modfunction.bas

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

Public Function GetStyleObject(iGeometryType As Integer) As Object

  Dim objStyle As Object
  On Error GoTo ErrorHandler
  
  Select Case iGeometryType
    Case gdbPoint
      Set objStyle = CreateObject("GeoMedia.SymbolFontStyle")
      objStyle.Color = QBColor(nNextColor)
      objStyle.StyleUnits = gmsStyleUnitsPaper
      objStyle.FontName = "Wingdings"
      objStyle.Index = 74
      objStyle.Size = 200
   
    Case gdbGraphic
      ' because we know that we have retrieved the geometry type
      ' from the metadata, we know that if the type is the generic graphic,
      ' then it is a text element
      Set objStyle = CreateObject("GeoMedia.TextStyle")
      objStyle.Color = QBColor(nNextColor)
      objStyle.StyleUnits = gmsStyleUnitsPaper
      Set objStyle.Font = New StdFont
      With objStyle.Font
        .Name = "Arial"
        .Size = 10
      End With
   
    
    Case gdbAreal
      Set objStyle = CreateObject("GeoMedia.AreaStyle")
      objStyle.BoundaryOn = True
      With objStyle.Boundary
        .StyleUnits = gmsStyleUnitsPaper
        .Mode = gmsLinearModeShowBackground
        .Color = QBColor(nNextColor)
        .Width = 400
        .BackStyle = gmsLinearMediumDashed
      End With
      nNextColor = GetNextQBColor()
      
      With objStyle
        .BackColor = QBColor(nNextColor)
        .FillMode = gmsFillModeStandard
        .FillType = gmsFPDiagCrossHatch
        .ForeColor = QBColor(15)
        .HatchSpacing = 10
        .HatchWidth = 3
        .StyleUnits = gmsStyleUnitsPaper
      End With
      
    
    Case gdbAnySpatial
      Set objStyle = CreateObject("GeoMedia.AnyStyle")
      Set objStyle.TextStyle = CreateObject("GeoMedia.TextStyle")
      With objStyle.TextStyle
        .Color = QBColor(nNextColor)
        .StyleUnits = gmsStyleUnitsPaper
        Set .Font = New StdFont
        With .Font
          .Name = "Times New Roman"
          .Size = 36
        End With
      End With
      nNextColor = GetNextQBColor()
      
      Set objStyle.PointStyle = CreateObject("GeoMedia.SymbolFontStyle")
      With objStyle.PointStyle
        .Color = QBColor(nNextColor)
        .StyleUnits = gmsStyleUnitsPaper
        .FontName = "Wingdings"
        .Index = 100
        .Size = 400
      End With
      nNextColor = GetNextQBColor()

      Set objStyle.LinearStyle = CreateObject("GeoMedia.LinearStyle")
      With objStyle.LinearStyle
        .StyleUnits = gmsStyleUnitsPaper
        .Mode = gmsLinearModeShowBackground
        .Color = QBColor(nNextColor)
        .Width = 400
        .BackStyle = gmsLinearMediumDashed
      End With
      nNextColor = GetNextQBColor()
      
      Set objStyle.AreaStyle = CreateObject("GeoMedia.AreaStyle")
      With objStyle.AreaStyle
        .BoundaryOn = True
        With .Boundary
          .StyleUnits = gmsStyleUnitsPaper
          .Mode = gmsLinearModeShowBackground
          .Color = QBColor(nNextColor)
          .Width = 400
          .BackStyle = gmsLinearMediumDashed
        End With
        nNextColor = GetNextQBColor()
      
        .BackColor = QBColor(nNextColor)
        .FillMode = gmsFillModeStandard
        .FillType = gmsFPDiagCrossHatch
        .ForeColor = QBColor(15)
        .HatchSpacing = 10
        .HatchWidth = 3
        .StyleUnits = gmsStyleUnitsPaper
      End With
    
    Case gdbLinear
      Set objStyle = CreateObject("GeoMedia.LinearStyle")
      objStyle.StyleUnits = gmsStyleUnitsPaper
      objStyle.Mode = gmsLinearModeShowBackground
      objStyle.Color = QBColor(nNextColor)
      objStyle.Width = 300
    Case Else
      Set objStyle = CreateObject("GeoMedia.LinearStyle")
      objStyle.StyleUnits = gmsStyleUnitsPaper
      objStyle.Mode = gmsLinearModeShowBackground
      objStyle.Color = QBColor(nNextColor)
      objStyle.Width = 300
  End Select
  
  nNextColor = GetNextQBColor()
  Set GetStyleObject = objStyle
  Exit Function

ErrorHandler:
  MsgBox Err.Description, MSGBOX_ERROR, "GetStyleObject Error"
  Set objStyle = Nothing
  Set GetStyleObject = Nothing

End Function

Public Function GetNextQBColor() As Integer
  
  If nNextColor > 14 Then
    GetNextQBColor = 0
  Else
    GetNextQBColor = nNextColor + 1
  End If
  
End Function

Private Function LoadCoord(ActiveConnection As Connection, OcxMapView As GMMapView)
    '''Load coordinate system from gdatabase, then assign to mapview
    Dim i               As Long
    Dim sSQL            As String
    Dim Flds()          As Variant
    Dim FldTemp         As Variant
    Dim objRsCoord      As GRecordset
    Dim objCoordSysMgr  As Object
    Dim objDB As GDatabase
    
    Set objCoordSysMgr = CreateObject("CoordSystemsMgr")
    sSQL = "Select * From GCoordSystem"
    Set objDB = ActiveConnection.Database
    Set objRsCoord = objDB.OpenRecordset(sSQL, gdbOpenDynaset)
    ReDim Flds(0 To objRsCoord.GFields.Count - 1)

    Do While objRsCoord.EOF <> True
        FldTemp = objRsCoord.GetRows(1)
        For i = 0 To objRsCoord.GFields.Count - 1
            Flds(i) = FldTemp(i, 0)
        Next i
    Loop
    Set objRsCoord = Nothing
    objCoordSysMgr.CoordSystem.LoadFromGCoordSystemTableRowFormat Flds()
    Set OcxMapView.CoordSystemsMgr = objCoordSysMgr
    Set objCoordSysMgr = Nothing
    
End Function

Public Function SaveGeometry(Geometry As Object, AddRecordSet As GRecordset)
  On Error GoTo errhandle
    Dim GSS As GeometryStorageService
    Dim GeomOut As Variant
    Set GSS = CreateObject("Geomedia.GeometryStorageService")
    GSS.GeometryToStorage Geometry, GeomOut
    With AddRecordSet
        .AddNew
        .GFields(GetGeometryFieldName(AddRecordSet)).Value = GeomOut
        .Update
    End With
    Exit Function
errhandle:
    MsgBox Err.Description
End Function

Public Function BlobToGeometry(Blob As Variant) As Object
On Error GoTo MyErr
  Dim objGss  As New GeometryStorageService
  Dim objGeometry   As Object
  objGss.StorageToGeometry Blob, objGeometry
  Set BlobToGeometry = objGeometry
  Set objGss = Nothing
  Set objGeometry = Nothing
  Exit Function
MyErr:
   Set BlobToGeometry = Nothing
   MsgBox Err.Description, vbOKOnly, "Blob to geometry worrong"
End Function

Public Function polylinetosvg(filenum As Integer, Geometry As PolylineGeometry) As Integer
  Dim i As Integer
  Print #filenum, "<polyline points=" + Chr(34)
  For i = 1 To Geometry.Points.Count
    Print #filenum, Str(Geometry.Points(i).X) + "," + Str(Geometry.Points(i).Y) + " " + Chr(34)
  Next i
  Print #filenum, "style=" + Chr(34) + "stroke: red; fill: none" + Chr(34) + "/>"
  
End Function
Public Sub GenerateLabels(sFeature As String, sAttribute As String, RecordsetLable As GRecordset, OcxMapView As GMMapView)

    On Error GoTo ErrorHandler

    Dim sGeomFld As String
    sGeomFld = "Geometry"
'    sGeomFld = GetPrimaryGeometryField(sFeature)

'Create an originating pipe to create the recordset
'of the feature class.
    Dim oOP As OriginatingPipe
    gobjConnection.CreateOriginatingPipe oOP
    oOP.Table = sFeature
    oOP.GeometryFieldName = sGeomFld
    
'Run the recordset through the CSSTransformPipe to transform the geometries to
'the CSS of the mapview.
    Dim oCSSPipe As New CSSTransformPipe
    Set oCSSPipe.InputRecordset = oOP.OutputRecordset
    oCSSPipe.InputGeometryFieldName = sGeomFld
    Set oCSSPipe.CoordSystemsMgr = OcxMapView.CoordSystemsMgr
    
'Run the recordset through the CenterPointPipe to get their geometric centers.
    Dim oCenterPipe As New CenterPointPipe
    oCenterPipe.InputGeometryFieldName = sGeomFld
    Set oCenterPipe.InputRecordset = oCSSPipe.OutputRecordset
    oCenterPipe.OutputGeometryFieldName = sGeomFld & "2"
    
'Run the recordset through the GraphicsTextPipe to generate the labels.
    Dim oTextPipe As New GraphicsTextPipe
    oTextPipe.InputGeometryFieldName = sGeomFld & "2"
    Set oTextPipe.InputRecordset = oCenterPipe.OutputRecordset
    oTextPipe.OutputGeometryFieldName = sGeomFld & "3"
    oTextPipe.StringContent = "[" & sAttribute & "]"
    Set RecordsetLable = oTextPipe.OutputRecordset
'Create the legend entry.
    Dim oLE As New RecordLegendEntry
    With oLE
        .Title = sFeature & " Labels"
        .GeometryFieldName = sGeomFld & "3"
        Set .Recordset = oTextPipe.OutputRecordset
        Set .Style = New TextStyle
        With .Style
            .Color = QBColor(OcxMapView.Legend.LegendEntries.Count Mod 16)
            .StyleUnits = gmsStyleUnitsPaperAsNonscaling
            Set .Font = New StdFont
            With .Font
                .Name = "Arial"
                .Size = 10
            End With
        End With
    End With
    
'Display them on the map view.
    If oLE.ValidateSource Then
        If OcxMapView.Legend.LegendEntries.Count = 0 Then
            OcxMapView.Legend.LegendEntries.Append oLE
            oLE.LoadData
            OcxMapView.Fit
        Else
            OcxMapView.Legend.LegendEntries.Append oLE, 1
            oLE.LoadData
        End If
        OcxMapView.Refresh True
        OcxMapView.Legend.Refresh
    End If
    
    GoTo Finish
    
ErrorHandler:
    Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext

Finish:
    On Error Resume Next
    Set oOP = Nothing
    Set oCSSPipe = Nothing
    Set oCenterPipe = Nothing
    Set oTextPipe = Nothing
    Set oLE = Nothing

End Sub
Public Function outputtable(objConn As Connection, InputRecordset As GRecordset, outputTableName As String)
On Error GoTo errhandle