frmmain.frm

求最短路径的vb程序,可以根据需要社顶路径的名称来实现最短路径的求借

Private Sub mnuObjectsConvexHull_Click()
    MapInfo.RunMenuCommand 1616
End Sub

Private Sub mnuObjectsLineClose_Click()
    MapInfo.RunMenuCommand 1617
End Sub


Private Sub mnuOld_Click()
Call menuallclose_Click

Call LoadStartUpWor
End Sub


Private Sub mnuSaveDefaultWor_Click()
    MapInfo.Do "Save Workspace As """ & TheInstallPath & "StartUp.Wor"""
End Sub

Private Sub mnuTableAddRow_Click()
MapInfo.RunMenuCommand M_TABLE_APPEND
End Sub

Private Sub mnuTableCombineObject_Click()
MapInfo.RunMenuCommand M_TABLE_MERGE_USING_COLUMN
End Sub

Private Sub mnuTableCreatePoint_Click()
MapInfo.RunMenuCommand M_TABLE_CREATE_POINTS
End Sub

Private Sub mnuTableDelTable_Click()
MapInfo.RunMenuCommand M_TABLE_DELETE
End Sub

Private Sub mnuTableExport_Click()
MapInfo.RunMenuCommand M_TABLE_EXPORT
End Sub

Private Sub mnuTableGeoCode_Click()
MapInfo.RunMenuCommand M_TABLE_GEOCODE
End Sub


Private Sub mnuTableImport_Click()
MapInfo.RunMenuCommand M_TABLE_IMPORT
End Sub

Private Sub mnuTablePack_Click()
MapInfo.RunMenuCommand M_TABLE_PACK
End Sub

Private Sub mnuTableRenameTable_Click()
MapInfo.RunMenuCommand M_TABLE_RENAME
End Sub


Private Sub mnuTabPMT_Click()
    Dim ThePublicOutPath As String
    
    ThePublicOutPath = App.Path + "\"
    
    Call PMTTableSearch(ThePublicOutPath)
End Sub
Private Sub PMTTableSearch(ThePublicOutPath As String)
    Dim I As Integer, N As Integer, M As Integer
    Dim LayerName As String, LayerNames() As String, LayerNameField() As String, LayerNameN As Integer
    Dim TableName As String, Columns() As String, ColumnsType() As String, ColumnsN As Integer
    Dim Col1 As String
    Dim TheOutFilePMT As String
    Dim Row As Long, RowN As Long
    Dim Elevs() As Single, ElevsN As Long, Elev As Single
    Dim nNode As Integer
    Dim Lat() As Single, Lon() As Single, High() As Single, Dis() As Single, bUse() As Byte, No() As Long, LatLonN As Long, LatLonNt As Long
    Dim Lat1 As Single, Lon1 As Single, Lat2 As Single, Lon2 As Single, Imin As Long
    Dim S As Single
    Dim X1 As Single, Y1 As Single, X2 As Single, Y2 As Single
    Dim LatOld() As Single, LonOld() As Single, nNodeOld As Long
    Dim bYes As Boolean, ExistFile As String
    Dim Smin As Single, Smax As Single
    Dim LatMin As Single, LatMax As Single
    Dim LonMin As Single, LonMax As Single
    Dim HighMin As Single, HighMax As Single
    Dim Obj_Info_Types As Integer
    Dim MapperInfoCoordSys As String
    Dim Temp As String, TMP As String

    '查看是否有Selection表
    LayerName = MapInfo.Eval("SelectionInfo(" & SEL_INFO_TABLENAME & ")")
    I = InStr(LayerName, Chr(0))
    If (I > 0) Then LayerName = Left(LayerName, I - 1)

    If (LayerName = "" Or LayerName = "Cosmetic1") Then '无Selection表,看装饰图层中是否有线条、折线
        '选择裁减区域
        MapInfo.Do "Select * From Cosmetic1 Where Object"
        N = Val(MapInfo.Eval("SelectionInfo(3)"))
        If (N = 1) Then
            Obj_Info_Types = MapInfo.Eval("ObjectInfo(Selection.OBJ," & OBJ_INFO_TYPE & ")")
            If (Obj_Info_Types = 3 Or Obj_Info_Types = 4) Then
                '判断是否有等高线表或等值线图
                mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
                nLayerName = CInt(MapInfo.Eval("MapperInfo(" & mapWinID & "," & MAPPER_INFO_LAYERS & ")"))
                LayerName = ""
                ReDim LayerNames(1 To nLayerName), LayerNameField(1 To nLayerName)
                LayerNameN = 0
                For I = 1 To nLayerName
                    TableName = Trims(MapInfo.Eval("TableInfo(" & I & "," & TAB_INFO_NAME & ")"))
                    Col1 = Trims(MapInfo.Eval("ColumnInfo(""" & TableName & """,""col1"",1)"))
                    If (Col1 = "等值线值" Or Col1 = "高程") Then
                        LayerNameN = LayerNameN + 1
                        LayerNames(LayerNameN) = TableName
                        LayerNameField(LayerNameN) = Col1
                    End If
                Next I
                If (LayerNameN = 0) Then
                    MsgBox "无等值线表，不能进行剖面分析! ", vbOKOnly, "关于剖面分析 "
                    Exit Sub
                End If
            Else
                MapInfo.Do "Set Map Layer 0 Editable ON"
                MapInfo.Do "Delete from Cosmetic1"
                'MapInfo.RunMenuCommand M_MAP_CLEAR_COSMETIC
                MsgBox "请用直线或折线工具在‘装饰图层’上画出一个剖面！ ", vbOKOnly, "关于剖面分析 "
                Exit Sub
            End If
        Else
            MapInfo.Do "Set Map Layer 0 Editable ON"
            MapInfo.Do "Delete from Cosmetic1"
            MsgBox "请用直线或折线工具在‘装饰图层’上画出一个剖面！ ", vbOKOnly, "关于剖面分析 "
            Exit Sub
        End If
    Else
        Col1 = UCase(MapInfo.Eval("ColumnInfo(""" & LayerName & """,""col1"",1)"))
        I = MapInfo.Eval("SelectionInfo(" & SEL_INFO_NROWS & ")")
        If (I = 1) Then
            Obj_Info_Types = MapInfo.Eval("ObjectInfo(Selection.OBJ," & OBJ_INFO_TYPE & ")")
            If (Obj_Info_Types = 3 Or Obj_Info_Types = 4) Then
                '判断是否有等高线表或等值线图
                mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
                nLayerName = CInt(MapInfo.Eval("MapperInfo(" & mapWinID & "," & MAPPER_INFO_LAYERS & ")"))
                LayerName = ""
                ReDim LayerNames(1 To nLayerName), LayerNameField(1 To nLayerName)
                LayerNameN = 0
                For I = 1 To nLayerName
                    TableName = Trims(MapInfo.Eval("TableInfo(" & I & "," & TAB_INFO_NAME & ")"))
                    Col1 = Trims(MapInfo.Eval("ColumnInfo(""" & TableName & """,""col1"",1)"))
                    If (Col1 = "等值线值" Or Col1 = "等值线" Or Col1 = "等高线" Or Col1 = "高程线" Or Col1 = "高程" Or Col1 = "elev") Then
                        LayerNameN = LayerNameN + 1
                        LayerNames(LayerNameN) = TableName
                        LayerNameField(LayerNameN) = Col1
                    End If
                Next I
                If (LayerNameN = 0) Then
                    MsgBox "无等值线表，不能进行剖面分析! ", vbOKOnly, "关于剖面分析 "
                    Exit Sub
                End If
            Else
                MapInfo.Do "Set Map Layer 0 Editable ON"
                MapInfo.Do "Delete from Cosmetic1"
                MapInfo.RunMenuCommand M_MAP_CLEAR_COSMETIC
                MsgBox "请用直线或折线工具在‘装饰图层’上画出一个剖面！ ", vbOKOnly, "关于剖面分析 "
                Exit Sub
            End If
        Else
            MapInfo.Do "Set Map Layer 0 Editable ON"
            MapInfo.Do "Delete from Cosmetic1"
            MsgBox "请用直线或折线工具在‘装饰图层’上画出一个剖面！ ", vbOKOnly, "关于剖面分析 "
            Exit Sub
        End If
    End If

    Call WaitOpen
    Call WaitCaption("正在创建剖面图！")
    

    '获取当前显示投影参数
    mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
    MapperInfoCoordSys = MapInfo.Eval("MapperInfo(" & mapWinID & ",17)")

    MapInfo.Do "Fetch Last From Selection"
    MapInfo.Do "OBJ_Temp=Selection.OBJ"

    MapInfo.Do "Set CoordSys Earth Projection 1,0"
    'Begin搜索剖面线节点起点
    I = MapInfo.Eval("ObjectInfo(Selection.OBJ," & OBJ_INFO_TYPE & ")")
    If (Obj_Info_Types = 3) Then
        nNodeOld = 2
        ReDim LonOld(1 To nNodeOld), LatOld(1 To nNodeOld)
        LonOld(1) = Val(MapInfo.Eval("ObjectGeography(OBJ_Temp,1)"))
        LatOld(1) = Val(MapInfo.Eval("ObjectGeography(OBJ_Temp,2)"))
        
        LonOld(2) = Val(MapInfo.Eval("ObjectGeography(OBJ_Temp,3)"))
        LatOld(2) = Val(MapInfo.Eval("ObjectGeography(OBJ_Temp,4)"))
    Else
        nNodeOld = Val(MapInfo.Eval("ObjectInfo(OBJ_Temp, 20)"))
        ReDim LonOld(1 To nNodeOld), LatOld(1 To nNodeOld)
        For I = 1 To nNodeOld
            LonOld(I) = Val(MapInfo.Eval("ObjectNodeX(OBJ_Temp, 1, " & I & ")"))
            LatOld(I) = Val(MapInfo.Eval("ObjectNodeY(OBJ_Temp, 1, " & I & ")"))
        Next I
    End If
    
    Lon1 = LonOld(1)
    Lat1 = LatOld(1)
    
    Lon2 = LonOld(nNodeOld)
    Lat2 = LatOld(nNodeOld)
    
    If (Lon2 < Lon1) Then
        Lon1 = Lon2
        Lat1 = Lat2
    ElseIf (Lon2 = Lon1 And Lat2 < Lat1) Then
        Lon1 = Lon2
        Lat1 = Lat2
    End If
    'End搜索剖面线节点起点
            
    'Begin创建剖面表----------------
    I = 0
    Do
        I = I + 1
        
        TableName = "剖面图表" + Format(I, "###0")
        TheOutFile = TheMapInfoPath + TableName + ".TAB"
        DirFile = Dir(TheOutFile)
        If (DirFile = "") Then
            Exit Do
        End If
    Loop
    
    I = 0
    Do
        I = I + 1
        
        TheOutFilePMT = ThePublicOutPath + "剖面图" + Format(I, "###0") + ".PMT"
        DirFile = Dir(TheOutFilePMT)
        If (DirFile = "") Then
            Exit Do
        End If
    Loop
    
    '''ExistFile = MapInfo.Eval("TABLEINFO(" & TableName & ",5)")
    If (ExistFile = "") Then '创建一个条带表
        ColumnsN = 1
        ReDim Columns(1 To ColumnsN), ColumnsType(1 To ColumnsN)

        Columns(1) = "剖面图文件名"
        ColumnsType(1) = "Char(50)"

        Temp = "("
        For I = 1 To ColumnsN - 1
            Temp = Temp + Columns(I) + " " + ColumnsType(I) + ","
        Next I

        Columns(ColumnsN) = Trim(Columns(ColumnsN))
        ColumnsType(ColumnsN) = UCase(Trim(ColumnsType(ColumnsN)))
   
        Temp = Temp + Columns(ColumnsN) + " " + ColumnsType(ColumnsN) + ")"
        
        '创建一个新表
        MapInfo.Do "Create Table " + TableName + Temp + " FILE """ + TheMapInfoPath + TableName + """"
        '使表可地图化
        MapInfo.Do "Create Map For " & TableName & " " & MapperInfoCoordSys
    End If

    '创建剖面字段
    MapInfo.Do "Insert Into " & TableName & "(剖面图文件名,Object) values (""" & TheOutFilePMT & """,OBJ_Temp)"
    
    '新表存盘
    MapInfo.Do "Commit Table """ & TableName & """"

    If (ExistFile = "") Then
        MapInfo.Do "Add Map Layer " & TableName
    End If
    'End创建剖面表----------------
        
    'Begin创建临时图层
    MapInfo.Do "Create Table 临时图层 " + Temp + " FILE """ + TheMapInfoPath + "临时图层.TAB"""
    MapInfo.Do "Create Map For 临时图层 " & MapperInfoCoordSys
    MapInfo.Do "Insert Into 临时图层(Object) values (OBJ_Temp)"
    MapInfo.Do "Commit Table ""临时图层"""
    'End创建临时图层

    MapInfo.Do "Set map redraw off"
    
    'Begin等高线图层循环----------
    ReDim Elevs(1 To 1000)
    LatLonNt = 1000
    ReDim Lat(1 To LatLonNt), Lon(1 To LatLonNt), High(1 To LatLonNt), bUse(1 To LatLonNt)
    LatLonN = 0
    
    For nLayerName = 1 To LayerNameN
        LayerName = LayerNames(nLayerName)
        
        MapInfo.Do "Set " & MapperInfoCoordSys

        '选择剖面线设置为目标
        RowN = Val(MapInfo.Eval("TableInfo(" & TableName & "," & TAB_INFO_NROWS & ")"))
        MapInfo.Do "Select  * From " & TableName & " Where RowID=" & RowN
        MapInfo.Do "Set Target On"

        'Begin搜索不同等高线值
        Col1 = LayerNameField(nLayerName)
        MapInfo.Do "Select " & Col1 & " From " & LayerName & " Order By " & Col1

        '叠压节点
        MapInfo.Do "Objects Overlay Into Target"


        Call WaitCaption("正在搜索不同等高线值！")
        
        'Begin搜索不同等高线值
        MapInfo.Do "Select " & Col1 & " From " & LayerName & " Order By " & Col1
        RowN = Val(MapInfo.Eval("SelectionInfo(3)"))
        Call WaitMinMax(1, RowN)
        
        Elev = -9999999999#
        Row = 0
        ElevsN = 0
        Do While Row < RowN
            Row = Row + 1
            
            Call WaitValue(Row)
            MapInfo.Do "Fetch Rec " & Row & " From  Selection"
            ElevCur = Val(MapInfo.Eval(LayerName & "." & Col1))
            If (ElevCur <> Elev) Then
                ElevsN = ElevsN + 1
                
                Elevs(ElevsN) = ElevCur
            End If
            Elev = ElevCur
        Loop
        'End搜索不同等高线值
    
        Call WaitCaption("正在求等高线值与剖面的交点！")
        Call WaitMinMax(1, ElevsN)
        For Row = 1 To ElevsN
            Call WaitValue(Row)
            
            MapInfo.Do "Close Table Selection Interactive"
        
            '删除装饰图层上的全部对象
            MapInfo.Do "Close Table 临时图层" 'Interactive"
            MapInfo.Do "Open Table """ & TheMapInfoPath & "临时图层.TAB"" as 临时图层"
            MapInfo.Do "Add Map Layer 临时图层"
            MapInfo.Do "Select  * From 临时图层"
            MapInfo.Do "Set Target On"

            Elev = Elevs(Row)
            MapInfo.Do "Select " & Col1 & " From " & LayerName & " Where " & Col1 & "=" & Elev
            
            '叠压节点
            MapInfo.Do "Objects Overlay Into Target"
            
            MapInfo.Do "Fetch Last From 临时图层"
            MapInfo.Do "OBJ_Temp1=临时图层.OBJ"
        
            Obj_Info_Types = MapInfo.Eval("ObjectInfo(OBJ_Temp1," & OBJ_INFO_TYPE & ")")
            
            If (Obj_Info_Types = 4) Then
                '搜索节点
                nNode = Val(MapInfo.Eval("ObjectInfo(OBJ_Temp1, 20)"))

                If (LatLonN + nNode > LatLonNt) Then
                    LatLonNt = LatLonN + nNode
                    ReDim Preserve Lat(1 To LatLonNt), Lon(1 To LatLonNt), High(1 To LatLonNt), bUse(1 To LatLonNt)
                End If
                MapInfo.Do "Set CoordSys Earth Projection 1,0"
                For I = 2 To nNode - 1
                    Lon2 = Val(MapInfo.Eval("ObjectNodeX(OBJ_Temp1, 1, " & I & ")"))
                    Lat2 = Val(MapInfo.Eval("ObjectNodeY(OBJ_Temp1, 1, " & I & ")"))
        
                    '判断是否是原有