?? geometryop.vb
字號:
Imports VBCommon
Namespace Common
Public Class GeometryOP
Shared Function LoadCoord(ByRef ActiveConnection As PClient.Connection, ByRef OcxMapView As AxMapviewLib.AxGMMapView) As Object
'Load coordinate system from gdatabase, then assign to mapview
Dim i As Integer
Dim sSQL As String
Dim Flds() As Object
Dim FldTemp As Object
Dim objRsCoord As PClient.GRecordset
Dim objCoordSysMgr As Object
Dim objDB As PClient.GDatabase
objCoordSysMgr = CreateObject("CoordSystemsMgr")
sSQL = "Select * From GCoordSystem"
objDB = ActiveConnection.Database
objRsCoord = objDB.OpenRecordset(sSQL, PClient.GConstants.gdbOpenDynaset)
ReDim Flds(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
objRsCoord = Nothing
objCoordSysMgr.CoordSystem.LoadFromGCoordSystemTableRowFormat(Flds)
OcxMapView.CoordSystemsMgr = objCoordSysMgr
objCoordSysMgr = Nothing
End Function
Shared Sub OpenDatabase(ByRef iDataBaseType As Short, ByRef Location As String, ByRef Server As String, ByRef DataBaseName As String, ByRef USERID As String, ByRef 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
gobjConnection.Disconnect()
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 = PClient.ConnectionConstants.gmcModeReadWrite
End If
.Connect()
End With
Exit Sub
ErrorHandler:
MsgBox(Err.Description, MSGBOX_ERROR, "打開數據庫出錯")
End Sub
Shared Function GetFeatureNameList(Optional ByVal bGeoFeature As Boolean = False) As ArrayList
On Error GoTo ErrorHandler
Dim alFeatureName As ArrayList
Dim objMDSrvc As New GMService.MetadataService()
Dim vTableList As Object
Dim tmask As Integer
Dim i As Short
alFeatureName = New ArrayList()
If gobjConnection.Status = PClient.ConnectionConstants.gmcStatusOpen Then
objMDSrvc.Connection = gobjConnection
If bGeoFeature Then
tmask = PService.MetadataTableConstants.gmmtGraphic + PService.MetadataTableConstants.gmmtAnySpatial + _
PService.MetadataTableConstants.gmmtAreal + PService.MetadataTableConstants.gmmtLinear + _
PService.MetadataTableConstants.gmmtPoint
Else
tmask = 1 + 2 + 4 + 8 + 16 + 32 + 128
End If
objMDSrvc.GetTables(tmask, vTableList)
For i = 0 To (UBound(vTableList) - LBound(vTableList) - 1)
alFeatureName.Add(vTableList(i))
Next i
objMDSrvc = Nothing
Else
MsgBox("數據庫連接未打開", MsgBoxStyle.OKOnly, "錯誤")
End If
Return alFeatureName
ErrorHandler:
MsgBox(Err.Description, MSGBOX_ERROR, "錯誤")
objMDSrvc = Nothing
End Function
Shared Sub CreateRecordset(ByRef objRS As PClient.GRecordset, ByVal strActiveTableName As String, ByVal strFilter As String)
' 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 objOP As PClient.OriginatingPipe
If strActiveTableName <> "" Then
gobjConnection.CreateOriginatingPipe(objOP)
objOP.Table = strActiveTableName
objOP.Filter = strFilter
objRS = objOP.OutputRecordset
objOP = Nothing
End If
Exit Sub
ErrorHandler:
MsgBox(Err.Description, MSGBOX_ERROR, "CreateRecordset Error")
End Sub
Shared Sub DisplayTheLegendEntry(ByRef objLE As PView.RecordLegendEntry, ByRef OcxMapView As AxMapviewLib.AxGMMapView)
On Error GoTo ErrorHandler
Dim objLegend As PView.Legend
If Not (objLE Is Nothing) Then
If OcxMapView.Legend Is Nothing Then
OcxMapView.Legend = New PView.Legend()
End If
objLegend = OcxMapView.Legend
If objLE.ValidateSource Then
If objLegend.LegendEntries.Count = 0 Then
objLegend.LegendEntries.Append(objLE)
objLE.LoadData()
OcxMapView.Fit()
Else
objLegend.LegendEntries.Append(objLE, 1)
objLE.LoadData()
End If
OcxMapView.Fit()
OcxMapView.CtlRefresh(True)
End If
objLegend = Nothing
End If
Exit Sub
ErrorHandler:
MsgBox(Err.Description, MSGBOX_ERROR, "圖例顯示出錯")
On Error Resume Next
objLegend = Nothing
End Sub
Shared Function GetLegendEntry(ByRef objRS As PClient.GRecordset, ByRef OcxMapView As AxMapviewLib.AxGMMapView) As PView.RecordLegendEntry
On Error GoTo ErrorHandler
Dim GLegend As PView.RecordLegendEntry
'Create the RecordLegendEntry returned by this function.
GLegend = CreateObject("GeoMedia.RecordLegendEntry")
'Create the ExtendedPropertySet of the input recordset.
Dim objExt As Object
objExt = objRS.GetExtension("ExtendedPropertySet")
'Get the name of the geometry field.
GLegend.GeometryFieldName = objExt.GetValue("PrimaryGeometryFieldName")
Dim objfield As PClient.GField
If GLegend.GeometryFieldName = "" Then
' this will be true when the table only contains a text field
For Each objfield In objRS.GFields
If objfield.Type = PClient.GConstants.gdbSpatial Or objfield.Type = PClient.GConstants.gdbGraphic Then
GLegend.GeometryFieldName = objfield.Name
Exit For
End If
Next objfield
objfield = Nothing
End If
'Get the name of the recordset and set that to be the legend entry title.
GLegend.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 Short
iGeometryType = objExt.GetValue("GeometryType")
GLegend.Style = GetStyleObject(iGeometryType)
' name will be blank if the recordset is derived so default it
If GLegend.Title = "" Then
GLegend.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 PDBPipe.CSSTransformPipe()
objCSSPipe.InputRecordset = objRS
objCSSPipe.CoordSystemsMgr = OcxMapView.CoordSystemsMgr
objCSSPipe.InputGeometryFieldName = GLegend.GeometryFieldName
objCSSPipe.OutputCSGUID = OcxMapView.CoordSystemsMgr.CoordSystem.GUID
GLegend.Recordset = objCSSPipe.OutputRecordset
objExt = Nothing
objCSSPipe = Nothing
Return GLegend
'Exit Function
ErrorHandler:
MsgBox(Err.Description, MSGBOX_ERROR, "獲取圖例出錯")
On Error Resume Next
objExt = Nothing
objCSSPipe = Nothing
End Function
Shared Function ReLoadLegendEntry(ByRef objRS As PClient.GRecordset, ByRef OcxMapView As AxMapviewLib.AxGMMapView) As Object
On Error GoTo errhandle
Dim objLE As PView.RecordLegendEntry
Dim i As Short
Dim isExist As Boolean
Dim IndexLegendEntry As Short
Dim objStyle As Object
Dim strTitle As String
objLE = GetLegendEntry(objRS, OcxMapView)
If OcxMapView.Legend.LegendEntries.Count = 0 Then
DisplayTheLegendEntry(objLE, OcxMapView)
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
objStyle = OcxMapView.Legend.LegendEntries(i).Style
strTitle = OcxMapView.Legend.LegendEntries(i).Title
isExist = True
Exit For
Else
isExist = False
End If
Next i
If isExist Then
OcxMapView.Legend.LegendEntries.Remove(IndexLegendEntry)
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -