网优之经纬度的那些事(1)

vbavsto 2018-10-10

展开全文

1 背景

这段时间被督导搞毛了，天天找我要一个两个站的TAC，我说你能不能把本期要建设的都给我一起来规划，他说不能。。。我也不想总被这么吵啊，毕竟我很忙的，那就写个工具吧，so easy!

2 成品

导入polygon文件，输入经纬度，执行获取点所在的polygon。

3 实现过程

3.1 获取polygon

最原始的方法，自己动手挨个画，当然我肯定不会去做这么low的事，我肯定先百度，果不其然

https://wenku.baidu.com/view/7721aca00066f5335b81218d.html

很简单的方法，但这样出来的边界区并不精确，正常的TAC区应该依街区、河流、山体等自然因素而定，没关系，我们在这个基础上再修改就是了。

随后点表-导出-mif，一份完整的polygon文件就出炉了，mif文件记录位置信息，mid文件记录字段信息，结构如下：

3.2 算法原理

1、理论支持：如果从需要判断的点出发的一条射线与该多边形的焦点个数为奇数，则该点在此多边形内，否则该点在此多边形外。
2、编程思路：
该程序的思路是从A点出发向左做一条水平射线（平行于x轴，向X轴的反方向），判断与各边是否有焦点。
dLon1, dLon2, dLat1, dLat2分别表示边的起点和终点的经度和纬度（x轴和y轴）。
先判断A点是否在边的两端点d1和d2的水平平行线之间，不在则不可能有交点，继续判断下一条边。
在之间则说明可能与A点向左的射线有交点，接下来利用几何方法得到A点的水平直线与该边交点的x坐标。
然后判断交点的x坐标在A点的左侧还是右侧，左侧则总交点数加一，右侧则不在A点左射线上，继续判断下一条边。

继续搬运工

https://blog.csdn.net/bluehawksky/article/details/51669994

大神是用Python写的，对我们网优er来说，vba显然使用更便捷，改改就好了，编程语言无所谓，反正我全靠CTRL+CV。

4 我的代码

Sub mif()
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Filters.Clear
        .InitialFileName = ThisWorkbook.Path
        .Filters.Add "Mif Files", "*.mif"
        .Filters.Add "All Files", "*.*"
        If .Show = -1 Then
            Path = .SelectedItems(1)
            Sheets("Polygon").Range("F1") = Path
        Else
            Exit Sub
        End If
    End With
End Sub
Function chkRow(s) As Boolean
    Dim c As Range, reg
    Set reg = CreateObject("vbscript.regexp")
    reg.Pattern = "^(\d+(\.\d+)?)[ ](\d+(\.\d+)?)"
    chkRow = reg.Test(s)
End Function
Sub main()
With Sheets("Polygon")
    If .Range("F1") = "" Then Exit Sub
    Path = .Range("F1")
    m = 0
    n = 0
    i = -1
    Dim midArr() As String
    Dim textArr() As String
    Dim lonArr() As String
    Dim latArr() As String
    Open Replace(Path, ".MIF", ".MID") For Input As #1
        Do Until EOF(1)
            Line Input #1, textLine
            ReDim Preserve midArr(m + 1)
            midArr(m) = Replace(Split(textLine, ",")(0), """", "")
            m = m + 1
        Loop
    Close #1
    Open Path For Input As #1
        Do Until EOF(1)
            Line Input #1, textLine
            If textLine = "Region  1" Then
                i = i + 1
            End If
            If chkRow(textLine) = True Then
                ReDim Preserve textArr(n + 1)
                ReDim Preserve lonArr(n + 1)
                ReDim Preserve latArr(n + 1)
                textArr(n) = midArr(i)
                lonArr(n) = Split(textLine, " ")(0)
                latArr(n) = Split(textLine, " ")(1)
                n = n + 1
            End If
        Loop
    Close #1
    For j = 3 To .Range("B1000000").End(xlUp).Row  '遍历点
        aLon = .Cells(j, 2) * 1
        aLat = .Cells(j, 3) * 1
        iSum = 0
        For k = 0 To n - 1   '遍历polygon顶点
            If textArr(k) = textArr(k + 1) Then
                pLon1 = Val(lonArr(k))
                pLat1 = Val(latArr(k))
                pLon2 = Val(lonArr(k + 1))
                pLat2 = Val(latArr(k + 1))
                If ((aLat >= pLat1) And (aLat < pLat2)) Or ((aLat >= pLat2) And (aLat < pLat1)) Then
                    If (Abs(pLat1 - pLat2) > 0) Then
                        pLon = pLon1 - ((pLon1 - pLon2) * (pLat1 - aLat)) / (pLat1 - pLat2)
                        If (pLon < aLon) Then
                            iSum = iSum + 1
                        End If
                    End If
                End If
            ElseIf textArr(k) <> textArr(k + 1) Or k - n = 2 Then
                If iSum Mod 2 <> 0 Then
                    .Cells(j, 4) = textArr(k)
                    Exit For
                Else
                    .Cells(j, 4) = "N/A"
                End If
            End If
        Next
    Next
End With
MsgBox "完成！"
End Sub