modfunction.bas

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

    Dim objOutputTableService As OutputTableService
    Set objOutputTableService = CreateObject("GMService.OutputTableService")
    Set objOutputTableService.InputRecordset = InputRecordset
    objOutputTableService.outputTableName = outputTableName
    objOutputTableService.OutputMode = 3
    Set objOutputTableService.OutputConnection = objConn
    objOutputTableService.Execute
    objConn.BroadcastDatabaseChanges
    Set objOutputTableService = Nothing
    Exit Function
errhandle:
    MsgBox Err.Description
    Set objOutputTableService = Nothing
End Function
Public Function SnapToGeometry(ByVal mapview As Object, _
                                ByVal objLocateCollection As LocatedObjectsCollection, _
                                ByVal InputPoint As Point, _
                                ByRef retSnapPnt As Point, _
                                ByRef retSnapType As Long, _
                                ByRef Retsnapindex As Integer) As Boolean
    Dim snapSvr             As New SnapService
    Dim locobject           As Object
    Dim geomfield           As Object
    Dim GeomStoreSvr        As Object
    Dim loctolerance        As Double
    
    Dim x1                  As Double
    Dim y1                  As Double
    Dim z1                  As Double
    Dim x2                  As Double
    
    Dim snapType            As Long
    Dim snapDist            As Double
    Dim snapGeom            As Object
    Dim snapPoint           As Point
    Dim parentGeom          As Object
    Dim keyPointIndex       As Long
    Dim keyPointTotIndex    As Long
    
    Dim KeyPnt              As Point
    Dim svKeyType           As Long
    
    Dim svKeyDist           As Double
    Dim KeyDist             As Double
    Dim KeyIndex            As Integer

    retSnapPnt.X = InputPoint.X
    retSnapPnt.Y = InputPoint.Y
    retSnapPnt.Z = InputPoint.Z
  
    SnapToGeometry = False
    mapview.WindowToWorld CLng(0), CLng(0), x1, y1, z1
    mapview.WindowToWorld CLng(5), CLng(0), x2, y1, z1
    loctolerance = Abs(x2 - x1)
    snapSvr.SnapTolerance = loctolerance
    snapSvr.SnapTypes = gmssSnapToEndPoint + _
                        gmssSnapToVertex + _
                        gmssSnapToElement
                        
    For Each locobject In objLocateCollection
       If snapSvr.SnapToLocatedObject(locobject, _
                                        InputPoint, _
                                        parentGeom, _
                                        snapGeom, _
                                        snapPoint, _
                                        snapType, _
                                        snapDist, _
                                        keyPointIndex, _
                                        keyPointTotIndex) Then
                       
            Set KeyPnt = snapPoint
            svKeyType = snapType
            KeyIndex = keyPointIndex
            KeyDist = snapDist
            SnapToGeometry = True
            
            retSnapPnt.X = KeyPnt.X
            retSnapPnt.Y = KeyPnt.Y
            retSnapPnt.Z = KeyPnt.Z
            retSnapType = svKeyType
            Retsnapindex = KeyIndex
        End If
    Next
    Set locobject = Nothing
    Set snapSvr = Nothing
    Set geomfield = Nothing
End Function
Public Function storeGeometry() As Boolean
    Dim objGss As GeometryStorageService
    Dim objGeom As Object
    Dim objfield As GField
    
    On Error GoTo MyErr
    
    Set objGss = CreateObject("GeoMedia.GeometryStorageService")
    Set objGeom = gobjGeomEdit.GetGeometry(gobjGeomEdit.GeometryCount)
    rsGrecordset.edit
        objGss.SetGeometry rsGrecordset.GFields(GetGeometryFieldName(rsGrecordset)), objGeom
    rsGrecordset.Update
    '''gobjGeomEdit.SelectAllKeypoints gobjGeomEdit.GeometryCount, gobjHandleStyle
 
    storeGeometry = True
    Set objGeom = Nothing
    Set objGss = Nothing
    Exit Function
MyErr:
    storeGeometry = False
    Set objGeom = Nothing
    Set objGss = Nothing
End Function
Public Function reLoadGeoMetry() As Boolean
    Dim i               As Long
    Dim objRLE          As RecordLegendEntry        '''MapView数据对象集合
    Dim nGeoType        As Long                     '''几何图形类型
    Dim sGeometry       As String                   '''图形数据字段名
    Dim objStyle        As Object
    Dim strTitle        As String
    
    '''============================================================
    On Error Resume Next
    '''============================================================
    FrmMain.GMMapView1.MapViewSelectedObjects.Clear
    i = 0
    For Each objRLE In FrmMain.GMMapView1.Legend.LegendEntries
        i = i + 1
        objRLE.Recordset.MoveFirst
        If (objRLE.Recordset.Name = rsGrecordset.Name) And _
            (objRLE.Recordset.GFields(0).SourceDatabase = rsGrecordset.GFields(0).SourceDatabase) Then
            Set objStyle = objRLE.Style
            strTitle = objRLE.Title
            sGeometry = GetGeometryFieldName(rsGrecordset)
            FrmMain.GMMapView1.Legend.LegendEntries.Remove i
            Exit For    '''删除操作执行完毕，退出循环
        End If
    Next objRLE
    '''============================================================
    Set objRLE = CreateObject("Geomedia.RecordLegendEntry")
    objRLE.GeometryFieldName = sGeometry
    Set objRLE.Recordset = rsGrecordset
    Set objRLE.Style = objStyle
    objRLE.Title = strTitle
        If FrmMain.GMMapView1.Legend.LegendEntries.Count = 0 Then
            FrmMain.GMMapView1.Legend.LegendEntries.Append objRLE
        Else
            FrmMain.GMMapView1.Legend.LegendEntries.Append objRLE, i
        End If
        objRLE.LoadData
    gobjGeomEdit.SelectAllKeypoints gobjGeomEdit.GeometryCount, gobjHandleStyle
    FrmMain.GMMapView1.Legend.Fit
    FrmMain.GMMapView1.Refresh
    '''============================================================
    Set objStyle = Nothing
    Set objRLE = Nothing
    '''============================================================
    If Err.Number <> 0 Then
        reLoadGeoMetry = False
    Else
        reLoadGeoMetry = True
    End If
End Function
Public Function PointOnline(ByVal pnt As Point, Geom As Object) As Integer

    Dim i       As Integer
    Dim j       As Integer
    Dim pnt1    As New Point
    Dim pnt2    As New Point

    On Error GoTo MyErr
    If Geom.Type = "CompositePolygonGeometry" Then
        If Geom.Count > 1 Then
            GoTo MyErr
        Else
            Set Geom = Geom.Item(1)
        End If
    End If
    
    For i = 1 To Geom.Points.Count
        Set pnt1 = Geom.Points(i)
        If i <> Geom.Points.Count Then
            Set pnt2 = Geom.Points(i + 1)
        Else
            Set pnt2 = Geom.Points(1)
        End If
        If PointOnSegment(pnt1, pnt2, pnt) Then
            PointOnline = i
            Exit Function
        End If
    Next
MyErr:
    PointOnline = -1
End Function
Public Function SaveWorkSpace(WorkSpacePath As String, Connection As PClient.Connection, Legend As Legend)
    Dim i As Integer
    Dim j As Integer
    Dim k As Integer
    Dim l As Integer
    Dim iColor As Integer
    Dim ColorW() As Long
    Open WorkSpacePath For Output As #1
    Print #1, "Connection="; Connection.Location
    Print #1, "LegendEntry Count="; Legend.LegendEntries.Count
    i = Legend.LegendEntries.Count
    For j = 1 To i
    If Legend.LegendEntries(j).Type = "UniqueValueLegendEntry" Then '############################
       Print #1, "Recordset="; Legend.LegendEntries(j).Recordset.Name
       Print #1, "LegendEntryType="; Legend.LegendEntries(j).Type
      Print #1, "Color Num="; UBound(Legend.LegendEntries(j).ColorSchemes(1).Colors)
       iColor = UBound(Legend.LegendEntries(j).ColorSchemes(1).Colors)
       ColorW = Legend.LegendEntries(j).ColorSchemes(1).Colors
       For k = 0 To iColor - 1
       Print #1, "Color" & k & "="; ColorW(k)
       Next k
       Print #1, "ColorScheme Name="; Legend.LegendEntries(j).ColorSchemes(1).Name
       Print #1, "ColorScheme Type="; Legend.LegendEntries(j).ColorSchemes(1).Type
       Print #1, "ColorScheme Index="; Legend.LegendEntries(j).ColorSchemeIndex
       'Print #1, "ColorScheme Num="; Legend.LegendEntries(j).ColorSchemes.Count
    Print #1, "Ascending="; Legend.LegendEntries(j).Ascending
    Print #1, "AttributeFieldName="; Legend.LegendEntries(j).AttributeFieldName
    Print #1, "Collapsed="; Legend.LegendEntries(j).Collapsed
    Print #1, "ContentsMode="; Legend.LegendEntries(j).ContentsMode
    Print #1, "DisplayMode="; Legend.LegendEntries(j).DisplayMode
    Print #1, "GeometryFieldName="; Legend.LegendEntries(j).GeometryFieldName
    Print #1, "Locatable="; Legend.LegendEntries(j).Locatable
    Print #1, "Style="; Legend.LegendEntries(j).Style.Type
    Print #1, "ValuesCont="; Legend.LegendEntries(j).UniqueValues.Count
    For l = 1 To Legend.LegendEntries(j).UniqueValues.Count
       Print #1, "RangeDescription" & l & "="; Legend.LegendEntries(j).UniqueValues(l).Description
       Print #1, "RangeInclue" & l & "="; Legend.LegendEntries(j).UniqueValues(l).Include
          If Legend.LegendEntries(j).Style.Type = "AreaStyle" Then
          Print #1, "AreaBackColor="; Legend.LegendEntries(j).UniqueValues(l).Style.BackColor
          Print #1, "FillType="; Legend.LegendEntries(j).UniqueValues(l).Style.FillType
          Print #1, "BoundaryOn="; Legend.LegendEntries(j).UniqueValues(l).Style.BoundaryOn
            If Legend.LegendEntries(j).UniqueValues(l).Style.BoundaryOn Then
                Print #1, "BoundaryLineStyle="; Legend.LegendEntries(j).UniqueValues(l).Style.Boundary.LineStyle
                Print #1, "BoundaryLineWidth="; Legend.LegendEntries(j).UniqueValues(l).Style.Boundary.Width
                Print #1, "BoundaryLineColor="; Legend.LegendEntries(j).UniqueValues(l).Style.Boundary.Color
            End If
          ElseIf Legend.LegendEntries(j).Style.Type = "LinearStyle" Then
                Print #1, "LineStyle="; Legend.LegendEntries(j).UniqueValues(l).Style.Mode
                Print #1, "LineWidth="; Legend.LegendEntries(j).UniqueValues(l).Style.Width
                Print #1, "LineColor="; Legend.LegendEntries(j).UniqueValues(l).Style.Color
          
          ElseIf Legend.LegendEntries(j).Style.Type = "SymbolFontStyle" Then
               Print #1, "PointSize="; Legend.LegendEntries(j).UniqueValues(l).Style.Size
               Print #1, "PointSymbol="; Legend.LegendEntries(j).UniqueValues(l).Style.FontName
               Print #1, "PointColor="; Legend.LegendEntries(j).UniqueValues(l).Style.Color
               Print #1, "PointIndex="; Legend.LegendEntries(j).UniqueValues(l).Style.Index
          ElseIf Legend.LegendEntries(j).Style.Type = "PointSymbolStyle" Then
               Print #1, "PointSize="; Legend.LegendEntries(j).UniqueValues(l).Style.Size
               Print #1, "PointSymbol="; Legend.LegendEntries(j).UniqueValues(l).Style.Symbol.Name
               Print #1, "PointColor="; Legend.LegendEntries(j).UniqueValues(l).Style.Color
          End If
    Next l
    Print #1, "Selected="; Legend.LegendEntries(j).Selected
    Print #1, "StatisticsMode="; Legend.LegendEntries(j).StatisticsMode
    'Print #1, "Status="; Legend.LegendEntries(j).Status
    Print #1, "HeadingFont="; Legend.LegendEntries(j).HeadingFont
    Print #1, "HeadingFontSize="; Legend.LegendEntries(j).HeadingFont.Size
'    Print #1, "HeadingFontColor="; Legend.LegendEntries(j).HeadingFontColor
    Print #1, "SubTitle="; Legend.LegendEntries(j).Subtitle
    Print #1, "SubTitleFont="; Legend.LegendEntries(j).SubtitleFont
    Print #1, "SubTitleFontSize="; Legend.LegendEntries(j).SubtitleFont.Size
'    Print #1, "SubTitleFontColor="; Legend.LegendEntries(j).SubtitleFontColor
    Print #1, "Title="; Legend.LegendEntries(j).Title
    Print #1, "TitleFont="; Legend.LegendEntries(j).TitleFont
    Print #1, "TitleFontSize="; Legend.LegendEntries(j).TitleFont.Size
'    Print #1, "TitleFontColor="; Legend.LegendEntries(j).TitleFontColor
    Print #1, "Visible="; Legend.LegendEntries(j).Visible
  
    ElseIf Legend.LegendEntries(j).Type = "RangeLegendEntry" Then '############################
       Print #1, "Recordset="; "Select * from [" + Legend.LegendEntries(j).Title + "]"
       Print #1, "LegendEntryType="; Legend.LegendEntries(j).Type
       Print #1, "Color Num="; UBound(Legend.LegendEntries(j).ColorSchemes(1).Colors)
       iColor = UBound(Legend.LegendEntries(j).ColorSchemes(1).Colors)
       ColorW = Legend.LegendEntries(j).ColorSchemes(1).Colors
       For k = 0 To iColor - 1
       Print #1, "Color" & k & "="; ColorW(k)
       Next k
       Print #1, "ColorScheme Name="; Legend.LegendEntries(j).ColorSchemes(1).Name
       Print #1, "ColorScheme Type="; Legend.LegendEntries(j).ColorSchemes(1).Type
       Print #1, "ColorScheme Index="; Legend.LegendEntries(j).ColorSchemeIndex
       'Print #1, "ColorScheme Num="; Legend.LegendEntries(j).ColorSchemes.Count
    Print #1, "Ascending="; Legend.LegendEntries(j).Ascending
    Print #1, "AttributeFieldName="; Legend.LegendEntries(j).AttributeFieldName
    Print #1, "Collapsed="; Legend.LegendEntries(j).Collapsed
    Print #1, "ContentsMode="; Legend.LegendEntries(j).ContentsMode
    Print #1, "DisplayMode="; Legend.LegendEntries(j).DisplayMode
    Print #1, "GeometryFieldName="; Legend.LegendEntries(j).GeometryFieldName
    Print #1, "Locatable="; Legend.LegendEntries(j).Locatable
    Print #1, "Style="; Legend.LegendEntries(j).Style.Type
    Print #1, "RangesCont="; Legend.LegendEntries(j).Ranges.Count
    For l = 1 To Legend.LegendEntries(j).Ranges.Count
       Print #1, "RangeDescription" & l & "="; Legend.LegendEntries(j).Ranges(l).Description