frmmain.frm

有关geomedia的一个全新的gis工程

                            pnt1.X = snapPnt.X
                            pnt1.Y = snapPnt.Y
                            pnt1.Z = snapPnt.Z
                            gobjGeomEdit.BeginMove pnt1
                            bMovePoint = True
                            Set pnt1 = Nothing
                        Case gmssOnElement: '''增加顶点
                            If gobjGeomEdit.IsEditable(gobjGeomEdit.GeometryCount, gmgeInsertVertex) Then
                                pnt1.X = snapPnt.X
                                pnt1.Y = snapPnt.Y
                                pnt1.Z = snapPnt.Z
                                Set objGeom = gobjGeomEdit.GetGeometry(gobjGeomEdit.GeometryCount)
                                pntIndex = PointOnline(pnt1, objGeom)
                                If pntIndex = -1 Then
                                    gobjGeomEdit.SelectAllKeypoints gobjGeomEdit.GeometryCount, gobjHandleStyle
                                    Exit Sub
                                End If
                                gobjGeomEdit.InsertVertexAfter objGeom, pntIndex, pnt1
                                Call storeGeometry
                                Call reLoadGeoMetry
                                bMovePoint = False
                            End If
                        End Select
                        Set pnt1 = Nothing
                    End If
        End If
      End If
End Sub

Private Sub EventControl1_MouseMove(ByVal MapviewDispatch As Object, ByVal Button As Long, ByVal Key As Long, ByVal WindowX As Double, ByVal WindowY As Double, ByVal WindowZ As Double, ByVal worldX As Double, ByVal worldY As Double, ByVal worldZ As Double)
On Error Resume Next
                gobjPnt.X = worldX
                gobjPnt.Y = worldY
                gobjPnt.Z = worldZ
        If MouseAction = "Edit" Then
                   pnt1.X = worldX
                   pnt1.Y = worldY
                   pnt1.Z = worldZ
                   Set snapPnt = New Point
           
                   If objLocatedObjects.Count > 0 Then    '当已经存在选取的 Feather时，除执行添加点和移动过程中外，只捕获已选取的Feather
               
                       If SnapToGeometry(GMMapView1, objLocatedObjects, pnt1, snapPnt, snapType, Myindex) Then
                           Select Case snapType:
                               Case gmssOnEndVertex:
                                   GMMapView1.MousePointer = gmmvctCrossHairOnEndPoint
                               Case gmssOnVertex:
                                   GMMapView1.MousePointer = gmmvctCrossHairOnVertex
                               Case gmssOnElement:
                                   GMMapView1.MousePointer = gmmvctCrossHairOnElement
                           End Select
                       Else
                           GMMapView1.MousePointer = gmmvctCrossHair
                           Set snapPnt = Nothing
                       End If
                   End If
        End If
        If MouseAction = "DigitLine" Then
                   objGeomDig.DynamicPoint gobjPnt
        End If
        If MouseAction = "DigitArea" Then
                  objGeomDig.DynamicPoint gobjPnt
        End If
 
 If Button = 1 Then
        
       If MouseAction = "ZoomIn" Or MouseAction = "ZoomOut" Then
                objPntZoom.X = worldX
                objPntZoom.Y = worldY
                objPntZoom.Z = worldZ
                objGeomDig.DynamicPoint objPntZoom
        End If
        
        If MouseAction = "Pan" Then
                GMMapView1.Pan worldX - objPntZoom.X, worldY - objPntZoom.Y, worldZ - objPntZoom.Z
                GMMapView1.Refresh False
        End If
        If MouseAction = "Edit" Then
            If bMovePoint = True Then
                    pnt1.X = worldX
                    pnt1.Y = worldY
                    pnt1.Z = worldZ
                    gobjGeomEdit.Move pnt1
                    Set pnt1 = Nothing
             End If
        End If
 End If
    
End Sub

Private Sub EventControl1_MouseUp(ByVal MapviewDispatch As Object, ByVal Button As Long, ByVal Key As Long, ByVal WindowX As Double, ByVal WindowY As Double, ByVal WindowZ As Double, ByVal worldX As Double, ByVal worldY As Double, ByVal worldZ As Double)
On Error Resume Next
If Button = 1 Then
                objPntZoom.X = worldX
                objPntZoom.Y = worldY
                objPntZoom.Z = worldZ
                
        If MouseAction = "ZoomIn" Then
                ZoomRectX2 = worldX
                ZoomRectY2 = worldY
                ZoomRectZ2 = worldZ
                objGeomDig.AppendPoint objPntZoom
                GMMapView1.ZoomArea ZoomRectX1, ZoomRectY1, ZoomRectZ1, ZoomRectX2, ZoomRectY2, ZoomRectZ2
        End If
        If MouseAction = "ZoomOut" Then
                ZoomRectX2 = worldX
                ZoomRectY2 = worldY
                ZoomRectZ2 = worldZ
                objGeomDig.AppendPoint objPntZoom
                Dim mapX1 As Double, mapY1 As Double, mapZ1 As Double, mapX2 As Double, mapY2 As Double, mapZ2 As Double, ratioX As Double, ratioY As Double, detalX As Double, detalY As Double
                GMMapView1.GetRange mapX1, mapY1, mapZ1, mapX2, mapY2, mapZ2
                ratioX = (mapX2 - mapX1) / (ZoomRectX2 - ZoomRectX1)
                ratioY = (mapY2 - mapY1) / (ZoomRectY1 - ZoomRectY2)
                detalX = ratioX * (mapX2 - mapX1) / 2
                detalY = ratioY * (mapY2 - mapY1) / 2
                ZoomRectX1 = mapX1 - detalX
                ZoomRectY1 = mapY1 + detalY
                ZoomRectX2 = mapX2 + detalX
                ZoomRectY2 = mapY2 - detalY
                GMMapView1.ZoomArea ZoomRectX1, ZoomRectY1, ZoomRectZ1, ZoomRectX2, ZoomRectY2, ZoomRectZ2
        End If
        If MouseAction = "Edit" Then
            If bMovePoint = True Then
                    pnt1.X = worldX
                    pnt1.Y = worldY
                    pnt1.Z = worldZ
                    
                    gobjGeomEdit.EndMove pnt1
                    Set pnt1 = Nothing
                    
                    Call storeGeometry
                    Call reLoadGeoMetry
                    bMovePoint = False
            End If
        End If
        GMMapView1.Refresh False
End If
End Sub

Private Sub Form_Initialize()
   With GMMapView1
    .Legend = New pview.Legend
    .LocateTolerance = 7
    .DefaultZ = 0
    If .HighlightColor <> RGB(0, 180, 180) Then _
          .HighlightedObjects.SetDisplayColor RGB(255, 0, 0)
    If .SelectColor <> RGB(180, 0, 180) Then _
          .MapViewSelectedObjects.SetDisplayColor RGB(180, 0, 180)
    .MousePointer = gmmvctNWArrow
    .PreserveMapScaleWhenResizing = True
    .SelectBehavior = gmwHighlightOnly
    .SelectBehaviorConditions = gmwAnyWindowActive
    .SelectBehaviorZoomFactor = 1
    .ZoomFactor = 1.5
  End With
    objLocatedObjects.MaxNumOfObjects = 1
    EventControl1.AddMapView GMMapView1.Dispatch, objEventServer
    Set objGeomDig = CreateObject("GeoMedia.GeometryDigitizeService")
    Set objGeomDig.mapview = GMMapView1.Dispatch
    Set gobjGeomEdit = CreateObject("GeoMedia.GeometryEditService")
    Set gobjGeomEdit.mapview = GMMapView1.Dispatch
    Set ZoomRect = CreateObject("GeoMedia.RectangleGeometry")
    With ZoomLineStyle
        .StyleUnits = gmsStyleUnitsView
        .Color = RGB(0, 180, 120)
        .Width = 2
        .LineStyle = gmsLinearMediumDashed
    End With
 
End Sub

Private Sub Form_Resize()
  'Adjust the size of GMMapView1 control
  GMMapView1.Left = 0
  GMMapView1.Top = 0
  GMMapView1.Width = Me.ScaleWidth
  GMMapView1.Height = Me.ScaleHeight
End Sub

Private Sub geometryLocate_Click()
  FrmGeometryLocate.Show
End Sub

Private Sub intersectionPipe_Click()
MouseAction = "Intersection"
frmSpatialAnylize.Show
End Sub

Private Sub mnuDigit_Click()
    Toolbar1.Visible = True
    ComSelectTable.Enabled = True
    Dim i As Integer
    Dim TableMask As Long
    Dim FeatureTables As Variant
    Dim objMDSrvc As New MetadataService
    Set objMDSrvc.Connection = gobjConnection
    TableMask = gmmtPoint Or gmmtLinear Or gmmtAreal Or gmmtAnySpatial
    objMDSrvc.GetTables TableMask, FeatureTables
    For i = LBound(FeatureTables) To UBound(FeatureTables) - 1
    ComSelectTable.AddItem FeatureTables(i)
    Next i
    Set objMDSrvc = Nothing
End Sub

Private Sub mnuDisplayFeature_Click()
  ' select a feature class and create a legend entry for display
  
  On Error GoTo ErrorHandler
  
  Dim objRS As GRecordset
  
  CreateRecordset objRS
  
  If Not (objRS Is Nothing) Then
    MousePointer = vbHourglass
    Dim objLE As RecordLegendEntry
    Set objLE = GetLegendEntry(objRS)
    DisplayTheLegendEntry objLE
    MousePointer = vbDefault
  End If
  Exit Sub
  
ErrorHandler:
  MsgBox Err.Description, MSGBOX_ERROR, "DisplayFeature_Click Error"
End Sub

Private Sub mnuFileExit_Click()
  Set gobjConnection = Nothing
  End
End Sub

Private Sub mnuFileOpen_Click()
On Error GoTo ErrorHandler
  
  OpenConnection
  
  Exit Sub

ErrorHandler:
  MsgBox Err.Description, MSGBOX_ERROR, "FileOpen_Click Error"
End Sub

Private Sub mnuOpenWorkSpace_Click()
  OpenWorkSpace App.Path + "\WORKSPACE.txt", App.Path + "\GISsym.fsm", gobjConnection, GMMapView1
End Sub

Private Sub mnuPrint_Click()
  Dim objPreferenceSet As Object
  Dim objPageSetup As Object
  Dim objUOM As Object
  Dim objPrint As Object
  Dim lrtn As Long
  lrtn = 0
  On Error GoTo ErrorHandler
  
  If objPreferenceSet Is Nothing Then
    Set objPreferenceSet = CreateObject("GMService.PreferenceSet")
    objPreferenceSet.RegistryPath = "Software\Intergraph\GeoMedia\05.00\PreferenceSet"
  End If

  Set objUOM = CreateObject("UnitsOfMeasure")
  Set objPageSetup = CreateObject("GeoMediaCommand.PageSetup")

  lrtn = objPageSetup.PageSetup(GMMapView1.Dispatch, objPreferenceSet, _
         "Any text", "Any text", objUOM)
  
  Set objPrint = CreateObject("GeoMediaCommand.Print")
  lrtn = objPrint.Print(GMMapView1.Dispatch, "Any text", objPreferenceSet, "Any text")
  
  Set objPrint = Nothing
  Set objPageSetup = Nothing
  Set objUOM = Nothing
  Exit Sub
  
ErrorHandler:
  MsgBox Err.Description, MSGBOX_ERROR, "mnuFilePrint Error"
  Set objPageSetup = Nothing
  Set objUOM = Nothing
  Set objPrint = Nothing

End Sub

Private Sub mnuSaveWorkSpace_Click()
   SaveWorkSpace App.Path + "\WORKSPACE.txt", gobjConnection, GMMapView1.Legend
End Sub

Private Sub mnuViewFit_Click()
On Error Resume Next
   GMMapView1.MousePointer = gmmvctNWArrow
   GMMapView1.Fit
   GMMapView1.Refresh False
End Sub

Private Sub mnuViewLegend_Click()
     FrmMain.GMMapView1.Legend.Visible = Not mnuViewLegend.Checked
     mnuViewLegend.Checked = Not mnuViewLegend.Checked
End Sub

Private Sub mnuViewPan_Click()
   MouseAction = "Pan"
   GMMapView1.MousePointer = gmmvctPan
End Sub

Private Sub mnuViewProperty_Click()
   MouseAction = "Property"
   GMMapView1.MousePointer = gmmvctNWArrow
End Sub

Private Sub mnuViewZoomIn_Click()
    MouseAction = "ZoomIn"
    GMMapView1.MousePointer = gmmvctZoomIn
End Sub

Private Sub mnuViewZoomOut_Click()
   MouseAction = "ZoomOut"
   GMMapView1.MousePointer = gmmvctZoomOut
End Sub

Private Sub outputtable_Click()
 FrmOutputTable.Show
End Sub

Private Sub Select_Click()
   GMMapView1.MousePointer = gmmvctNWArrow
   MouseAction = "Select"
End Sub

Private Sub SelectedView_Click()
  FrmSelectedView.Show
End Sub

Private Sub testgenerallable_Click()
 On Error GoTo ErrorHandler
    
    Dim sFeature As String
    Dim sAttribute As String
    
    If frmLabel.GetLabelInfo(gobjConnection, sFeature, sAttribute) Then
        Screen.MousePointer = vbHourglass
        GenerateLabels sFeature, sAttribute, RecordsetOutputTable, GMMapView1
    End If
    
    GoTo Finish
    
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Source & Chr(13) & _
        Err.Description, vbOKOnly + vbExclamation

Finish:
    On Error Resume Next
    Screen.MousePointer = vbDefault

End Sub

Private Sub thematic_Click()
  FrmThem.Show
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As ComctlLib.Button)
 Select Case Button.Key
         Case "line"
               MouseAction = "DigitLine"
         Case "polygon"
               MouseAction = "DigitArea"
  End Select
End Sub