網(wǎng)優(yōu)之經(jīng)緯度的那些事(1)

vbavsto 2018-10-10

展開全文

1 背景

這段時間被督導搞毛了，天天找我要一個兩個站的TAC，我說你能不能把本期要建設的都給我一起來規(guī)劃，他說不能。。。我也不想總被這么吵啊，畢竟我很忙的，那就寫個工具吧，so easy!

2 成品

導入polygon文件，輸入經(jīng)緯度，執(zhí)行獲取點所在的polygon。

3 實現(xiàn)過程

3.1 獲取polygon

最原始的方法，自己動手挨個畫，當然我肯定不會去做這么low的事，我肯定先百度，果不其然

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

很簡單的方法，但這樣出來的邊界區(qū)并不精確，正常的TAC區(qū)應該依街區(qū)、河流、山體等自然因素而定，沒關(guān)系，我們在這個基礎上再修改就是了。

隨后點表-導出-mif，一份完整的polygon文件就出爐了，mif文件記錄位置信息，mid文件記錄字段信息，結(jié)構(gòu)如下：

3.2 算法原理

1、理論支持：如果從需要判斷的點出發(fā)的一條射線與該多邊形的焦點個數(shù)為奇數(shù)，則該點在此多邊形內(nèi)，否則該點在此多邊形外。
2、編程思路：
該程序的思路是從A點出發(fā)向左做一條水平射線（平行于x軸，向X軸的反方向），判斷與各邊是否有焦點。
dLon1, dLon2, dLat1, dLat2分別表示邊的起點和終點的經(jīng)度和緯度（x軸和y軸）。
先判斷A點是否在邊的兩端點d1和d2的水平平行線之間，不在則不可能有交點，繼續(xù)判斷下一條邊。
在之間則說明可能與A點向左的射線有交點，接下來利用幾何方法得到A點的水平直線與該邊交點的x坐標。
然后判斷交點的x坐標在A點的左側(cè)還是右側(cè)，左側(cè)則總交點數(shù)加一，右側(cè)則不在A點左射線上，繼續(xù)判斷下一條邊。

繼續(xù)搬運工

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

大神是用Python寫的，對我們網(wǎng)優(yōu)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