www.pudn.com > VBSupermapobject.rar > FormMain.frm
VERSION 5.00
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "mo20.ocx"
Object = "{6C20C089-0689-11D5-B2F8-000102D87123}#2.0#0"; "MO21ScaleBar.ocx"
Object = "{C7FC2F7C-0688-11D5-B2F8-000102D87123}#1.0#0"; "MO21Legend.ocx"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{F99BA434-15AD-4C19-9007-0EF3532E0AD3}#10.0#0"; "GISPENG XP Visual Controls.ocx"
Begin VB.Form FrmMain
Appearance = 0 'Flat
AutoRedraw = -1 'True
BackColor = &H00D8E9EC&
Caption = "GISPENG"
ClientHeight = 8280
ClientLeft = 60
ClientTop = 345
ClientWidth = 9855
LinkTopic = "Form1"
NegotiateMenus = 0 'False
ScaleHeight = 8280
ScaleWidth = 9855
StartUpPosition = 3 '窗口缺省
Begin MSComctlLib.Toolbar Toolbar1
Height = 600
Left = 0
TabIndex = 6
Top = 0
Width = 9855
_ExtentX = 17383
_ExtentY = 1058
ButtonWidth = 1138
ButtonHeight = 953
Appearance = 1
_Version = 393216
BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628}
NumButtons = 12
BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "放大"
Style = 2
EndProperty
BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "缩小"
Style = 2
EndProperty
BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "漫游"
Style = 2
EndProperty
BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "全图"
Style = 2
EndProperty
BeginProperty Button5 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "画点"
Style = 2
EndProperty
BeginProperty Button6 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "画线"
Style = 2
EndProperty
BeginProperty Button7 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "矩形"
Style = 2
EndProperty
BeginProperty Button8 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "圆形"
Style = 2
EndProperty
BeginProperty Button9 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "多边性"
Style = 2
EndProperty
BeginProperty Button10 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "文本"
Style = 2
EndProperty
BeginProperty Button11 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "属性"
Style = 2
EndProperty
BeginProperty Button12 {66833FEA-8583-11D1-B16A-00C0F0283628}
EndProperty
EndProperty
Begin VB.TextBox text1
Height = 615
Left = 8040
TabIndex = 8
Text = "LDGIS"
Top = 0
Width = 615
End
Begin GIS_XPForm.XPButtons XPButtons1
Height = 615
Left = 8760
TabIndex = 7
Top = 0
Width = 1095
_ExtentX = 1931
_ExtentY = 1085
Caption = "打印地图 "
CapAlign = 2
BackStyle = 2
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
cGradient = 0
Mode = 0
Value = 0 'False
cBack = -2147483633
End
End
Begin MO21legend.legend legend1
Height = 3735
Left = 240
TabIndex = 1
Top = 840
Width = 2295
_ExtentX = 4048
_ExtentY = 6588
BackColor = -2147483644
ForeColor = -2147483630
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin MapObjects2.Map Map1
Height = 5415
Left = 2760
TabIndex = 0
Top = 840
Width = 6855
_Version = 131072
_ExtentX = 12091
_ExtentY = 9551
_StockProps = 225
BackColor = 16777215
BorderStyle = 1
Appearance = 1
Contents = "FormMain.frx":0000
End
Begin MSComctlLib.ListView ListView1
Height = 1455
Left = 2760
TabIndex = 3
Top = 6360
Width = 6855
_ExtentX = 12091
_ExtentY = 2566
View = 3
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
Begin MO21ScaleBar.ScaleBar ScaleBar1
Height = 600
Left = 240
TabIndex = 4
Top = 6960
Width = 2295
_ExtentX = 4048
_ExtentY = 1058
BackColor = -2147483633
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
MapUnits = 2
ScaleBarUnits = 2
ScreenUnits = 1
End
Begin MapObjects2.Map Map2
Height = 1695
Left = 240
TabIndex = 2
Top = 4800
Width = 2295
_Version = 131072
_ExtentX = 4048
_ExtentY = 2990
_StockProps = 225
BackColor = 12632256
BorderStyle = 1
BackColor = 12632256
Contents = "FormMain.frx":001A
End
Begin MSComctlLib.StatusBar StatusBar1
Align = 2 'Align Bottom
DragMode = 1 'Automatic
Height = 375
Left = 0
TabIndex = 5
Top = 7905
Width = 9855
_ExtentX = 17383
_ExtentY = 661
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 4
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 1
Object.Width = 4736
EndProperty
BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 1
Object.Width = 4736
EndProperty
BeginProperty Panel3 {8E3867AB-8586-11D1-B16A-00C0F0283628}
AutoSize = 1
Object.Width = 4736
EndProperty
BeginProperty Panel4 {8E3867AB-8586-11D1-B16A-00C0F0283628}
EndProperty
EndProperty
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 dc As New DataConnection
Dim layer As MapLayer
Dim col As ColumnHeader
Dim r As MapObjects2.Rectangle
Dim fdback As DragFeedback
Dim sym As MapObjects2.Symbol
Dim pt As Point
Dim pts As New Points
Dim lsline As MapObjects2.Line
Dim poly As MapObjects2.Polygon
Dim rect As MapObjects2.Rectangle
Dim elli As MapObjects2.Ellipse
Dim txsym As TextSymbol
Dim Recs As MapObjects2.Recordset
Dim fld As Field
'Dim lslayer As MapLayer
'scalebar控件状态栏StatusBar
Private Sub refreshscale()
ScaleBar1.MapExtent.MaxX = Map1.Extent.Right
ScaleBar1.MapExtent.MinX = Map1.Extent.Left
ScaleBar1.MapExtent.MaxY = Map1.Extent.Bottom
ScaleBar1.MapExtent.MinY = Map1.Extent.Top
ScaleBar1.PageExtent.MinX = Map1.Left / Screen.TwipsPerPixelX
ScaleBar1.PageExtent.MinY = Map1.Top / Screen.TwipsPerPixelY
ScaleBar1.PageExtent.MaxX = (Map1.Left + Map1.Width) / Screen.TwipsPerPixelX
ScaleBar1.PageExtent.MaxY = (Map1.Top + Map1.Height) / Screen.TwipsPerPixelY
ScaleBar1.Refresh
StatusBar1.Panels(1).Text = "比例 1：" & Format$(ScaleBar1.RFScale, "###,###,###,###")
End Sub
'加载图层数据
Private Sub LayerSet()
Set layer = New MapLayer
Set layer.GeoDataset = dc.FindGeoDataset("地市界线_polyline.shp")
layer.Name = "界线"
Map1.Layers.Add layer
Set layer = New MapLayer
Set layer.GeoDataset = dc.FindGeoDataset("镇_region.shp")
layer.Symbol.Color = moOrange
layer.Symbol.Size = 1
layer.Symbol.Outline = True
layer.Symbol.OutlineColor = moGreen
layer.Symbol.Style = 9
layer.Name = "乡镇"
Map1.Layers.Add layer
Set layer = New MapLayer
Set layer.GeoDataset = dc.FindGeoDataset("镇名_region.shp")
layer.Symbol.Color = moRed
layer.Symbol.Font = "幼圆"
layer.Symbol.Size = 12
layer.Name = "镇名"
Map1.Layers.Add layer
Set layer = New MapLayer
Set layer.GeoDataset = dc.FindGeoDataset("路网_polyline.shp")
layer.Symbol.Color = moRed
layer.Symbol.Size = 3
layer.Symbol.Style = 0
layer.Name = "路网"
Set layer.Renderer = New LabelRenderer
layer.Renderer.Field = "Name"
layer.Renderer.Symbol(0).Font.Size = 2
layer.Renderer.Symbol(0).Color = moRed
layer.Renderer.AllowDuplicates = True
Map1.Layers.Add layer
Set layer = New MapLayer
Set layer.GeoDataset = dc.FindGeoDataset("地市界线_polyline.shp")
layer.Symbol.Color = moYellow
Map2.Layers.Add layer
End Sub
Private Sub Form_Load()
'初始化ListView1的ColumnHeaders属性
Set col = ListView1.ColumnHeaders.Add()
col.Text = "Field"
Set col = ListView1.ColumnHeaders.Add()
col.Text = "Value"
'加载地图数据
'dc.Database = "E:\LDGISLearning\数据\实验数据\shp"
dc.Database = App.Path + "\Data"
If Not dc.Connect Then
MsgBox "指定文件夹下没有找到相应的数据!"
End If
LayerSet
legend1.setMapSource Map1
legend1.LoadLegend True
Map1.Refresh
End Sub
Private Sub legend1_AfterSetLayerVisible(Index As Integer, isVisible As Boolean)
Map1.Refresh
End Sub
Private Sub Map1_AfterLayerDraw(ByVal Index As Integer, ByVal canceled As Boolean, ByVal hdc As stdole.OLE_HANDLE)
Call refreshscale
If Index = 1 Then
Map2.TrackingLayer.Refresh True
End If
End Sub
Public Sub Map1_AfterTrackingLayerDraw(ByVal hdc As stdole.OLE_HANDLE)
If Toolbar1.Buttons(5).Value = 1 Then
If Not pts Is Nothing Then
Set sym = New Symbol
sym.Color = moBlack
sym.SymbolType = moPointSymbol
sym.Size = 10
Map1.DrawShape pts, sym
End If
End If
If Toolbar1.Buttons(6).Value = 1 Then
If Not lsline Is Nothing Then
Set sym = New Symbol
If pts.Count > 1 Then
sym.Color = moBlack
sym.SymbolType = moLineSymbol
sym.Size = 5
Map1.DrawShape lsline, sym
End If
End If
End If
If Toolbar1.Buttons(7).Value = 1 Then
If Not rect Is Nothing Then
Set sym = New Symbol
sym.SymbolType = moFillSymbol
sym.Style = moDiagonalCrossFill
sym.Color = moBlue
Map1.DrawShape rect, sym
End If
End If
If Toolbar1.Buttons(8).Value = 1 Then
If Not elli Is Nothing Then
Set sym = New Symbol
sym.SymbolType = moFillSymbol
sym.Style = moDiagonalCrossFill
sym.Color = moGreen
Map1.DrawShape elli, sym
End If
End If
If Toolbar1.Buttons(9).Value = 1 Then
If Not poly Is Nothing Then
Set sym = New Symbol
sym.Color = moGreen
Map1.DrawShape poly, sym
End If
End If
If Toolbar1.Buttons(10).Value = 1 Then
If Not pt Is Nothing Then
Set txsym = New TextSymbol
txsym.Color = moBlack
Map1.DrawText text1.Text, pt, txsym
End If
End If
End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Toolbar1.Buttons(1).Value = 1 Then
Set Map1.Extent = Map1.TrackRectangle
ElseIf Toolbar1.Buttons(3).Value = 1 Then
Map1.Pan
ElseIf Toolbar1.Buttons(2).Value = 1 Then
Set r = Map1.Extent
r.ScaleRectangle 1.5
Map1.Extent = r
ElseIf Toolbar1.Buttons(4).Value = 1 Then
Map1.Extent = Map1.FullExtent
ElseIf Toolbar1.Buttons(5).Value = 1 Then
Set pt = Map1.ToMapPoint(x, y)
pts.Add pt
Map1.TrackingLayer.Refresh True
ElseIf Toolbar1.Buttons(6).Value = 1 Then
If lsline Is Nothing Then
Set lsline = New MapObjects2.Line
End If
If pts Is Nothing Then
Set pts = New Points
End If
Set pt = Map1.ToMapPoint(x, y)
pts.Add pt
If pts.Count = 1 Then
lsline.Parts.Add pts
Set pts = lsline.Parts(0)
End If
Map1.TrackingLayer.Refresh True
ElseIf Toolbar1.Buttons(7).Value = 1 Then
Set rect = Map1.TrackRectangle
Map1.TrackingLayer.Refresh True
ElseIf Toolbar1.Buttons(8).Value = 1 Then
Set elli = Map1.TrackCircle
Map1.TrackingLayer.Refresh True
ElseIf Toolbar1.Buttons(9).Value = 1 Then
Set poly = Map1.TrackPolygon
Map1.TrackingLayer.Refresh True
ElseIf Toolbar1.Buttons(10).Value = 1 Then
Set pt = Map1.ToMapPoint(x, y)
Map1.TrackingLayer.Refresh True
'属性查询
ElseIf Toolbar1.Buttons(11).Value = 1 Then
Dim newitem As Object
Set pt = Map1.ToMapPoint(x, y)
'Set lslayer = Map1.Layers(0)
Set Recs = Map1.Layers(2).SearchShape(pt, 12, "")
If Not Recs.EOF Then
ListView1.ListItems.Clear
For Each fld In Recs.Fields
Set newitem = ListView1.ListItems.Add
newitem.Text = fld.Name
newitem.SubItems(1) = fld.ValueAsString
Next fld
End If
End If
End Sub
Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim pt As New Point
Set pt = Map1.ToMapPoint(x, y)
StatusBar1.Panels(2).Text = "x=" & pt.x
StatusBar1.Panels(3).Text = "y=" & pt.y
End Sub
Private Sub Map2_AfterTrackingLayerDraw(ByVal hdc As stdole.OLE_HANDLE)
Dim sym As New Symbol
sym.Size = 2
sym.OutlineColor = moRed
sym.Style = moTransparentFill
Map2.DrawShape Map1.Extent, sym
End Sub
Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim rec As New MapObjects2.Rectangle
Dim pt As New MapObjects2.Point
'Set rec = Map2.TrackRectangle
'Set Map1.Extent = rec
Set pt = Map2.ToMapPoint(x, y)
'Map1.CenterAt pt.x, pt.y
If Map1.Extent.IsPointIn(pt) Then
Set fdback = New DragFeedback
fdback.DragStart Map1.Extent, Map2, x, y
Else
Set rec = Map2.TrackRectangle
Set Map1.Extent = rec
Map1.CenterAt pt.x, pt.y
End If
End Sub
Private Sub Map2_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Not fdback Is Nothing Then
fdback.DragMove x, y
End If
End Sub
Private Sub Map2_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Not fdback Is Nothing Then
Map1.Extent = fdback.DragFinish(x, y)
Set fdback = Nothing
End If
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
If Toolbar1.Buttons(1).Value = 1 Then
Map1.MousePointer = moZoomIn
ElseIf Toolbar1.Buttons(3).Value = 1 Then
Map1.MousePointer = moPan
ElseIf Toolbar1.Buttons(2).Value = 1 Then
Map1.MousePointer = moZoomOut
ElseIf Toolbar1.Buttons(4).Value = 1 Then
Set Map1.Extent = Map1.FullExtent
Map1.MousePointer = moDefault
ElseIf Toolbar1.Buttons(5).Value = 1 Then
Set pt = Nothing
Set pts = Nothing
Map1.MousePointer = moDefault
ElseIf Toolbar1.Buttons(6).Value = 1 Then
Set pt = Nothing
Set lsline = Nothing
Set pts = Nothing
Map1.MousePointer = moDefault
ElseIf Toolbar1.Buttons(7).Value = 1 Then
Map1.MousePointer = moDefault
ElseIf Toolbar1.Buttons(8).Value = 1 Then
Map1.MousePointer = moDefault
ElseIf Toolbar1.Buttons(9).Value = 1 Then
Map1.MousePointer = moDefault
ElseIf Toolbar1.Buttons(10).Value = 1 Then
Map1.MousePointer = moDefault
ElseIf Toolbar1.Buttons(11).Value = 1 Then
Map1.MousePointer = moDefault
Set pt = Nothing
End If
End Sub
Private Sub XPButtons1_Click()
On Error GoTo err1
Printer.Print
Map1.OutputMap Printer.hdc
Printer.EndDoc
MsgBox "打印完成。"
Exit Sub
err1:
MsgBox Err.Description + "，程序停止。"
Unload Me
'On Error GoTo err1
' Map1.PrintMap "MyMap", "", Option1.Value
' MsgBox "打印完成。"
' Exit Sub
'err1:
' MsgBox Err.Description + "，程序停止。"
' Unload Me
End Sub