frmmain.frm

MapInfo 行业应用源代码

End Sub


Private Sub mnuWindowArrangeIcons_Click()
    Me.Arrange vbArrangeIcons
End Sub

'新建浏览窗口
Private Sub mnuWindowBrowserWindow_Click()
    Dim TableName As String

    On Error Resume Next
    
    Call LoadNewForm
    MapInfo.RunMenuCommand M_WINDOW_BROWSE

    BrowserWinID = CLng(MapInfo.Eval("FrontWindow()"))
    TableName = MapInfo.Eval("WindowInfo(" & BrowserWinID & "," & WIN_INFO_TABLE & ")")

    FormBrowser = FormBrowser + 1
    ActiveForm.Caption = TableName + " Browser:" + Format(FormBrowser, "#0")
End Sub

Private Sub mnuWindowNewWindow_Click()
    Call LoadNewForm
    MapInfo.RunMenuCommand M_WINDOW_MAP

    mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
    ''Call UpdateMenuAndToolbar(True)
End Sub

Private Sub mnuWindowTileVertical_Click()
    Me.Arrange vbTileVertical
End Sub

Private Sub mnuWindowTileHorizontal_Click()
    Me.Arrange vbTileHorizontal
End Sub

Private Sub mnuWindowCascade_Click()
    Me.Arrange vbCascade
End Sub

Private Sub mnuViewStatusBar_Click()
mnuViewStatusBar.Checked = Not mnuViewStatusBar.Checked
sbStatusBar.Visible = mnuViewStatusBar.Checked
End Sub

Private Sub mnuViewToolbar_Click()
    mnuViewToolbar.Checked = Not mnuViewToolbar.Checked
    tbarMain.Visible = mnuViewToolbar.Checked
End Sub

Private Sub mnuEditPaste_Click()
MapInfo.RunMenuCommand M_EDIT_PASTE
Exit Sub
    On Error Resume Next
    ActiveForm.rtfText.SelRTF = Clipboard.GetText

End Sub

Private Sub mnuEditCopy_Click()
MapInfo.RunMenuCommand M_EDIT_COPY
End Sub

Private Sub mnuEditCut_Click()
MapInfo.RunMenuCommand M_EDIT_CUT
Exit Sub
    On Error Resume Next
    Clipboard.SetText ActiveForm.rtfText.SelRTF
    ActiveForm.rtfText.SelText = vbNullString

End Sub

Private Sub mnuEditUndo_Click()
MapInfo.RunMenuCommand M_EDIT_UNDO
End Sub


Private Sub mnuFileExit_Click()
Unload Me
End Sub

Private Sub mnuFilePrint_Click()
If ActiveForm Is Nothing Then Exit Sub
MapInfo.Do "Set Next Document Parent " & ActiveForm.hwnd & " Style 1"
MapInfo.RunMenuCommand M_FILE_PRINT

End Sub

Private Sub mnuFilePageSetup_Click()
MapInfo.RunMenuCommand M_FILE_PAGE_SETUP
End Sub

Private Sub mnuFileSave_Click()
MapInfo.RunMenuCommand M_FILE_SAVE

End Sub

Private Sub mnuFileClose_Click()
On Error GoTo Error

MapInfo.RunMenuCommand M_FILE_CLOSE

CloseSelectedLayer

If (mapWinID = 0) Then
    Unload ActiveForm
    Call UpdateMenuAndToolbar(False)
Else
    Call SetToolBarValue0
End If
Error:
End Sub

Private Sub mnuFileOpen_Click()
    Dim I As Integer, TableName As String
    
    RightIndex = ".TAB"
    
    If (InStr(LeftRightIndex, RightIndex) <= 0) Then
        LeftRightIndex = "*.TAB"
    End If
    If (TheInPathTabOrWor = "") Then
        TheInPathTabOrWor = TheInstallPath + "知识库\"
    End If
    
    FrmTAB.Show 1
    
    If (nTabOrWor = 0) Then Exit Sub
    
    For I = 1 To nTabOrWor
        TheInFile = TheInPathTabOrWor + TabOrWor(I)
        
        '表名
        TableName = TabOrWor(I)
        TableName = Left(TableName, Len(TableName) - 4)

        '开表
        MapInfo.Do "Open Table """ & TheInFile & """ as " & TableName
        If MapInfo.Eval("TableInfo(" & TableName & "," & TAB_INFO_MAPPABLE & ")") = "F" Then
            iMapper = 0
        Else
            iMapper = 1
        End If

        Call BrowserAddCreateTable(TableName, iMapper)
    Next I
    ReDim TabOrWor(1 To 1)
    nTabOrWor = 0
End Sub
Private Sub mnuFileNew_Click()
    Call OpenNewTable
End Sub


Private Sub NotQuery_Click()
    MapInfo.RunMenuCommand M_ANALYZE_UNSELECT
End Sub

Private Sub SQLQuery_Click()
    MapInfo.RunMenuCommand M_ANALYZE_SQLQUERY
End Sub

Private Sub tbarMain_ButtonClick(ByVal Button As ComctlLib.Button)
Dim nLayerName As Integer, LayerName As String, Col1 As String, ColN As Integer
Dim ADType As String, TZBM As String, FileM0 As String
Dim I As Integer, J As Integer, intPositionOfQuery As Integer, nSelect As Integer
Dim ThePictureFile As String, ThePicturePath As String, DirFile As String
Dim Index As Integer, TheXLFileName As String
Dim FileTIM1 As String, M As Integer, TheOutFileE00 As String

On Error GoTo Error

bExitSub = False

Call SetToolBarValue0

Select Case Button.Key
    Case "Select" '选择
        tbarMain.Buttons("Select").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_SELECTOR
    Case "Move" '移动图纸
        tbarMain.Buttons("Move").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_RECENTER
    Case "ZoomIn" '缩小
        tbarMain.Buttons("ZoomIn").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_SHRINK
    Case "ZoomOut" '放大
        tbarMain.Buttons("ZoomOut").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_EXPAND
    ''Case "ChangeView" '改变视图
    ''    tbarMain.Buttons("ChangeView").Value = 0
    ''    MapInfo.RunMenuCommand M_MAP_CHANGE_VIEW
    Case "SelectRect" '矩形选择
        tbarMain.Buttons("SelectRect").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_SEARCH_RECT
    Case "SelectCircle" '圆形选择
        tbarMain.Buttons("SelectCircle").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_SEARCH_RADIUS
    Case "SelectCreatePoly" '创建一个虚拟多边形区域,选择区域内的对象
        tbarMain.Buttons("SelectCreatePoly").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_SEARCH_POLYGON
    Case "SelectPoly" '多边形选择
        tbarMain.Buttons("SelectPoly").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_SEARCH_BOUNDARY
    ''Case "LayerControl" '图层控制
        ''MapInfo.RunMenuCommand M_MAP_LAYER_CONTROL
    Case "Ruler"
        MapInfo.RunMenuCommand M_TOOLS_RULER
        MapInfo.Do "Set Window Ruler Parent " & ActiveForm.hwnd & " Show"
        tbarMain.Buttons("Ruler").Value = 1
    Case "AntiSelect" '反选
        MapInfo.RunMenuCommand 311
    Case "ManMark" '手工标注
        tbarMain.Buttons("ManMark").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_LABELER
    'Case "ShowHideLegend" '显示/影藏图例
    '    MapInfo.RunMenuCommand M_WINDOW_LEGEND
    Case "Info_Point"
        MapInfo.Do "Run Menu Command ID 2001"
    Case "Info_Rect"
        MapInfo.Do "Run Menu Command ID 2002"
    Case "Symbol" '符号
        tbarMain.Buttons("Select").Value = 0
        tbarMain.Buttons("Symbol").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_POINT
    Case "Line" '直线
        tbarMain.Buttons("Select").Value = 0
        tbarMain.Buttons("Line").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_LINE
    Case "PolyLine"
        tbarMain.Buttons("Select").Value = 0
        tbarMain.Buttons("PolyLine").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_POLYLINE
    Case "Arc"
        tbarMain.Buttons("Select").Value = 0
        tbarMain.Buttons("Arc").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_ARC
    Case "Polygon" '创建多边形区域
        tbarMain.Buttons("Select").Value = 0
        tbarMain.Buttons("Polygon").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_POLYGON
    Case "Ellipse"
        tbarMain.Buttons("Select").Value = 0
        tbarMain.Buttons("Ellipse").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_ELLIPSE
    Case "Rectangle"
        tbarMain.Buttons("Select").Value = 0
        tbarMain.Buttons("Rectangle").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_RECTANGLE
    Case "RoundedRectangle"
        tbarMain.Buttons("Select").Value = 0
        tbarMain.Buttons("RoundedRectangle").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_ROUNDEDRECT
    Case "Text"
        tbarMain.Buttons("Select").Value = 0
        tbarMain.Buttons("Text").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_TEXT
    Case "ReShape"
        tbarMain.Buttons("Select").Value = 1
        tbarMain.Buttons("ReShape").Value = 1
        MapInfo.RunMenuCommand M_EDIT_RESHAPE
    Case "AddNode"
        tbarMain.Buttons("Select").Value = 0
        tbarMain.Buttons("AddNode").Value = 1
        MapInfo.RunMenuCommand M_TOOLS_ADD_NODE
    Case "SymbolStyle"
        tbarMain.Buttons("SymbolStyle").Value = 0
        MapInfo.RunMenuCommand M_FORMAT_PICK_SYMBOL
    Case "LineStyle"
        tbarMain.Buttons("LineStyle").Value = 0
        MapInfo.RunMenuCommand M_FORMAT_PICK_LINE
    Case "RegionStyle"
        tbarMain.Buttons("RegionStyle").Value = 0
        MapInfo.RunMenuCommand M_FORMAT_PICK_FILL
    Case "TextStyle"
        tbarMain.Buttons("TextStyle").Value = 0
         MapInfo.RunMenuCommand M_FORMAT_PICK_FONT
End Select
Exit Sub
Error:
Screen.MousePointer = 0
ADType = MsgBox("没有选中地图对象,可能是无可选图层！ ", vbOKOnly, "关于查询分析 ")
bExitSub = False
End Sub
Private Sub LoadStartUpWor()
    On Error Resume Next

    TheWorFile = App.Path + "\StartUp.wor"

    Call LoadNewForm
    ActiveForm.WindowState = 2
    MapInfo.Do "Run Application """ & TheWorFile & """"

    thereIsAMap = True

    mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
    MapInfo.Do "Set CoordSys Earth Projection 1,0"
    Call UpdateMenuAndToolbar(True)
    ActiveForm.Caption = "初始地图" + " Map"
End Sub
Public Sub OpenOldTables()
    On Error Resume Next
    
    mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
    
    If (mapWinID = 0 And TableName <> "") Then
        LoadNewForm
        MapInfo.Do "Map From " & TableName
        mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
        thereIsAMap = True
        
        ActiveForm.Caption = TableName + " Map"
        MapInfo.Do "Set Map Display Position"
        MapInfo.Do "Set Map Layer 0 Editable ON"
        MapInfo.Do "Set Map Zoom Entire"
        Call UpdateMenuAndToolbar(True)
    End If
End Sub

Private Sub SetToolBarValue0()
    tbarMain.Buttons("Select").Value = 1
    MapInfo.RunMenuCommand M_TOOLS_SELECTOR
    tbarMain.Buttons("Move").Value = 0
    tbarMain.Buttons("ZoomIn").Value = 0
    tbarMain.Buttons("ZoomOut").Value = 0
    ''tbarMain.Buttons("ChangeView").Value = 0
    tbarMain.Buttons("SelectRect").Value = 0
    tbarMain.Buttons("SelectCircle").Value = 0
    tbarMain.Buttons("SelectCreatePoly").Value = 0
    tbarMain.Buttons("SelectPoly").Value = 0
    ''tbarMain.Buttons("LayerControl").Value = 0
    tbarMain.Buttons("Ruler").Value = 0
    tbarMain.Buttons("ManMark").Value = 0

    tbarMain.Buttons("Symbol").Value = 0
    tbarMain.Buttons("Line").Value = 0
    tbarMain.Buttons("PolyLine").Value = 0
    tbarMain.Buttons("Arc").Value = 0
    tbarMain.Buttons("Polygon").Value = 0
    tbarMain.Buttons("Ellipse").Value = 0
    tbarMain.Buttons("Rectangle").Value = 0
    tbarMain.Buttons("RoundedRectangle").Value = 0
    tbarMain.Buttons("Text").Value = 0
    'tbarMain.Buttons("ReShape").Value = 0
    tbarMain.Buttons("AddNode").Value = 0
    tbarMain.Buttons("SymbolStyle").Value = 0
    tbarMain.Buttons("LineStyle").Value = 0
    tbarMain.Buttons("RegionStyle").Value = 0
    tbarMain.Buttons("TextStyle").Value = 0
End Sub


'判断表是否可地图化
Private Sub BrowserAddCreateTable(TableName As String, iMapper As Integer)
    If (iMapper = 0) Then
        LoadNewForm
    
        MapInfo.Do "Browse * from " & TableName
    
        BrowserWinID = CLng(MapInfo.Eval("FrontWindow()"))
        TableName = MapInfo.Eval("WindowInfo(" & BrowserWinID & "," & WIN_INFO_TABLE & ")")

        FormBrowser = FormBrowser + 1
        ActiveForm.Caption = TableName + " Browser:" + Format(FormBrowser, "#0")
    Else
        If thereIsAMap Then '已有一个地图,添加新图层
            ''If (MapinfoRunTime = True) Then
                MapInfo.Do "Add Map Layer " & TableName
                ActiveForm.Caption = TableName + "," + ActiveForm.Caption
            ''End If
        Else '创建新地图窗口
            LoadNewForm
            MapInfo.Do "Map From " & TableName
            mapWinID = CLng(MapInfo.Eval("FrontWindow()"))
            thereIsAMap = True
            ActiveForm.Caption = TableName + " Map"
            MapInfo.Do "Set Map Display Position"
            MapInfo.Do "Set Map Layer 0 Editable ON"
        End If
        Call UpdateMenuAndToolbar(True)
    End If
    ''MapInfo.do "Set Map XY Units ""degree"" Distance Units ""km"" Area Units ""sq km"""
End Sub