modfunction.bas

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

Attribute VB_Name = "ModFunction"
Option Explicit

Public Sub OpenConnection()
  ' Display a common dialog to request an Access database
  ' file name.
  ' Algorithm:
  ' 1.  Initialize dialog parameters
  ' 2.  Display dialog
  ' 3.  If user said OK, attempt to open the database
  ' 4.  If user said Cancel, exit sub
  ' 5.  If open failed, display an error message and redisplay file dialog
  ' 6.  If open succeeded, create a DatabaseEntry and add the
  ' element to the global array

  Dim strFile As String
  On Error GoTo ErrorHandler
  ' setup and display the dialog
  strFile = BrowseForFile(FrmMain.cdFile)
  ' check status
  If (strFile = "") Then
    Exit Sub
  Else
    ' open database
    FrmMain.MousePointer = 11
    
    On Error Resume Next
    If Not (gobjConnection Is Nothing) Then
       gobjConnection.Disconnect
    End If
    On Error GoTo ErrorHandler
      With gobjConnection
        .Type = "Access.GDatabase"
        .ConnectionName = "Access Connection 1"
        .Location = strFile
        .Connect
      End With
    LoadCoord gobjConnection, FrmMain.GMMapView1
    FrmMain.MousePointer = 0
  End If
  
  Exit Sub

ErrorHandler:
  MsgBox Err.Description, MSGBOX_ERROR, "OpenDatabase Failure"

End Sub
Private Function BrowseForFile(CDlg As CommonDialog) As String
  
  ' Handle Errors
  On Error GoTo UserCancelled
    
  ' Set FileOpen Dialog Filters
  CDlg.Filter = "(*.mdb)|*.mdb"
  
  ' Set Path To Current Path In Current Drive
  CDlg.InitDir = CurDir
  
  ' Set Filter The First In The Filter List
  CDlg.FilterIndex = 1
  ' If user cancels, trap it
  CDlg.CancelError = True
  
  ' Show FileOpen Dialog
  CDlg.Action = 1
  
  If Err.Number = 32755 Then
    BrowseForFile = ""
  Else
    ' Return filename
    BrowseForFile = CDlg.FileName
  End If
  Exit Function
  
UserCancelled:
  BrowseForFile = ""
 
End Function ' OpenFile
Public Sub OpenDatabase(iDataBaseType As Integer, Location As String, Server As String, DataBaseName As String, USERID As String, Password As String)
  '1 open access database
  '2 open sqlserver database
  '3 open oracle database
  Dim conKeyWord As String
  On Error GoTo ErrorHandler
    On Error Resume Next
    Set gobjConnection = Nothing
      With gobjConnection
         If iDataBaseType = 1 Then
            .Type = "Access.GDatabase"
            .Location = Location
         ElseIf iDataBaseType = 2 Then
            .Type = "SQLServerRW.GDatabase"
            .Location = "Sql Server"
            .ConnectionName = "xxx"
            conKeyWord = "Uid=" & "libin" & _
                        ";Pwd=" & "123" & _
                        ";Database=" & "geomedia" & _
                        ";SERVER=" & "libin"
            .ConnectInfo = conKeyWord
            'MsgBox .ConnectInfo
            .Mode = gmcModeReadWrite
         End If
            .Connect
      End With
  Exit Sub
ErrorHandler:
  MsgBox Err.Description, MSGBOX_ERROR, "OpenDatabase Failure"
End Sub


Public Function GetGeometryFieldName(InputRecordset As GRecordset) As String
 On Error GoTo errhandle
  Dim objfield As GField
      For Each objfield In InputRecordset.GFields
        If objfield.Type = gdbSpatial Or objfield.Type = gdbGraphic Then
          GetGeometryFieldName = objfield.Name
          Exit For
        Else
          GetGeometryFieldName = ""
        End If
      Next objfield
    Set objfield = Nothing
    Exit Function
errhandle:
    MsgBox "GetGeometryFieldName Fail"
    Set objfield = Nothing
End Function
Public Sub CreateRecordset(objRS As GRecordset)
  ' this function display a form to select a database/feature class
  ' Once selected, the recordset is returned to the calling function
  
  ' Algorithm:
  ' 1.  check to ensure at least one connection exists
  ' 2.  call frmSelectFeature.GetSelectFeatureInfo to display the form with
  '     databases and tables properly populated on the form, and get the
  '     connection and table the user chose
  ' 3.  create a recordset using OriginatingPipe
  
  On Error GoTo ErrorHandler
  
  'Check to ensure at least one connection exists.
  
  Dim strActiveTableName As String
  frmSelectFeature.GetSelectFeatureInfo gobjConnection, strActiveTableName
  
  If strActiveTableName <> "" Then
    Dim objOP As OriginatingPipe
    gobjConnection.CreateOriginatingPipe objOP
    objOP.Table = strActiveTableName
    Set objRS = objOP.OutputRecordset
    Set objOP = Nothing
  End If
Exit Sub
ErrorHandler:
  MsgBox Err.Description, MSGBOX_ERROR, "CreateRecordset Error"
End Sub
Public Sub CreateRecordsetAtDigit(TableName As String, objRS As GRecordset)
  On Error GoTo ErrorHandler
    
  If TableName <> "" Then
    Dim objOP As OriginatingPipe
    gobjConnection.CreateOriginatingPipe objOP
    objOP.Table = TableName
    Set objRS = objOP.OutputRecordset
    Set objOP = Nothing
  End If
  Exit Sub
ErrorHandler:
  MsgBox Err.Description, vbOKOnly, "CreateRecordset Error"
End Sub
Public Function GetLegendEntry(objRS As GRecordset) As RecordLegendEntry

    On Error GoTo ErrorHandler
  
'Create the RecordLegendEntry returned by this function.
    Set GetLegendEntry = CreateObject("GeoMedia.RecordLegendEntry")
  
'Create the ExtendedPropertySet of the input recordset.
    Dim objExt As Object
    Set objExt = objRS.GetExtension("ExtendedPropertySet")
    
'Get the name of the geometry field.
    GetLegendEntry.GeometryFieldName = objExt.GetValue("PrimaryGeometryFieldName")
    If GetLegendEntry.GeometryFieldName = "" Then
        ' this will be true when the table only contains a text field
        Dim objfield As GField
        For Each objfield In objRS.GFields
            If objfield.Type = gdbSpatial Or objfield.Type = gdbGraphic Then
                GetLegendEntry.GeometryFieldName = objfield.Name
                Exit For
            End If
        Next objfield
        Set objfield = Nothing
    End If
  
'Get the name of the recordset and set that to be the legend entry title.
    GetLegendEntry.Title = objExt.GetValue("Name")
  
'Get the geometry type and use that as input to get a style object for this
'legend entry.
    Dim iGeometryType As Integer
    iGeometryType = objExt.GetValue("GeometryType")
    Set GetLegendEntry.Style = GetStyleObject(iGeometryType)
    ' name will be blank if the recordset is derived so default it
    If GetLegendEntry.Title = "" Then
      GetLegendEntry.Title = objRS.GFields(0).SourceTable
    End If
 
'Run the recordset through the CSSTransformPipe to transform the geometries to
'the CSS of the mapview.  The definition of the transform occurred at the time of the
'recordset creation
    Dim objCSSPipe As New CSSTransformPipe
    Set objCSSPipe.InputRecordset = objRS
    Set objCSSPipe.CoordSystemsMgr = FrmMain.GMMapView1.CoordSystemsMgr
    objCSSPipe.InputGeometryFieldName = GetLegendEntry.GeometryFieldName
    objCSSPipe.OutputCSGUID = FrmMain.GMMapView1.CoordSystemsMgr.CoordSystem.Guid

    Set GetLegendEntry.Recordset = objCSSPipe.OutputRecordset

    Set objExt = Nothing
    Set objCSSPipe = Nothing
  
    Exit Function
  
ErrorHandler:
    MsgBox Err.Description, MSGBOX_ERROR, "GetLegendEntry Error"
    On Error Resume Next
    Set objExt = Nothing
    Set objCSSPipe = Nothing
  
End Function

Public Sub DisplayTheLegendEntry(objLE As RecordLegendEntry)

    On Error GoTo ErrorHandler
    
    If Not (objLE Is Nothing) Then
        Dim objLegend As Legend
        Set objLegend = FrmMain.GMMapView1.Legend
        If objLE.ValidateSource Then
            If objLegend.LegendEntries.Count = 0 Then
                objLegend.LegendEntries.Append objLE
                objLE.LoadData
                FrmMain.GMMapView1.Fit
            Else
                objLegend.LegendEntries.Append objLE, 1
                objLE.LoadData
            End If
            FrmMain.GMMapView1.Fit
            FrmMain.GMMapView1.Refresh True
        End If
        Set objLegend = Nothing
    End If
    
    Exit Sub

ErrorHandler:
    MsgBox Err.Description, MSGBOX_ERROR, "DisplayTheLegendEntry Error"
    On Error Resume Next
    Set objLegend = Nothing

End Sub

Public Function ReLoadLegendEntry(objRS As GRecordset, OcxMapView As GMMapView)
    On Error GoTo errhandle
    Dim objLE As RecordLegendEntry
    Dim i As Integer
    Dim isExist As Boolean
    Dim IndexLegendEntry As Integer
    Set objLE = GetLegendEntry(objRS)
    If OcxMapView.Legend.LegendEntries.Count = 0 Then
       DisplayTheLegendEntry objLE
    Else
       For i = 1 To OcxMapView.Legend.LegendEntries.Count
           If objRS.GFields(0).SourceTable = OcxMapView.Legend.LegendEntries(i).Recordset.GFields(0).SourceTable Then
              IndexLegendEntry = i
              isExist = True
              Exit For
           Else
              isExist = False
           End If
       Next i
        If isExist Then
           OcxMapView.Legend.LegendEntries.Remove IndexLegendEntry
           DisplayTheLegendEntry objLE
        Else
           DisplayTheLegendEntry objLE
        End If
    End If
    Exit Function
errhandle:
      MsgBox Err.Description, vbOKOnly, "重新加载图例时出错"
End Function