📄 frmrsub.frm
字号:
VERSION 5.00
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "Mo20.ocx"
Begin VB.Form FrmRsub
Caption = "Form1"
ClientHeight = 8280
ClientLeft = 2970
ClientTop = 1590
ClientWidth = 10920
LinkTopic = "Form1"
ScaleHeight = 8280
ScaleWidth = 10920
Begin VB.CommandButton cmdReset
Caption = "重置地图"
Height = 375
Left = 8640
TabIndex = 18
Top = 7320
Width = 2175
End
Begin VB.CommandButton cmdvalue
Caption = "唯一值渲染"
Height = 375
Left = 8640
TabIndex = 17
Top = 1560
Width = 2175
End
Begin VB.CommandButton cmdEqualInterval
Caption = "等组距分类渲染"
Height = 375
Left = 8640
TabIndex = 16
Top = 2040
Width = 2175
End
Begin VB.CommandButton cmdLabel
Caption = "自动标注图层"
Height = 375
Left = 8640
TabIndex = 15
Top = 2520
Width = 2175
End
Begin VB.CommandButton cmdFullExtent
Caption = "显示全图"
Height = 375
Left = 8640
TabIndex = 14
Top = 7680
Width = 2175
End
Begin VB.Frame Frame1
Caption = "组合渲染"
Height = 2415
Left = 8640
TabIndex = 7
Top = 4800
Width = 2295
Begin VB.CheckBox chkVMR
Caption = "ValueMapRenderer"
Enabled = 0 'False
Height = 255
Left = 120
TabIndex = 13
Top = 240
Width = 1935
End
Begin VB.CheckBox chkCBR
Caption = "ClassBreaksRenderer"
Enabled = 0 'False
Height = 375
Left = 120
TabIndex = 12
Top = 480
Width = 2055
End
Begin VB.CheckBox chkLR
Caption = "LabelRenderer"
Enabled = 0 'False
Height = 255
Left = 120
TabIndex = 11
Top = 840
Width = 1935
End
Begin VB.CommandButton cmdApplyGR
Caption = "应用组合渲染对象"
Height = 375
Left = 240
TabIndex = 10
Top = 1920
Width = 1815
End
Begin VB.CheckBox chkCR
Caption = "ChartRenderer"
Enabled = 0 'False
Height = 255
Left = 120
TabIndex = 9
Top = 1200
Width = 1935
End
Begin VB.CheckBox DotR
Caption = "DotRenderer"
Enabled = 0 'False
Height = 255
Left = 120
TabIndex = 8
Top = 1560
Width = 1935
End
End
Begin VB.CommandButton cmdChart
Caption = "饼图渲染"
Height = 375
Left = 8640
TabIndex = 6
Top = 3000
Width = 2175
End
Begin VB.CheckBox chkDrawf
Caption = "显示图层内容"
Height = 255
Left = 8880
TabIndex = 4
Top = 4440
Width = 1575
End
Begin VB.CommandButton Command1
Caption = "点密度渲染"
Height = 375
Left = 8640
TabIndex = 3
Top = 3480
Width = 2175
End
Begin VB.TextBox Text1
Appearance = 0 'Flat
Height = 375
Left = 9360
TabIndex = 2
Text = "10"
Top = 3960
Width = 1455
End
Begin VB.ComboBox Combo1
Height = 300
Left = 8640
TabIndex = 1
Text = "请选择渲染字段"
Top = 600
Width = 2175
End
Begin VB.CommandButton Command2
Caption = "选择其他数据渲染..."
Height = 375
Left = 8640
TabIndex = 0
Top = 1080
Width = 2175
End
Begin MapObjects2.Map Map1
Height = 8055
Left = 0
TabIndex = 5
Top = 0
Width = 8535
_Version = 131072
_ExtentX = 15055
_ExtentY = 14208
_StockProps = 225
BackColor = 16777215
BorderStyle = 1
Contents = "FrmRsub.frx":0000
End
Begin VB.Label Label1
Caption = "点值："
Height = 255
Left = 8640
TabIndex = 20
Top = 4080
Width = 615
End
Begin VB.Label Label2
Caption = "请选择渲染的字段"
Height = 375
Left = 8640
TabIndex = 19
Top = 120
Width = 2175
End
End
Attribute VB_Name = "FrmRsub"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private vmr As MapObjects2.ValueMapRenderer
Private cbr As MapObjects2.ClassBreaksRenderer
Private lr As MapObjects2.LabelRenderer
Private cr As MapObjects2.ChartRenderer
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Dim oDotRend As New MapObjects2.DotDensityRenderer
Dim g_symSelection As MapObjects2.Symbol
Dim recSelection As MapObjects2.Recordset
Dim ttt As Boolean
Private Sub Combo1_Click()
Call ListValues
End Sub
Private Sub Command1_Click()
Set Map1.Layers(0).Renderer = oDotRend
With oDotRend
.Field = "TempField"
.DotSize = 1
.DotColor = moRed
.DotValue = Text1.Text
.DrawBackground = True
End With
DotR.Enabled = True
Map1.Refresh
End Sub
Private Sub Command2_Click()
Load FrmR
FrmR.show
Unload FrmRsub
End Sub
Private Sub Form_Initialize()
InitCommonControls
End Sub
Private Sub cmdValue_Click()
Dim lyr As New MapObjects2.MapLayer
Dim Recs As MapObjects2.Recordset
Dim i As Integer
Set vmr = New MapObjects2.ValueMapRenderer
' Find unique values for the STATE_NAME field
Dim strcStateName As New MapObjects2.Strings
Set lyr = Map1.Layers(0)
Set Recs = lyr.Records
Do Until Recs.EOF
strcStateName.Add Recs.Fields("NAME").Value
Recs.MoveNext
Loop
vmr.Field = "NAME"
' Add the unique values to the Renderer
vmr.ValueCount = strcStateName.Count
For i = 0 To strcStateName.Count - 1
vmr.Value(i) = strcStateName(i)
Next
For i = 0 To vmr.ValueCount - 1
If vmr.Value(i) = "北京市" Then
vmr.Symbol(i).color = moPurple
End If
Next
' Assign the renderer property of the maplayer to the
' ValueMapRenderer object
Set lyr.Renderer = vmr
'Enable the ValueMapRenderer group check box
chkVMR.Enabled = True
' Refresh map display
Map1.Refresh
End Sub
Private Sub cmdEqualInterval_Click()
Dim lyr As New MapObjects2.MapLayer
Dim Recs As MapObjects2.Recordset
Dim stats As MapObjects2.Statistics
Dim i As Integer
Dim numClasses As Integer
Set cbr = New MapObjects2.ClassBreaksRenderer
Set lyr = Map1.Layers(0)
Set Recs = lyr.Records
'We will have our ClassBreaksRenderer contain 5 classes
numClasses = 5
cbr.Field = "TempField"
cbr.BreakCount = numClasses - 1
Set stats = Recs.CalculateStatistics("TempField")
Dim total_range As Double
Dim interval_range As Double
total_range = stats.Max - stats.Min
interval_range = total_range / numClasses
For i = 1 To cbr.BreakCount
cbr.Break(i - 1) = stats.Min + (interval_range * i)
Next
cbr.RampColors moPaleYellow, moNavy
' Assign the renderer property of the maplayer to the
' ClassBreaksRenderer object
Set lyr.Renderer = cbr
'Enable the ClassBreaksRenderer group check box
chkCBR.Enabled = True
'Refresh map display
Map1.Refresh
End Sub
Private Sub cmdLabel_Click()
Dim lyr As New MapObjects2.MapLayer
Dim stats As MapObjects2.Statistics
Dim fntLabelFont As New StdFont
Dim i As Integer
'Make a new LabelRenderer
Set lr = New MapObjects2.LabelRenderer
' Set the font to the "Times New Roman" TrueType font
fntLabelFont.Name = "Times"
' Ensure that the font is not bold
fntLabelFont.Bold = False
Set lyr = Map1.Layers(0)
'lr.Symbol(0).Height = Map1.Extent.Height / 40
'lr.Symbol(0).Font = fntLabelFont
lr.Symbol(0).Font.Size = 7
lr.Field = "NAME"
' Since some states may share county names, allow duplicate labels
lr.AllowDuplicates = True
' Set renderer property of layer to new LabelRenderer
Set lyr.Renderer = lr
'Enable the LabelRenderer group check box
chkLR.Enabled = True
' Refresh map display
Map1.Refresh
End Sub
Private Sub cmdChart_Click()
Set cr = New MapObjects2.ChartRenderer
cr.ChartType = moPie
cr.FieldCount = 2
cr.Field(0) = "SUM_AREA"
cr.Field(1) = "TempField"
cr.MaxPieSize = 20
cr.MinPieSize = 6
cr.color(0) = moRed
cr.color(1) = moBrown
cr.DrawBackground = True
Set Map1.Layers(0).Renderer = cr
'Enable the LabelRenderer group check box
chkCR.Enabled = True
'Redraw the map.
Map1.Refresh
End Sub
Private Sub cmdApplyGR_Click()
Dim gr As New MapObjects2.GroupRenderer
'If the ValueMapRenderer's check box is checked, then
'add the ValueMapRenderer (vmr) to the GroupRenderer (gr)
If chkVMR.Value = 1 Then
gr.Add vmr
End If
If chkCBR.Value = 1 Then
gr.Add cbr
End If
If chkCR.Value = 1 Then
gr.Add cr
End If
If DotR.Value = 1 Then
gr.Add oDotRend
End If
If Not lr Is Nothing Then
If chkLR.Value = 1 Then
gr.Add lr
End If
End If
gr.DrawBackground = chkDrawf.Value
If gr.Count > 0 Then
Set Map1.Layers(0).Renderer = gr
Map1.Refresh
End If
End Sub
Private Sub cmdReset_Click()
Set Map1.Layers("results").Renderer = Nothing
Map1.Refresh
End Sub
Private Sub cmdFullExtent_Click()
Map1.Extent = Map1.FullExtent
End Sub
Private Sub Form_Load()
' Load data into the map
Dim dc1 As New MapObjects2.DataConnection
Dim lyr As New MapObjects2.MapLayer
Dim gds As MapObjects2.GeoDataset
dc1.Database = App.Path
dc1.Connect
If FrmR.ComboADO.Text <> "请选择渲染数据" Then
Set gds = dc1.FindGeoDataset("results")
ttt = True
Else
Set gds = dc1.FindGeoDataset("s省界prj")
ttt = False
End If
If gds Is Nothing Then
MsgBox "You should set DataSourec Properly"
Else
Set lyr.GeoDataset = gds
End If
Map1.Layers.Add lyr
With Map1
If Not .Layers.Count = 1 Then End
.Layers(0).Symbol.color = moDarkGreen
End With
'
' List MapLayer's Numeric Fields in first combo box.
'
With Combo1
Dim fldLyr As MapObjects2.Field
For Each fldLyr In Map1.Layers(0).Records.Fields
If fldLyr.Type < 20 Then '字段不是 点 线 或多边形类型
.AddItem fldLyr.Name
End If
Next fldLyr
' .ListIndex = 0
End With
' Call ListValues
End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim rect As New MapObjects2.rectangle
If Button = 1 Then
' Zoom in
Set rect = Map1.TrackRectangle
If Not rect Is Nothing Then Map1.Extent = rect
Else
' Zoom out
Set rect = Map1.Extent
rect.ScaleRectangle 1.5
Map1.Extent = rect
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set vmr = Nothing
Set cbr = Nothing
Set lr = Nothing
Set cr = Nothing
End Sub
Private Sub ListValues()
If Len(Combo1.List(Combo1.ListIndex)) > 0 Then
'
' Iterate through recordset of MapLayer.
'
Dim recLyr As MapObjects2.Recordset
Dim layer As MapObjects2.MapLayer
Dim Recs As MapObjects2.Recordset
Set layer = Map1.Layers(0)
Set Recs = layer.Records
Dim str As Double
Set recLyr = Map1.Layers(0).Records
Dim strName As String
strName = Combo1.List(Combo1.ListIndex)
Do While Not recLyr.EOF
If ttt = True Then
str = recLyr.Fields(strName).Value 'AsString
Recs.Edit
Recs!TempField = str
Recs.Update
Recs.MoveNext
End If
recLyr.MoveNext
Loop
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -