📄 frmmain.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Object = "{2635E9FF-96C9-11CF-8638-08003601B01F}#5.0#0"; "event.ocx"
Object = "{47E3FD10-88A2-11CF-A17B-08003606E802}#5.0#0"; "mapview.ocx"
Begin VB.Form FrmMain
Caption = "Main"
ClientHeight = 5955
ClientLeft = 165
ClientTop = 450
ClientWidth = 9300
LinkTopic = "Form1"
ScaleHeight = 5955
ScaleWidth = 9300
StartUpPosition = 2 'CenterScreen
Begin ComctlLib.Toolbar Toolbar1
Align = 1 'Align Top
Height = 420
Left = 0
TabIndex = 1
Top = 0
Visible = 0 'False
Width = 9300
_ExtentX = 16404
_ExtentY = 741
ButtonWidth = 635
ButtonHeight = 582
Appearance = 1
ImageList = "ImageList1"
_Version = 327682
BeginProperty Buttons {0713E452-850A-101B-AFC0-4210102A8DA7}
NumButtons = 2
BeginProperty Button1 {0713F354-850A-101B-AFC0-4210102A8DA7}
Key = "line"
Object.ToolTipText = "DigitLine"
Object.Tag = ""
ImageIndex = 1
EndProperty
BeginProperty Button2 {0713F354-850A-101B-AFC0-4210102A8DA7}
Key = "polygon"
Object.ToolTipText = "DigitPolygon"
Object.Tag = ""
ImageIndex = 2
EndProperty
EndProperty
Begin VB.ComboBox ComSelectTable
Height = 315
Left = 960
TabIndex = 2
Text = "Select table"
Top = 0
Width = 1455
End
End
Begin GMEventControlLib.EventControl EventControl1
Left = 6840
Top = 1920
_Version = 327680
_ExtentX = 741
_ExtentY = 741
_StockProps = 0
End
Begin MapviewLib.GMMapView GMMapView1
Height = 2295
Left = 960
TabIndex = 0
Top = 1320
Width = 4215
_Version = 327680
_ExtentX = 7435
_ExtentY = 4048
_StockProps = 0
End
Begin MSComDlg.CommonDialog cdFile
Left = 7560
Top = 3840
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin ComctlLib.ImageList ImageList1
Left = 6600
Top = 480
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 327682
BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7}
NumListImages = 2
BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "FrmMain.frx":0000
Key = ""
EndProperty
BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "FrmMain.frx":0352
Key = ""
EndProperty
EndProperty
End
Begin VB.Menu mnuFile
Caption = "&File"
Begin VB.Menu mnuFileOpen
Caption = "&Open"
End
Begin VB.Menu mnuOpenWorkSpace
Caption = "OpenWorkSpace"
End
Begin VB.Menu mnuSaveWorkSpace
Caption = "SaveWorkSpace"
End
Begin VB.Menu mnuPrint
Caption = "Print"
End
Begin VB.Menu mnuFileExit
Caption = "E&xit"
End
End
Begin VB.Menu mnuView
Caption = "&View"
Begin VB.Menu mnuViewZoomIn
Caption = "Zoom &In"
End
Begin VB.Menu mnuViewZoomOut
Caption = "Zoom &Out"
End
Begin VB.Menu mnuViewPan
Caption = "Pan"
End
Begin VB.Menu mnuViewFit
Caption = "&Fit"
End
Begin VB.Menu mnuViewLegend
Caption = "&Legend"
End
Begin VB.Menu mnuDisplayFeature
Caption = "&Add Feature"
End
Begin VB.Menu Select
Caption = "Select"
End
Begin VB.Menu mnuViewProperty
Caption = "Property"
End
End
Begin VB.Menu test
Caption = "test"
Begin VB.Menu testgenerallable
Caption = "generallable"
End
Begin VB.Menu intersectionPipe
Caption = "intersectionPipe"
End
Begin VB.Menu DifferencePipe
Caption = "DifferencePipe"
End
Begin VB.Menu outputtable
Caption = "outputtable"
End
Begin VB.Menu geometryLocate
Caption = "geometryLocate"
End
Begin VB.Menu thematic
Caption = "thematic"
End
Begin VB.Menu SelectedView
Caption = "SelectedView"
End
Begin VB.Menu edit
Caption = "edit"
End
Begin VB.Menu mnuDigit
Caption = "Digit"
End
End
End
Attribute VB_Name = "FrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim objSmartLocSvrc As New SmartLocateService
Dim objLocatedObjects As New LocatedObjectsCollection
Dim objEventServer As New EventServer
Dim objPntGeom As New PointGeometry
Dim DigitLine As New PolylineGeometry
Dim DigitArea As New PolygonGeometry
Dim objPntZoom As New Point
Dim gobjPnt As New Point
Dim ZoomRect As New RectangleGeometry 'when zooming use the ZoomRect object
Dim ZoomLineStyle As New LinearStyle
Dim ZoomRectX1, ZoomRectY1, ZoomRectZ1, ZoomRectX2, ZoomRectY2, ZoomRectZ2 As Double
Public MouseAction As String
Public RecordsetOutputTable As GRecordset
Private Sub ComSelectTable_Click()
Dim orgPip As OriginatingPipe
Dim selectRs As GRecordset
gobjConnection.CreateOriginatingPipe orgPip
orgPip.Table = ComSelectTable.List(ComSelectTable.ListIndex)
Set selectRs = orgPip.OutputRecordset
If selectRs.GFields(GetGeometryFieldName(selectRs)).SubType = 1 Then 'line
Me.Toolbar1.Buttons(1).Enabled = True
Me.Toolbar1.Buttons(2).Enabled = False
ElseIf selectRs.GFields(GetGeometryFieldName(selectRs)).SubType = 2 Then 'area
Me.Toolbar1.Buttons(2).Enabled = True
Me.Toolbar1.Buttons(1).Enabled = False
Else
Me.Toolbar1.Buttons(1).Enabled = False
Me.Toolbar1.Buttons(2).Enabled = False
End If
ReLoadLegendEntry selectRs, FrmMain.GMMapView1
End Sub
Private Sub DifferencePipe_Click()
MouseAction = "Difference"
frmSpatialAnylize.Show
End Sub
Private Sub edit_Click()
On Error GoTo errhandle
Dim gobjLineSelectStyle As New LinearStyle
Dim objRS As GRecordset
Dim sFieldName As String
Dim objGblob As Variant
Dim objGeometry As Object
Dim objGss As New GeometryStorageService
With gobjHandleStyle
.Color = RGB(0, 0, 0) '''黑色
.HandleMode = gmsHandleModeSolid
.HandleShape = gmsHandleShapeSquare
.Size = 4
.StyleUnits = gmsStyleUnitsView
End With
With gobjLineSelectStyle
.Width = 3
.Color = RGB(200, 200, 50)
.LineStyle = gmsLinearSolid
.StyleUnits = gmsStyleUnitsView
End With
Set objRS = objLocatedObjects.Item(1).Recordset
sFieldName = GetGeometryFieldName(objRS)
objRS.Bookmark = objLocatedObjects.Item(1).Bookmark
objGblob = objRS.GFields(sFieldName).Value
objGss.StorageToGeometry objGblob, objGeometry
Set rsGrecordset = objRS
gobjGeomEdit.AppendGeometry objGeometry, gobjLineSelectStyle
gobjGeomEdit.SelectAllKeypoints gobjGeomEdit.GeometryCount, gobjHandleStyle
MouseAction = "Edit"
Exit Sub
errhandle:
Exit Sub
End Sub
Private Sub EventControl1_Click(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)
If MouseAction = "Property" Then
objPntGeom.Origin.X = worldX
objPntGeom.Origin.Y = worldY
objPntGeom.Origin.Z = worldZ
objLocatedObjects.Clear
GMMapView1.HighlightedObjects.Clear
objSmartLocSvrc.Locate objPntGeom, GMMapView1.Dispatch, objLocatedObjects
If objLocatedObjects.Count > 0 Then
GMMapView1.HighlightedObjects.Add objLocatedObjects.Item(1)
End If
GMMapView1.Refresh False
If objLocatedObjects.Count > 0 Then
FrmProperties.FillFlexGrid objLocatedObjects.Item(1)
End If
End If
If MouseAction = "Select" Then
objPntGeom.Origin.X = worldX
objPntGeom.Origin.Y = worldY
objPntGeom.Origin.Z = worldZ
objLocatedObjects.Clear
GMMapView1.HighlightedObjects.Clear
gobjGeomEdit.RemoveAllGeometries
objSmartLocSvrc.Locate objPntGeom, GMMapView1.Dispatch, objLocatedObjects
If objLocatedObjects.Count > 0 Then
GMMapView1.HighlightedObjects.Add objLocatedObjects.Item(1)
End If
GMMapView1.Refresh False
End If
If MouseAction = "DigitLine" Then
gobjPnt.X = worldX
gobjPnt.Y = worldY
gobjPnt.Z = worldZ
If objGeomDig.IsGeometryComplete Then
objGeomDig.RemoveAllGeometries
objGeomDig.AppendGeometry DigitLine, ZoomLineStyle
End If
objGeomDig.AppendPoint gobjPnt
End If
If MouseAction = "DigitArea" Then
gobjPnt.X = worldX
gobjPnt.Y = worldY
gobjPnt.Z = worldZ
If objGeomDig.IsGeometryComplete Then
objGeomDig.RemoveAllGeometries
objGeomDig.AppendGeometry DigitArea, ZoomLineStyle
End If
objGeomDig.AppendPoint gobjPnt
End If
End Sub
Private Sub EventControl1_DblClick(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)
If MouseAction = "DigitLine" Then
Dim addRS As GRecordset
MouseAction = "Select"
CreateRecordsetAtDigit ComSelectTable.List(ComSelectTable.ListIndex), addRS
SaveGeometry objGeomDig.GetGeometry(1), addRS
ReLoadLegendEntry addRS, FrmMain.GMMapView1
objGeomDig.RemoveAllGeometries
End If
If MouseAction = "DigitArea" Then
Dim AddRSarea As GRecordset
MouseAction = "Select"
CreateRecordsetAtDigit ComSelectTable.List(ComSelectTable.ListIndex), AddRSarea
SaveGeometry objGeomDig.GetGeometry(1), AddRSarea
ReLoadLegendEntry AddRSarea, FrmMain.GMMapView1
objGeomDig.RemoveAllGeometries
End If
End Sub
Private Sub EventControl1_MouseDown(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
Dim objGeom As Object
Dim pntIndex As Integer
If Button = 1 Then
objPntZoom.X = worldX
objPntZoom.Y = worldY
objPntZoom.Z = worldZ
If MouseAction = "ZoomIn" Or MouseAction = "ZoomOut" Then
ZoomRectX1 = worldX
ZoomRectY1 = worldY
ZoomRectZ1 = worldZ
If objGeomDig.IsGeometryComplete Then
objGeomDig.RemoveAllGeometries
objGeomDig.AppendGeometry ZoomRect, ZoomLineStyle
End If
objGeomDig.AppendPoint objPntZoom
End If
If MouseAction = "pan" Then
objPntZoom.X = worldX
objPntZoom.Y = worldY
objPntZoom.Z = worldZ
End If
If MouseAction = "Edit" Then
If Not (snapPnt Is Nothing) Then
Select Case snapType:
Case gmssOnVertex: '''编辑顶点
gobjGeomEdit.UnSelectAllKeypoints gobjGeomEdit.GeometryCount
gobjGeomEdit.SelectKeypoint gobjGeomEdit.GeometryCount, Myindex, gobjHandleStyle
pnt1.X = snapPnt.X
pnt1.Y = snapPnt.Y
pnt1.Z = snapPnt.Z
gobjGeomEdit.BeginMove pnt1
bMovePoint = True
Set pnt1 = Nothing
Case gmssOnEndVertex: '''编辑顶点
gobjGeomEdit.UnSelectAllKeypoints gobjGeomEdit.GeometryCount
gobjGeomEdit.SelectKeypoint gobjGeomEdit.GeometryCount, Myindex, gobjHandleStyle
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -