frmmain.frm

师兄做的一个利用VB结合mapx组件做的超市查询小系统

  
End Sub

Private Sub Form_Unload(Cancel As Integer)
  SetWindowLong MapDisp.hWnd, GWL_WNDPROC, Oldwinproc
  
End Sub



Private Sub lstName_DblClick()
  
  Dim oDS As MapXLib.DataSet
  Dim Fld As MapXLib.Field
  Dim Ftr As MapXLib.Feature
  
  MapDisp.Layers("商场、超市").Selection.ClearSelection
  
  For Each Ftr In MapDisp.Layers("商场、超市").AllFeatures
      If Ftr.KeyValue = Trim(lstName.List(lstName.ListIndex)) Then
        Set FoundObj = Ftr
        fs_Color = FoundObj.Style.SymbolFontColor
        MapDisp.CenterX = FoundObj.CenterX
        MapDisp.CenterY = FoundObj.CenterY
        MapDisp.Zoom = 2
        MapDisp.Layers("商场、超市").Selection.Add Ftr
      End If
  Next
  
End Sub

Private Sub Mapdisp_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  MapDisp.ConvertCoord x, y, XDown, YDown, miScreenToMap
  XDown = Format(XDown, "#.0000")
  YDown = Format(YDown, "#.0000")
  Me.MapStatusBar.Panels(1).Text = CStr(XDown) + "米" + "," + CStr(YDown) + "米"
End Sub

Private Sub Mapdisp_PolyToolUsed(ByVal ToolNum As Integer, ByVal Flags As Long, ByVal Points As Object, ByVal bShift As Boolean, ByVal bCtrl As Boolean, EnableDefault As Boolean)
    Dim DisSum As Double
    Dim Dis As Double
    Dim N As Integer
    Dim pts As New MapXLib.Points
    Dim X1 As Double, Y1 As Double, X2 As Double, Y2 As Double
    
    Dim i As Integer
    
    Set pts = Points
    
    For i = 1 To pts.Count - 1
        X1 = pts.Item(i).x
        Y1 = pts.Item(i).y
        X2 = pts.Item(i + 1).x
        Y2 = pts.Item(i + 1).y
        Dis = Sqr((X1 - X2) ^ 2 + (Y1 - Y2) ^ 2)
        DisSum = DisSum + Dis
    Next i
    DisSum = Format(DisSum / 1000, "#.0000")
    Me.MapStatusBar.Panels(2).Text = Str(DisSum) + " 公里"
End Sub

Private Sub MapDisp_SelectionChanged()
    If m_bSelect = True And b_Select = True Then
      Load frmIdentify
      frmIdentify.InitData (lstLayers.List(lstLayers.ListIndex))
    End If
    m_bSelect = False
    
    If NameFindIndex = 1 Then
        Set FoundObj.Style.SymbolFontColor = fs_Color
        FoundObj.Update
    End If
    
End Sub

Private Sub MapDisp_ToolUsed(ByVal ToolNum As Integer, ByVal X1 As Double, ByVal Y1 As Double, ByVal X2 As Double, ByVal Y2 As Double, ByVal Distance As Double, ByVal Shift As Boolean, ByVal Ctrl As Boolean, EnableDefault As Boolean)
    Dim FTRS As MapXLib.Features
    Dim Ftr As MapXLib.Feature
    Dim ptStart As New MapXLib.Point, ptEnd As New MapXLib.Point
    Dim XMap1 As Double, YMap1 As Double, XMap2 As Double, YMap2 As Double
    
    ptStart.Set X1, Y1
    iEndID = 0
    
    If MapDisp.CurrentTool = miSelectTool Then
      Set FTRS = MapDisp.Layers("node").SearchAtPoint(ptStart)
      If FTRS.Count <> 0 Then
        Select Case ClickCount
          Case 1
            iStartID = FTRS.Item(1).KeyValue
          Case 2
            iEndID = FTRS.Item(1).KeyValue
        End Select
      End If
    End If
End Sub

Private Sub mnuAttribute_Click()
  frmAttribute.Show
End Sub

Private Sub mnuBuffer_Click()
    Dim aa As Integer
    Dim i As Integer
    
    aa = 0
    For i = 1 To frmMain.MapDisp.Layers.Count
        aa = aa + frmMain.MapDisp.Layers(i).Selection.Count
    Next
    If aa = 0 Then
        MsgBox "请选择元素！", vbInformation
    Else
        FrmCreateBuffer.Show 0, Me
    End If
End Sub

Private Sub mnuCirSelect_Click()
  b_Select = True
  m_bSelect = False
  MapDisp.CurrentTool = miRadiusSelectTool
End Sub


Private Sub mnuDelTheme_Click()
    Dim i As Integer
    
    For i = 1 To MapDisp.DataSets.Count
      frmMain.MapDisp.DataSets.Item(i).Themes.RemoveAll
    Next
End Sub

Private Sub mnuDisSearch_Click()
    Dim aa As Integer
    Dim i As Integer
    
    aa = 0
    For i = 1 To frmMain.MapDisp.Layers.Count
        aa = aa + frmMain.MapDisp.Layers(i).Selection.Count
    Next
    If aa = 0 Then
        MsgBox "请选择元素！", vbInformation
    Else
        frmDistanceSearch.Show 0, Me
    End If
  
End Sub

Private Sub mnuDistance_Click()
    MapDisp.CurrentTool = TOOL_DISTANCE_ID
End Sub

Private Sub mnuEditLegend_Click()
  Dim Msg
  
  If Me.MapDisp.DataSets.Item(lstLayers.List(lstLayers.ListIndex)).Themes.Count = 0 Then
      Msg = MsgBox("该图层还没有专题图层，是否要建立！", vbYesNo + vbQuestion)
      If Msg = vbYes Then
          Call mnuTheme_Click
      Else
          Exit Sub
      End If
  Else
      ModiLegend = True
      frmEditTheme.Show
  End If
End Sub

Private Sub mnuEditTheme_Click()
  Dim Msg
  
  If Me.MapDisp.DataSets.Item(lstLayers.List(lstLayers.ListIndex)).Themes.Count = 0 Then
      Msg = MsgBox("该图层还没有专题图层，是否要建立！", vbYesNo + vbQuestion)
      If Msg = vbYes Then
          Call mnuTheme_Click
      Else
          Exit Sub
      End If
  Else
      frmEditTheme.Show
  End If
End Sub

Private Sub mnuEdtion_Click()
  Load frmAbout
  frmAbout.Show
End Sub

Private Sub mnuEndPoint_Click()
  ClickCount = 2
  MapDisp.CurrentTool = miSelectTool
  mnuStartPoint.Enabled = True
  mnuEndPoint.Enabled = False
End Sub

Private Sub mnuExit_Click()
  End
End Sub

Private Sub mnuExportMap_Click()
  Dim strFileName As String
  Dim strFormat As String
  
  cdlTest.Filter = "(*.WMF)|*.WMF|(*.BMP)|*.BMP|(*.JPG)|*.JPG|(*.TIF)|*.TIF|(*.GIF)|*.GIF|(*.PNG)|*.PNG|(*.PSD)|*.PSD"
  cdlTest.ShowSave
  
  If cdlTest.FileName = "" Then
      MsgBox "请保存图片！"
  Else
      strFileName = Right(cdlTest.FileName, 3)
      
      Select Case strFileName
          Case "WMF":
            strFormat = miFormatWMF
          Case "BMP":
            strFormat = miFormatBMP
          Case "JPG":
            strFormat = miFormatJPEG
          Case "GIF":
            strFormat = miFormatGIF
          Case "TIF":
            strFormat = miFormatTIF
          Case "PNG":
            strFormat = miFormatPNG
          Case "PSD":
            strFormat = miFormatPSD
      End Select
      MapDisp.ExportMap cdlTest.FileName, strFormat
  End If
End Sub

Private Sub mnuFullView_Click()
  MapDisp.Bounds = MapDisp.Layers.Bounds
End Sub

Private Sub mnuLabel_Click()
  MapDisp.CurrentTool = miLabelTool
End Sub

Private Sub mnuLayerControl_Click()
  MapDisp.Layers.LayersDlg
  Call ListAllLayer
End Sub

Private Sub mnuLengthORArea_Click()
    Dim FTRS As MapXLib.Features
    Dim Ftr As MapXLib.Feature
    Dim oLayer As MapXLib.Layer
    Dim dArea As Double
    Dim dLength As Double
    Dim b_Type As Boolean
    Dim dPermiter As Double
    Dim aa As Integer, i As Integer
    
    aa = 0
    For i = 1 To frmMain.MapDisp.Layers.Count
        aa = aa + frmMain.MapDisp.Layers(i).Selection.Count
    Next
    If aa = 0 Then
        MsgBox "请选择元素！", vbInformation
    Else
        Set oLayer = MapDisp.Layers(lstLayers.List(lstLayers.ListIndex))
        Set FTRS = oLayer.Selection
        
        For Each Ftr In FTRS
          Select Case Ftr.Type
             Case miFeatureTypeRegion:
               b_Type = False
               dArea = dArea + Ftr.Area
               dPermiter = dPermiter + Ftr.Perimeter
              Case miFeatureTypeLine:
                b_Type = True
                dLength = dLength + Ftr.Length
          End Select
        Next
        
        If b_Type = False Then
          MsgBox "面积:" + CStr(dArea) + ",周长:" + CStr(dPermiter)
        Else
          MsgBox "总长:" + CStr(dLength)
        End If
    End If
End Sub

Private Sub mnuLocationSearch_Click()
   frmSearchLocation.Show
End Sub

Private Sub mnuPan_Click()
  MapDisp.CurrentTool = miPanTool
End Sub

Private Sub mnuPolySelect_Click()
  b_Select = True
  m_bSelect = False
  MapDisp.CurrentTool = miPolygonSelectTool
End Sub

Private Sub mnuPrinter_Click()
  cdlTest.Filter = "(*.mdi)|*.mdi"
  cdlTest.ShowSave
  
  If cdlTest.FileName = "" Then
      MsgBox "请保存图片！"
  Else
    ScaleMode = 6
    Printer.CurrentX = 0
    Printer.CurrentY = 0
    Printer.Print " "
    MapDisp.PrintMap Printer.hDC, 0, 0, MapDisp.Width * 100, MapDisp.Height * 100
    Printer.NewPage
    Printer.EndDoc
  End If
  
End Sub

Private Sub mnuReadData_Click()
  Dim strInFileName As String, strInFileLink As String
  strInFileName = App.Path + "\Data\" + "node.MID"
  strInFileLink = App.Path + "\Data\" + "rail.MID"

  Call ShortPathData(strInFileName, strInFileLink, NoNode, nNode, LineNode, LineDis, nLineNode, LinkN, LinkNi, LinkDis, LinkNo)
End Sub

Private Sub mnuRectSelect_Click()
  b_Select = True
  m_bSelect = False
  MapDisp.CurrentTool = miRectSelectTool
End Sub

Private Sub mnuSearchI_Click()
  b_Select = True
  m_bSelect = True
  MapDisp.CurrentTool = miSelectTool
  MapDisp.FeatureEditMode = miEditModeFeature
End Sub

Private Sub mnuSearchShortPath_Click()
    Dim FTRS As MapXLib.Features
    Dim Lyr As MapXLib.Layer
    Dim Ftr As MapXLib.Feature
    Dim oDS As MapXLib.DataSet
    Dim FirID As Integer, SecID As Integer
    Dim i As Integer, nCount As Integer, J As Integer
    Dim NodeLinePath() As Integer
   
    Call ShortPathSearch(iStartID, iEndID, nNode, NoNode, LinkN, LinkNi, LinkNo, LinkDis, nNodeShortPath, NodeShortPath, ShortPath)
    
    Set Lyr = frmMain.MapDisp.Layers("rail")
    Set oDS = Lyr.DataSets.Item(1)
    Set FTRS = MapDisp.Layers("rail").AllFeatures
    
    For i = 1 To nNode
      If NodeShortPath(i) <> 0 Then
        nCount = nCount + 1
      End If
    Next i
    
    ReDim NodeLinePath(nCount) As Integer
    
    For i = 1 To nCount
        NodeLinePath(i) = NodeShortPath(i)
    Next i
    

    i = 1
    For Each Ftr In FTRS
        If Ftr.Type = miFeatureTypeLine Then
            FirID = oDS.Value(Ftr, 1)
            SecID = oDS.Value(Ftr, 2)
            For J = 1 To nCount
                If (NodeLinePath(J - 1) = FirID And NodeLinePath(J) = SecID) Then
                    Lyr.Selection.Add Ftr
                    i = i + 1
                ElseIf (NodeLinePath(J - 1) = SecID And NodeLinePath(J) = FirID) Then
                    i = i + 1
                    Lyr.Selection.Add Ftr
                End If
            Next J
        Else
            MsgBox "不是线特征!"
            Exit For
        End If
    Next
    
    ShortPath = Format$(ShortPath, "#.00")
    MsgBox "总长：" + CStr(ShortPath) + "米", vbOKOnly, "道路长度"
End Sub

Private Sub mnuSelectPoint_Click()
  b_Select = True
  m_bSelect = False
  MapDisp.CurrentTool = miSelectTool
End Sub

Private Sub mnuSQLSearch_Click()
  b_Select = True
  m_bSelect = False
  frmSearchSQL.Show
End Sub

Private Sub mnuStartEnd_Click()
  MapDisp.CurrentTool = miSelectTool
End Sub

Private Sub mnuStartPoint_Click()
  ClickCount = 1
  ShortCount = ShortCount + 1
  MapDisp.CurrentTool = miSelectTool
  mnuEndPoint.Enabled = True
  mnuStartPoint.Enabled = False
End Sub

Private Sub mnuText_Click()
  MapDisp.CurrentTool = miTextTool
End Sub

Private Sub mnuTheme_Click()
  frmTheme.Show
End Sub

Private Sub mnuZoomIn_Click()
  MapDisp.CurrentTool = miZoomInTool
End Sub

Private Sub mnuZoomOut_Click()
  MapDisp.CurrentTool = miZoomOutTool
End Sub

Private Sub CreateDistance()
  MapDisp.CreateCustomTool TOOL_DISTANCE_ID, miToolTypePoly, miDefaultCursor
End Sub



Function CreateTempLayer()
    On Error GoTo Err
    Dim newLayer As Layer, m_TempLayer As MapXLib.Layer
    Dim LayerInfoObject As New LayerInfo
    Dim fields As New fields
    
    fields.AddStringField "GeoName", 10
    
    LayerInfoObject.Type = miLayerInfoTypeTemp
    LayerInfoObject.AddParameter "Name", "Temporary Layer"
    LayerInfoObject.AddParameter "Fields", fields
    
    Set newLayer = MapDisp.Layers.Add(LayerInfoObject, 1)
    
    newLayer.Editable = True
    Set MapDisp.Layers.InsertionLayer = newLayer
    ListAllLayer
    
Err:
    Set m_TempLayer = MapDisp.Layers.CreateLayer("TempLayer")
    
End Function

Sub ListAllLayer()
  Dim i As Integer
  
  Me.lstLayers.Clear
  For i = 1 To MapDisp.Layers.Count
    Me.lstLayers.AddItem MapDisp.Layers(i).Name
    If MapDisp.Layers(i).DataSets.Count = 0 Then
        MapDisp.DataSets.Add miDataSetLayer, MapDisp.Layers(i), MapDisp.Layers(i).Name
    End If
  Next
  Me.lstLayers.ListIndex = 0
End Sub