testcom.frm
来自「里面有我用VB二次开发MAPGIS的20个例子」· FRM 代码 · 共 1,350 行 · 第 1/3 页
FRM
1,350 行
VERSION 5.00
Object = "{5A187E03-1FE4-11D3-9C2F-000021DF30C1}#1.0#0"; "EditView.ocx"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "Mscomctl.ocx"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "Comctl32.ocx"
Object = "{DF9A974A-C445-42A2-BC89-1A90FB1A0B52}#7.2#0"; "MapTree.ocx"
Begin VB.Form TestForm
Caption = "Map测试系统"
ClientHeight = 5856
ClientLeft = 132
ClientTop = 420
ClientWidth = 8088
LinkTopic = "Form1"
ScaleHeight = 5856
ScaleWidth = 8088
StartUpPosition = 2 '屏幕中心
WindowState = 2 'Maximized
Begin MapTree.MapTreeCtrl layerTreeView
Height = 3240
Left = 576
TabIndex = 3
Top = 684
Width = 2448
_ExtentX = 4318
_ExtentY = 5715
End
Begin VB.PictureBox Spliter
BackColor = &H8000000C&
BorderStyle = 0 'None
FillColor = &H00808080&
Height = 5448
Left = 3288
MousePointer = 9 'Size W E
ScaleHeight = 5448
ScaleWidth = 108
TabIndex = 2
Top = -12
Width = 108
End
Begin MSComctlLib.StatusBar StatusBar
Align = 2 'Align Bottom
Height = 408
Left = 0
TabIndex = 1
Top = 5448
Width = 8088
_ExtentX = 14266
_ExtentY = 720
_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}
Object.Width = 4233
MinWidth = 4233
Text = "武汉中地软件"
TextSave = "武汉中地软件"
EndProperty
EndProperty
End
Begin EDITVIEWLib.EditView EditView
Height = 4344
Left = 3972
TabIndex = 0
Top = 852
Width = 2544
_Version = 65536
_ExtentX = 4487
_ExtentY = 7662
_StockProps = 0
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 4968
Top = 384
_ExtentX = 677
_ExtentY = 677
_Version = 393216
End
Begin ComctlLib.ImageList mnuImageList
Left = 1884
Top = 4560
_ExtentX = 804
_ExtentY = 804
BackColor = 12632256
ImageWidth = 16
ImageHeight = 15
MaskColor = 12632256
_Version = 327682
BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7}
NumListImages = 7
BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "TestCom.frx":0000
Key = ""
EndProperty
BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "TestCom.frx":0112
Key = ""
EndProperty
BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "TestCom.frx":0224
Key = ""
EndProperty
BeginProperty ListImage4 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "TestCom.frx":0766
Key = ""
EndProperty
BeginProperty ListImage5 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "TestCom.frx":0878
Key = ""
EndProperty
BeginProperty ListImage6 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "TestCom.frx":098A
Key = ""
EndProperty
BeginProperty ListImage7 {0713E8C3-850A-101B-AFC0-4210102A8DA7}
Picture = "TestCom.frx":0A9C
Key = ""
EndProperty
EndProperty
End
Begin VB.Menu mnuPOPMap
Caption = "工程"
Begin VB.Menu mnuNewMap
Caption = "新建工程"
End
Begin VB.Menu mnuOpenMap
Caption = "打开工程"
End
Begin VB.Menu mnuSaveMap
Caption = "保存工程"
End
Begin VB.Menu mnuCloseMap
Caption = "关闭工程"
End
End
Begin VB.Menu mnuPOPDsp
Caption = "绘制"
Begin VB.Menu mnuDspMyDraw
Caption = "自己绘制"
End
End
Begin VB.Menu mnuPOPMapFun
Caption = "Map函数"
Begin VB.Menu mnuFindFirstNext
Caption = "循环取每个Layer"
End
Begin VB.Menu mnuFindLayer
Caption = "查找特定Layer"
End
End
Begin VB.Menu mnuPOPLegend
Caption = "图例"
Begin VB.Menu mnuMapDispLeg
Caption = "Map显示图例"
End
Begin VB.Menu mnuSep1
Caption = "-"
End
Begin VB.Menu mnuLegOpen
Caption = "打开图例文件"
End
Begin VB.Menu mnuLegSave
Caption = "保存图例文件"
End
Begin VB.Menu mnuLegSaveAs
Caption = "另存图例文件"
End
Begin VB.Menu mnuLegEditItem
Caption = "编辑图例文件"
End
Begin VB.Menu mnuLegClose
Caption = "关闭图例文件"
End
Begin VB.Menu mnuSep2
Caption = "-"
End
Begin VB.Menu mnuLegOpenPad
Caption = "打开图例板"
End
Begin VB.Menu mnuLegClosePad
Caption = "关闭图例板"
End
Begin VB.Menu mnuSep3
Caption = "-"
End
Begin VB.Menu mnuLegGetSelItem
Caption = "取当前选中的图例"
End
Begin VB.Menu mnuLegSetParam
Caption = "设置图例参数"
End
Begin VB.Menu mnuLegWriteToFile
Caption = "把图例转换为文件"
End
End
Begin VB.Menu mnuPOPPrint
Caption = "输出"
Begin VB.Menu mnuPrintFitToPage
Caption = "按照纸张大小设置"
End
Begin VB.Menu mnuPrintAutoCheckPage
Caption = "系统自动检测"
End
Begin VB.Menu mnuPrintSetParam
Caption = "设置输出参数"
End
Begin VB.Menu mnuSep4
Caption = "-"
End
Begin VB.Menu mnuRastTreat
Caption = "光栅化处理"
End
Begin VB.Menu mnuWindowsOut
Caption = "Windows输出"
End
Begin VB.Menu mnuSep5
Caption = "-"
End
Begin VB.Menu mnuCreateGif
Caption = "生成Gif图象"
End
Begin VB.Menu mnuCreateTif
Caption = "生成Tif图象"
End
End
Begin VB.Menu mnuPOPRaster
Caption = "Raster"
Begin VB.Menu mnuRstLayerOpen
Caption = "打开RasterLayer"
End
End
Begin VB.Menu mnuPOPTool
Caption = "Tool操作"
Begin VB.Menu mnuToolMoveRect
Caption = "移动Rect"
End
Begin VB.Menu mnuToolMoveLegRect
Caption = "移动LegRect"
End
Begin VB.Menu mnuToolClear
Caption = "清除Tool"
End
Begin VB.Menu mnuTest
Caption = "Test"
End
End
End
Attribute VB_Name = "TestForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public PubComPrj As Map
Public PubMapLeg As MapLegend
Public PubMapPrintParam As MapPrintParam
Public DspMyDraw As Integer
Dim PubRasterLayer As RasterLayer
Dim bSpliterPressed As Boolean
Dim BFIRSTSHOW As Boolean
Const SPLITWID = 30
'Tool操作对象
Public mpMoveLegRectTool As MoveLegRectTool
Public WithEvents mpMoveRectTool As MoveRectTool
Attribute mpMoveRectTool.VB_VarHelpID = -1
Public Test1 As TestClass1
Private Sub EditView_MousePosition(ByVal x_Pos As Double, ByVal y_Pos As Double)
On Error Resume Next
Dim str As String
Dim layername As String * 512
Dim layer As Integer
Dim ailin As Integer
Dim fname As String * 256
Dim res As Integer
str = "X坐标:" & Format(x_Pos, "0.000") & " Y坐标:" & Format(y_Pos, "0.000") ' & " 当前图层:" & layer & " (" & layername & ")"
Me.StatusBar.Panels(2).Text = str
End Sub
'自己绘制
Private Sub EditView_MyDraw(ByVal MpDC As Object)
On Error Resume Next
Dim mdc As MapGisDC
Dim mrc As D_Rect
Dim mrcDev As New D_Rect
Dim dot1 As New D_Dot
Dim dot2 As New D_Dot
If PubComPrj Is Nothing Then
Exit Sub
End If
Set mdc = MpDC
Set mrc = PubComPrj.MapRect
'显示图象
If Not (PubRasterLayer Is Nothing) Then
Call PubRasterLayer.Display(mdc)
End If
'dot1.x = 100
'dot1.y = 100
'dot2.x = 300
'dot2.y = 400
'
'mdc.LpToDpXY dot1
'mdc.LpToDpXY dot2
'
'mrcDev.xmin = dot1.x
'mrcDev.ymin = dot1.y
'mrcDev.xmax = dot2.x
'mrcDev.ymax = dot2.y
'
'mdc.RectDev mrcDev.xmin, mrcDev.ymin, mrcDev.xmax, mrcDev.ymax, 6
Set mrcDev = Nothing
Set mrc = Nothing
Set mdc = Nothing
End Sub
Private Sub Form_Load()
On Error Resume Next
DspMyDraw = 0
BFIRSTSHOW = True
'设置图形菜单
SetMenuBitMap
End Sub
Private Sub Form_Resize()
On Error Resume Next
EditView.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight
Dim offsetHei
offsetHei = 20
If Me.ScaleHeight - StatusBar.Height - offsetHei <= 0 Then
Exit Sub
End If
layerTreeView.Move 0, 0, Me.ScaleWidth / 4, Me.ScaleHeight - StatusBar.Height - offsetHei
EditView.Move Me.ScaleWidth / 4, 0, Me.ScaleWidth * 3 / 4, Me.ScaleHeight - StatusBar.Height - offsetHei
Spliter.Move Me.ScaleWidth / 4, 0, SPLITWID, Me.ScaleHeight - StatusBar.Height - offsetHei
Me.StatusBar.Panels(1).Width = Me.ScaleWidth / 5
Me.StatusBar.Panels(2).Width = Me.ScaleWidth * 3 / 5
Me.StatusBar.Panels(3).Width = Me.ScaleWidth / 5
End Sub
Private Sub layerTreeView_MouseDblClick(clicklayer As MAPGISLAYERCOMLib.MapLayer)
If Not (clicklayer Is Nothing) Then
MsgBox "layerTreeView_MouseDblClick!" & vbCrLf & "Name=" & clicklayer.WorkArea.Name
End If
End Sub
Private Sub layerTreeView_MouseLClick(clicklayer As MAPGISLAYERCOMLib.MapLayer)
'If Not (clicklayer Is Nothing) Then
' MsgBox "layerTreeView_Click!" & vbCrLf & "Name=" & clicklayer.WorkArea.Name
'End If
End Sub
Private Sub layerTreeView_UpdateMapTree()
'更新显示内容
EditView.UpdateWindow
End Sub
'设置图形菜单
Private Sub SetMenuBitMap()
On Error Resume Next
Dim i%
Dim hMenu, hSubMenu, menuID, x
hMenu = GetMenu(hwnd)
'Map菜单
hSubMenu = GetSubMenu(hMenu, 0)
For i = 1 To 4
menuID = GetMenuItemID(hSubMenu, i - 1)
x = SetMenuItemBitmaps(hMenu, menuID, &H4, mnuImageList.ListImages(i).Picture, mnuImageList.ListImages(i).Picture)
Next
'Draw菜单
hSubMenu = GetSubMenu(hMenu, 1)
menuID = GetMenuItemID(hSubMenu, 0)
x = SetMenuItemBitmaps(hMenu, menuID, 0, mnuImageList.ListImages(6).Picture, 0&)
'Draw菜单
hSubMenu = GetSubMenu(hMenu, 2)
menuID = GetMenuItemID(hSubMenu, 0)
x = SetMenuItemBitmaps(hMenu, menuID, 0, mnuImageList.ListImages(5).Picture, mnuImageList.ListImages(5).Picture)
menuID = GetMenuItemID(hSubMenu, 1)
x = SetMenuItemBitmaps(hMenu, menuID, 0, mnuImageList.ListImages(7).Picture, mnuImageList.ListImages(7).Picture)
End Sub
'******************************************'
'**************图例 处理函数***************'
'******************************************'
'图例--打开图例文件
Private Sub mnuLegOpen_Click()
On Error Resume Next
If PubComPrj Is Nothing Then
MsgBox "工程对象为空!"
Exit Sub
End If
Set PubMapLeg = PubComPrj.Legend
If (PubMapLeg Is Nothing) Then
Exit Sub
End If
CommonDialog1.DialogTitle = "选择要打开的图例文件"
CommonDialog1.FileName = ""
CommonDialog1.Filter = "图例文件(*.CLN)|*.CLN||"
CommonDialog1.ShowOpen
If CommonDialog1.FileName = "" Then
Exit Sub
End If
'打开图例文件
PubMapLeg.LoadLegendFile CommonDialog1.FileName
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?