📄 form1.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "Mscomctl.ocx"
Object = "{5A187E03-1FE4-11D3-9C2F-000021DF30C1}#1.0#0"; "EditView.ocx"
Begin VB.Form Form1
AutoRedraw = -1 'True
BackColor = &H80000000&
Caption = "TestComDBS"
ClientHeight = 6840
ClientLeft = 2790
ClientTop = 1710
ClientWidth = 9405
DrawMode = 14 'Copy Pen
DrawStyle = 4 'Dash-Dot-Dot
FillColor = &H00FFFFFF&
BeginProperty Font
Name = "Times New Roman"
Size = 7.5
Charset = 0
Weight = 400
Underline = 0 'False
Italic = -1 'True
Strikethrough = 0 'False
EndProperty
Icon = "Form1.frx":0000
LinkTopic = "Form1"
MousePointer = 2 'Cross
ScaleHeight = 6840
ScaleWidth = 9405
Begin EDITVIEWLib.EditView EditView
CausesValidation= 0 'False
Height = 3600
Left = -240
TabIndex = 1
Top = 120
Width = 4800
_Version = 65536
_ExtentX = 8467
_ExtentY = 6350
_StockProps = 0
End
Begin MSComctlLib.StatusBar StatusBar
Align = 2 'Align Bottom
Height = 390
Left = 0
TabIndex = 0
Top = 6450
Width = 9405
_ExtentX = 16589
_ExtentY = 688
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 3
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Object.Width = 2469
MinWidth = 2469
EndProperty
BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Object.Width = 5292
MinWidth = 5292
EndProperty
BeginProperty Panel3 {8E3867AB-8586-11D1-B16A-00C0F0283628}
Enabled = 0 'False
Object.Width = 4233
MinWidth = 4233
Text = "武汉中地软件"
TextSave = "武汉中地软件"
EndProperty
EndProperty
End
Begin VB.Menu mnuFile
Caption = "文件"
Begin VB.Menu mnuOpenDBS
Caption = "打开图库"
Shortcut = ^O
End
Begin VB.Menu mnuSeparator11
Caption = "-"
End
Begin VB.Menu mnuSave
Caption = "图库保存"
Shortcut = ^S
End
Begin VB.Menu mnuSaveAs
Caption = "图库另存为"
End
Begin VB.Menu mnuPackSaveAs
Caption = "图库压缩存为"
End
Begin VB.Menu mnuSeparator12
Caption = "-"
End
Begin VB.Menu mnuImpIndex
Caption = "引入图库索引…"
End
Begin VB.Menu mnuExpIndex
Caption = "导出图库索引…"
End
Begin VB.Menu mnuSeparator13
Caption = "-"
End
Begin VB.Menu mnuOutDocument
Caption = "输出图库文档"
End
Begin VB.Menu mnuCloseDocum
Caption = "关闭图库文件"
Shortcut = ^C
End
End
Begin VB.Menu mnuWindow
Caption = "窗口"
Begin VB.Menu mnuArcVisible
Caption = "区弧段可见"
End
Begin VB.Menu mnuSeparator21
Caption = "-"
End
Begin VB.Menu mnuEnableRange
Caption = "允许图库漫游"
End
Begin VB.Menu mnuChartDisp
Caption = "接图表显示"
Checked = -1 'True
End
Begin VB.Menu mnuGraphDisp
Caption = " 图形显示"
End
End
Begin VB.Menu mnuFrmManage
Caption = "图幅管理"
Begin VB.Menu mnuLayerManage
Caption = "图库层类管理器"
End
Begin VB.Menu mnuSeparator31
Caption = "-"
End
Begin VB.Menu mnuDataManager
Caption = "图幅数据维护"
End
Begin VB.Menu mnuDelFrm
Caption = "删除图幅数据"
End
Begin VB.Menu mnuSeparator32
Caption = "-"
End
Begin VB.Menu mnuIndexReg
Caption = "获取图库索引工作区…"
End
Begin VB.Menu mnuRgnAttAskDBSClsDat
Caption = "指定范围条件查询"
End
Begin VB.Menu mnuSeparator33
Caption = "-"
End
Begin VB.Menu mnuQueryInf
Caption = "查询图库信息"
End
End
Begin VB.Menu mnuFind
Caption = "图库检索"
Begin VB.Menu mnudsExpJTBToPrj
Caption = "输出接图表工程文件"
End
Begin VB.Menu mnuSelFrams
Caption = "选取图幅数据输出"
End
Begin VB.Menu mnuSeparator42
Caption = "-"
End
Begin VB.Menu mnuMerg
Caption = "查询提取时图元归并"
End
Begin VB.Menu mnuSeparator43
Caption = "-"
End
Begin VB.Menu mnuPntGraphInf
Caption = "查询点图元信息"
Begin VB.Menu mnuPntClassNo
Caption = "底图点元层号"
Enabled = 0 'False
End
Begin VB.Menu mnuPntAtt
Caption = "底图点元属性"
Enabled = 0 'False
End
End
Begin VB.Menu mnuLinGraphInf
Caption = "查询线图元信息"
Begin VB.Menu mnuLinClassNo
Caption = "底图线元层号"
Enabled = 0 'False
End
Begin VB.Menu mnuLinAtt
Caption = "底图线元属性"
Enabled = 0 'False
End
End
Begin VB.Menu mnuRegGraphInf
Caption = "查询区图元信息"
Begin VB.Menu mnuRegClassNo
Caption = "底图区元层号"
Enabled = 0 'False
End
Begin VB.Menu mnuRegAtt
Caption = "底图区元属性"
Enabled = 0 'False
End
End
Begin VB.Menu mnuSeparator44
Caption = "-"
End
Begin VB.Menu mnuAttAskGraDataToArea
Caption = "纯属性条件数据查询"
End
Begin VB.Menu RgnAttAskDBSClsDat
Caption = "区域属性条件数据提取 "
End
End
Begin VB.Menu Option
Caption = "选项"
Begin VB.Menu mnuEditParam
Caption = "编辑库投影参数"
End
Begin VB.Menu mnuSetCoordinate
Caption = " 设置提示坐标参数"
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit '确保所有变量都被明确说明
Dim pDBSLayer As DBSLayer
Dim pDBSArea As DBSArea
Dim IsGraDisp, IsArcDisp As Boolean
Dim IsView, IsDel, IsMerg As Boolean
Dim IsQuPnt, IsQuLin, IsQuReg As Boolean
Dim IsQuPntA, IsQuLinA, IsQuRegA As Boolean
'Dim PubMapDC As MapGisDC
Dim pDDotL, pDDotR, pDDotDbl As D_Dot
Dim lFramNo, lFrmNo As Long
Private Sub EditView_LButtonDblClk(ByVal xPos As Double, ByVal yPos As Double)
Set pDDotDbl = New D_Dot
pDDotDbl.x = xPos
pDDotDbl.y = yPos
'获取指定点所在图库图幅号
If Not pDBSArea Is Nothing Then
lFramNo = pDBSArea.dsSeekDBSIdxReg(pDDotDbl)
If IsDel = True Then
pDBSArea.dsDelDBSFramDat lFramNo
IsDel = False
End If
If IsView = True Then
If IsGraDisp = True Then
pDBSArea.dsDBSFramDatViewer lFramNo
Else
pDBSArea.dsDBSFramDatManger lFramNo
End If
IsView = False
End If
lFramNo = pDBSArea.dsSeekDBSIdxReg(pDDotL)
Dim pGIdx As DBS_GraIndex
Dim clsNo As Integer
Dim pDRect As D_Rect
Dim wArea As WorkArea
Dim a As IAi
Dim clsDatTyp As Enum_Dbs_File_Type
If IsGraDisp = True Then
Dim i, nCNumb As Integer
If IsQuPnt = True Or IsQuLin = True Or IsQuReg = True Or IsQuPntA = True Or IsQuLinA = True Or IsQuRegA = True Then
'由对话框选择图库当前层类
clsNo = pDBSArea.dsSelDBSCurClass
If clsNo >= 0 Then
pDBSArea.dsGetDBSClassNumb nCNumb
For i = 0 To nCNumb - 1
pDBSArea.dsSetDBSClassOnOff i, 0
Next i
pDBSArea.dsSetDBSClassOnOff clsNo, 1
EditView.UpdateWindow
'由给定RECT范围提取指定层类数据
Set pDRect = pDBSArea.rect
If Not pDRect Is Nothing Then
Set wArea = pDBSArea.dsRectAskDBSClsDat(clsNo, pDRect, IsMerg)
If Not wArea Is Nothing Then
Set a = wArea
clsDatTyp = pDBSArea.dsGetDBSClassDataType(clsNo)
Select Case clsDatTyp
Case 0
pDBSArea.dsNearDBSPnt clsNo, pDDotL, pGIdx
If Not pGIdx Is Nothing Then
'闪烁
EditView.FlashAPnt a.ai, pGIdx.graphNo
End If
Case 1
pDBSArea.dsNearDBSLin clsNo, pDDotL, pGIdx
If Not pGIdx Is Nothing Then
'闪烁
'EditView.FlashALin a.ai, pGIdx.graphNo
End If
Case 2
pDBSArea.dsSeekDBSReg clsNo, pDDotL, pGIdx
If Not pGIdx Is Nothing Then
'闪烁
EditView.FlashAReg a.ai, pGIdx.graphNo
End If
End Select
End If
End If
End If
If Not pGIdx Is Nothing Then
If IsQuPnt = True Or IsQuLin = True Or IsQuReg = True Then
pDBSArea.dsViewDBSGraLayerName pGIdx
IsQuPnt = False
IsQuLin = False
IsQuReg = False
Else
If IsQuPntA = True Then
pDBSArea.dsViewDBSPntAtt pGIdx
IsQuPntA = False
Else
If IsQuLinA = True Then
pDBSArea.dsViewDBSLinAtt pGIdx
IsQuLinA = False
Else
pDBSArea.dsViewDBSRegAtt pGIdx
IsQuRegA = False
End If
End If
End If
'停止闪烁
EditView.StopFlash
End If
End If
End If
End If
End Sub
Private Sub EditView_MouseLButtonDown(ByVal xPos As Double, ByVal yPos As Double)
Set pDDotL = New D_Dot
pDDotL.x = xPos
pDDotL.y = yPos
If Not pDBSArea Is Nothing Then
lFramNo = pDBSArea.dsSeekDBSIdxReg(pDDotL)
End If
End Sub
Private Sub EditView_MouseLButtonUp(ByVal xPos As Double, ByVal yPos As Double)
Set pDDotR = New D_Dot
pDDotR.x = xPos
pDDotR.y = yPos
End Sub
Private Sub mnuArcVisible_Click()
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -