frmmain.frm

最短路径算法

    TheWorFile = TheInPathTabOrWor + TabOrWor(1)
    
    Call LoadNewForm
    ActiveForm.WindowState = 2
    MapInfo.Do "Run Application """ & TheWorFile & """"
    MapInfo.Do "Set Window Legend Parent " & ActiveForm.hwnd & " Position(6,5) Width 2  Height 2 hide"
    MapInfo.Do "Set Legend "

    thereIsAMap = True

    mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
    MapInfo.Do "Set CoordSys Earth Projection 1,0"
    Call UpdateMenuAndToolbar(True)
    ActiveForm.Caption = Left(TabOrWor(1), Len(TabOrWor(1)) - 4) + " Map"
    'Call UpdateTitleWor
End Sub

Private Sub menurecov_Click()
MapInfo.RunMenuCommand M_FILE_REVERT
End Sub

Private Sub menuSaveAsWor_Click()
    Dim I As Integer, J As Integer, Temp As String
    
    On Error Resume Next
    
    If (Len(TheWorFile) = 0) Then
        TheOutFile = "Temp"
    Else
        For I = Len(TheWorFile) To 1 Step -1
            If (Mid(TheWorFile, I, 1) = "\") Then
                TheOutFile = Right(TheWorFile, Len(TheWorFile) - I)
                Exit For
            End If
        Next I
    End If
    
    dlgOpenTable.DialogTitle = "保存工作空间(保存表)"
    dlgOpenTable.FileName = Left(TheOutFile, Len(TheOutFile) - 4)
    dlgOpenTable.Filter = "*.Wor"
    dlgOpenTable.InitDir = TheMapInfoPath
    dlgOpenTable.FilterIndex = 1
    dlgOpenTable.ShowSave
        
    If (Err <> 32755) Then '打开文件
        TheOutPath = dlgOpenTable.FileName
        TheOutFile = dlgOpenTable.FileTitle
        For I = Len(TheOutPath) To 1 Step -1
            If (Mid(TheOutPath, I, 1) = "\") Then Exit For
        Next I
        TheOutPath = Left(TheOutPath, I)

        DirFile = Dir(TheOutPath + TheOutFile)
        If (DirFile <> "") Then
            I = MsgBox(TheOutPath + TheOutFile + "文件已存在,是否覆盖? ", vbYesNo, "关于保存工作空间(保存表)")
            If (I = vbNo) Then Exit Sub
        End If
        
        mapWinID = CLng(MapInfo.Eval("FrontWindow()"))

        nLayerName = CInt(MapInfo.Eval("MapperInfo(" & mapWinID & ",9)"))
        
        TableName = ""
        For I = 1 To nLayerName
            LayerName = MapInfo.Eval("LayerInfo(" & mapWinID & "," & I & ",1)")
            J = InStr(LayerName, Chr(0))
            If (J > 0) Then LayerName = Left(LayerName, J - 1)
            MapInfo.Do "Commit Table """ & LayerName & """ As """ & TheOutPath + LayerName & ".TAB"" TYPE NATIVE Charset ""WindowsSimpChinese"""
        Next I
        I = InStr(TheOutFile, ".")
        If (I = 0) Then
            TheOutFile = TheOutFile + ".WOR"
        End If
        MapInfo.Do "Save Workspace As """ & TheOutPath + "TempTMP"""
        
        Open TheOutPath + "TempTMP" For Input As #1
        Open TheOutPath + TheOutFile For Output As #2
        Do While Not EOF(1)
            Line Input #1, Temp
            I = InStr(Temp, "\")
            If (I > 0) Then
                For I = Len(Temp) To 1 Step -1
                    If (Mid(Temp, I, 1) = "\") Then Exit For
                Next I
               Temp = "Open Table """ + Right(Temp, Len(Temp) - I)
            End If
            Print #2, Temp
        Loop
        Close (1)
        Close (2)
        Kill TheOutPath + "TempTMP"
    End If
End Sub
Private Sub menusavewindow_Click()
    Dim I As Integer, J As Integer, nLayerName As String, LayerName As String, FileType As String
    ''MapInfo.RunMenuCommand M_FILE_SAVE_WINDOW_AS

    nLayerName = CInt(MapInfo.Eval("MapperInfo(" & mapWinID & "," & MAPPER_INFO_LAYERS & ")"))
    For I = 1 To nLayerName
        LayerName = MapInfo.Eval("TableInfo(" & I & "," & TAB_INFO_NAME & ")")
        J = InStr(LayerName, Chr(0))
        If (J > 0) Then LayerName = Left(LayerName, J - 1)
        Exit For
    Next I
    TheOutFile = ThePublicPicturePath + LayerName + ".JPG"
    
    SaveMap.Show 1
    If (bOKCancel = True) Then
        FileType = Right(TheOutFile, 3)
        Select Case FileType
            Case "WMF"
                FileType = "WMF"
            Case "JPG"
                FileType = "JPEG"
            Case "TIF"
                FileType = "TIFF"
            Case Else
                FileType = "BMP"
        End Select
        On Error GoTo Error
        MapInfo.Do "Save Window  " & mapWinID & " As  """ & TheOutFile & """ Type """ & FileType & """ Width " & mmPaperWidth & " units ""mm"" Height " & mmPaperHeight & " units ""mm"""
        Exit Sub
Error:
        MsgBox "该版本的MapInfo不支持" + FileType + "格式!" + Chr(10) + Chr(13) + "请选用更高版本的MapInfo", vbOKOnly, "关于存储图象!"
    End If
End Sub
Private Sub menusavewor_Click()
    MapInfo.RunMenuCommand M_FILE_SAVE_WORKSPACE
End Sub

Private Sub menuTableColomnUpDate_Click()
MapInfo.RunMenuCommand M_TABLE_UPDATE_COLUMN
End Sub

Private Sub menuTableStruture_Click()
MapInfo.RunMenuCommand M_TABLE_MODIFY_STRUCTURE
End Sub

Private Sub menuWindowLayerOut_Click()
Call LoadNewForm
MapInfo.RunMenuCommand M_WINDOW_LAYOUT

End Sub

Private Sub menuWindowStatisticWindow_Click()
Call LoadNewForm
MapInfo.RunMenuCommand M_WINDOW_GRAPH
End Sub

Private Sub mnuEditDel_Click()
MapInfo.RunMenuCommand M_EDIT_CLEAR
End Sub

Private Sub mnuEditDelMap_Click()
MapInfo.RunMenuCommand M_EDIT_CLEAROBJ
End Sub

Private Sub mnuEditGetInfo_Click()
MapInfo.RunMenuCommand M_EDIT_GETINFO
End Sub

Private Sub mnuEditNewRow_Click()
MapInfo.RunMenuCommand M_EDIT_NEW_ROW
End Sub

Private Sub mnuEditShapes_Click()
MapInfo.RunMenuCommand M_EDIT_RESHAPE
End Sub


Private Sub mnuFileSaveAs_Click()
MapInfo.RunMenuCommand M_FILE_SAVE_COPY_AS
End Sub

Private Sub MnuMapChangeView_Click()
MapInfo.RunMenuCommand M_MAP_CHANGE_VIEW
End Sub

Private Sub mnuMapClearCosmetic_Click()
MapInfo.RunMenuCommand M_MAP_CLEAR_COSMETIC
End Sub

Private Sub mnuMapClearCustomLabels_Click()
MapInfo.RunMenuCommand M_MAP_CLEAR_CUSTOM_LABELS
End Sub

Private Sub mnuMapCloseClip_Click()
MapInfo.RunMenuCommand M_MAP_CLIP_REGION_ONOFF
End Sub

Private Sub mnuMapCopyView_Click()
Call LoadNewForm
mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
MapInfo.RunMenuCommand M_MAP_CLONE_MAPPER
End Sub

Private Sub mnuMapCreate3DMap_Click()
    Call LoadNewForm
    ''mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
    MapInfo.RunMenuCommand 817
End Sub

Private Sub mnuMapCreateLegend_Click()
    Call LoadNewForm
    ''mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
    MapInfo.RunMenuCommand 816
End Sub

Private Sub mnuMapCreateLZMap_Click()
    Call LoadNewForm
    ''mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
    MapInfo.RunMenuCommand 818
End Sub

Private Sub mnuMapEntireLayer_Click()
MapInfo.RunMenuCommand M_MAP_ENTIRE_LAYER
End Sub


Private Sub mnuMapLayer_Click()
MapInfo.RunMenuCommand M_MAP_LAYER_CONTROL
Call EnabledMenuAndToolbar
End Sub

Private Sub mnuMapOptions_Click()
MapInfo.RunMenuCommand M_MAP_OPTIONS
End Sub

Private Sub mnuMapSaveCosmetic_Click()
MapInfo.RunMenuCommand M_MAP_SAVE_COSMETIC

End Sub

Private Sub mnuMapSetClip_Click()
MapInfo.RunMenuCommand M_MAP_SET_CLIP_REGION
End Sub

Private Sub mnuObjects_BUFFER_Click()
MapInfo.RunMenuCommand M_OBJECTS_BUFFER
End Sub

Private Sub mnuObjects_Clear_Target_Click()
MapInfo.RunMenuCommand M_OBJECTS_CLEAR_TARGET
End Sub

Private Sub mnuObjects_Combine_Click()
MapInfo.RunMenuCommand M_OBJECTS_COMBINE
End Sub


Private Sub mnuObjects_CVT_PGON_Click()
MapInfo.RunMenuCommand M_OBJECTS_CVT_PGON
End Sub

Private Sub mnuObjects_CVT_PLINE_Click()
MapInfo.RunMenuCommand M_OBJECTS_CVT_PLINE
End Sub


Private Sub mnuObjects_ERASE_Click()
MapInfo.RunMenuCommand M_OBJECTS_ERASE
End Sub

Private Sub mnuObjects_ERASE_OUT_Click()
MapInfo.RunMenuCommand M_OBJECTS_ERASE_OUT
End Sub


Private Sub mnuObjects_OVERLAY_Click()
MapInfo.RunMenuCommand M_OBJECTS_OVERLAY
End Sub


Private Sub mnuObjects_Set_Target_Click()
MapInfo.RunMenuCommand M_OBJECTS_SET_TARGET
End Sub

Private Sub mnuObjects_SMOOTH_Click()
MapInfo.RunMenuCommand M_OBJECTS_SMOOTH
End Sub

Private Sub mnuObjects_SPLIT_Click()
MapInfo.RunMenuCommand M_OBJECTS_SPLIT
End Sub

Private Sub mnuObjects_unCombine_Click()
MapInfo.RunMenuCommand 1621
End Sub

Private Sub mnuObjects_UNSMOOTH_Click()
MapInfo.RunMenuCommand M_OBJECTS_UNSMOOTH
End Sub

Private Sub mnuObjectsCheckError_Click()
    MapInfo.RunMenuCommand 1619
End Sub

Private Sub mnuObjectsCheckRegions_Click()
    MapInfo.RunMenuCommand 1618
End Sub

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 mnuShortPath_Click()
    Dim ShortPath As Double
    Dim TheInFileNode As String, TheInFileLine As String
    Dim LonNode() As Double, LatNode() As Double, NoNode() As Integer, nNode As Integer
    Dim LineNode() As Integer, LineDis() As Double, nLineNode As Integer
    Dim LinkN() As Integer, LinkNi() As Integer, LinkDis() As Double, LinkNo() As Integer
    Dim StartNo As Integer, EndNo As Integer
    Dim No(1 To 11, 1 To 2) As Integer
    Dim ShortDis As Single
    Dim NodeShortPath() As Integer, nNodeShortPath As Integer
    Dim I As Integer
    Dim TheOutPath As String, TableName As String
    
    TheOutPath = App.Path + "\知识库\"
    TheInFileNode = TheOutPath + "中国主干公路节点.MID"
    TheInFileLine = TheOutPath + "中国主干公路线.MID"
    Call ShortPathData(TheInFileNode, TheInFileLine, LonNode, LatNode, NoNode, nNode, LineNode, LineDis, nLineNode, LinkN, LinkNi, LinkDis, LinkNo)
    
    No(1, 1) = 453
    No(1, 2) = 375
    
    No(2, 1) = 119
    No(2, 2) = 457
    
    No(3, 1) = 456
    No(3, 2) = 353
    
    No(4, 1) = 313
    No(4, 2) = 443
    
    No(5, 1) = 436
    No(5, 2) = 443
    
    No(6, 1) = 443
    No(6, 2) = 436
    
    No(7, 1) = 1
    No(7, 2) = 277
    
    No(8, 1) = 313
    No(8, 2) = 420
    
    No(9, 1) = 231
    No(9, 2) = 436
    
    No(10, 1) = 231
    No(10, 2) = 443
    
    No(11, 1) = 231
    No(11, 2) = 454
    
    I = 11
    StartNo = No(I, 1)
    EndNo = No(I, 2)
    Call ShortPathSearch(StartNo, EndNo, nNode, NoNode, LinkN, LinkNi, LinkNo, LinkDis, nNodeShortPath, NodeShortPath, ShortPath)

    TableName = "最短路径" + Format(StartNo, "####0_") + Format(EndNo, "###0")
    Call ShortPathPlot(TheOutPath, TableName, nNode, LonNode, LatNode, NoNode, nNodeShortPath, NodeShortPath)
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