📄 frmtheme.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form frmThemeUnique
BorderStyle = 3 'Fixed Dialog
Caption = "单值图"
ClientHeight = 4785
ClientLeft = 45
ClientTop = 330
ClientWidth = 8520
Icon = "frmTheme.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4785
ScaleWidth = 8520
ShowInTaskbar = 0 'False
StartUpPosition = 1 'CenterOwner
Begin VB.CommandButton cmdApply
Caption = "应用"
Enabled = 0 'False
Height = 375
Left = 7320
TabIndex = 13
Top = 4320
Width = 1095
End
Begin VB.CommandButton cmdCancel
Caption = "取消"
Height = 375
Left = 6120
MaskColor = &H000000FF&
TabIndex = 12
Top = 4320
Width = 1095
End
Begin VB.CommandButton cmdOK
Caption = "确定"
Height = 375
Left = 4920
TabIndex = 11
Top = 4320
Width = 1095
End
Begin VB.CommandButton cmdAddAllValues
BackColor = &H000000FF&
Caption = "刷新"
Height = 375
Left = 3720
MaskColor = &H000000FF&
TabIndex = 10
Top = 4320
Width = 1095
End
Begin VB.Frame fraThemeName
Height = 3975
Left = 120
TabIndex = 1
Top = 120
Width = 8295
Begin VB.Frame Frame2
Caption = "颜色"
Height = 735
Left = 4440
TabIndex = 7
Top = 300
Width = 3615
Begin MSComctlLib.ImageCombo imgcboColorRamp
Height = 330
Left = 240
TabIndex = 8
Top = 240
Width = 3135
_ExtentX = 5530
_ExtentY = 582
_Version = 393216
ForeColor = -2147483640
BackColor = -2147483643
End
End
Begin VB.Frame Frame3
Caption = "字段"
Height = 735
Left = 2040
TabIndex = 5
Top = 300
Width = 2175
Begin VB.ComboBox cmbFields
Height = 300
Left = 240
TabIndex = 6
Top = 240
Width = 1695
End
End
Begin VB.PictureBox picSample
Appearance = 0 'Flat
BackColor = &H80000005&
ForeColor = &H80000008&
Height = 1215
Left = 240
ScaleHeight = 1185
ScaleWidth = 1545
TabIndex = 4
Top = 2520
Width = 1575
End
Begin VB.Frame Frame4
Caption = "图层"
Height = 2055
Left = 240
TabIndex = 2
Top = 360
Width = 1575
Begin VB.ListBox lstMapLayers
Height = 1620
Left = 120
TabIndex = 3
Top = 240
Width = 1335
End
End
Begin MSComctlLib.ListView lvwSymbol
Height = 2535
Left = 2040
TabIndex = 9
Top = 1200
Width = 6015
_ExtentX = 10610
_ExtentY = 4471
View = 3
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 3
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "符号"
Object.Width = 1764
EndProperty
BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 1
Text = "值"
Object.Width = 3528
EndProperty
BeginProperty ColumnHeader(3) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 2
Text = "序号"
Object.Width = 5168
EndProperty
End
End
Begin VB.PictureBox picTemp
Appearance = 0 'Flat
AutoRedraw = -1 'True
BackColor = &H8000000B&
ForeColor = &H80000008&
Height = 375
Left = 2520
ScaleHeight = 23
ScaleMode = 3 'Pixel
ScaleWidth = 71
TabIndex = 0
Top = 4320
Visible = 0 'False
Width = 1095
End
Begin MSComctlLib.ImageList iltColorRamp
Left = 1080
Top = 4200
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
MaskColor = 12632256
_Version = 393216
End
Begin MSComctlLib.ImageList iltSecond
Left = 480
Top = 4200
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
MaskColor = 12632256
_Version = 393216
End
Begin MSComctlLib.ImageList iltFirst
Left = 0
Top = 4200
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
MaskColor = 12632256
_Version = 393216
End
Begin VB.Line Line1
X1 = 120
X2 = 8400
Y1 = 4200
Y2 = 4200
End
End
Attribute VB_Name = "frmThemeUnique"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private m_pMap As IMap '选择的地图
Private m_pLayer As ILayer '选择的图层
Private m_pSymbolsArray As IArray '符号集合
Private m_colValues As Collection '值集合
Private m_intSymbolsNum As Integer '符号总数
Private m_pGeoFeatureLayer As IGeoFeatureLayer '当前选择的图层
Private m_bChangeImageList As Boolean '交替使用两个PictureBox
Private m_bChangeSymbol As Boolean '是否更换符号
Private m_strShapeType As String '当前选中的图层类型
Private m_intColorRampArray(3, 6) As Integer '色带参数数组
Private m_colMapLayers As Collection '地图所有图层
'窗体需要设置的参数（可选）
Public Property Let Map(pMap As IMap)
Set m_pMap = pMap
End Property
'窗体需要设置的参数（可选）
Public Property Let Layer(pLayer As ILayer)
Set m_pLayer = pLayer
End Property
Private Sub cmbFields_Click()
'若单值符号已经存在则加载之
If m_pGeoFeatureLayer.Renderer Is Nothing Then Exit Sub
Dim pFeatureRenderer As IFeatureRenderer
Set pFeatureRenderer = m_pGeoFeatureLayer.Renderer
If TypeOf pFeatureRenderer Is IUniqueValueRenderer Then
Dim i As Integer
Set m_colValues = Nothing
Set m_colValues = New Collection
Debug.Assert Not m_colValues Is Nothing
If m_colValues Is Nothing Then Exit Sub
m_intSymbolsNum = -1
Set m_pSymbolsArray = Nothing
Set m_pSymbolsArray = New esriSystem.Array
Debug.Assert Not m_pSymbolsArray Is Nothing
If m_pSymbolsArray Is Nothing Then Exit Sub
Dim pUniqueValueRenderer As IUniqueValueRenderer
Set pUniqueValueRenderer = pFeatureRenderer
Dim strValue As String
For i = 0 To pUniqueValueRenderer.ValueCount - 1
m_colValues.Add pUniqueValueRenderer.Value(i)
m_pSymbolsArray.Add pUniqueValueRenderer.Symbol(pUniqueValueRenderer.Value(i))
Next i
m_intSymbolsNum = pUniqueValueRenderer.ValueCount
'显示刚加载的符号
DisplaySymbols
End If
End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
'初始化
Private Sub Form_Load()
'初始化变量(含参数转换)
InitVariables
'初始化动态界面
InitDynamicDisplay
End Sub
'初始化变量
Private Sub InitVariables()
Set m_pSymbolsArray = Nothing
Set m_colValues = Nothing
m_intSymbolsNum = -1
Set m_pGeoFeatureLayer = Nothing
m_bChangeImageList = False
m_bChangeSymbol = False
m_strShapeType = ""
Set m_colMapLayers = Nothing
Set m_colMapLayers = New Collection
Debug.Assert Not m_colMapLayers Is Nothing
If m_colMapLayers Is Nothing Then Exit Sub
Debug.Assert Not (m_pMap Is Nothing And m_pLayer Is Nothing)
If m_pMap Is Nothing And m_pLayer Is Nothing Then
Exit Sub
End If
If Not m_pLayer Is Nothing Then
If TypeOf m_pLayer Is IGeoFeatureLayer Then
Set m_pMap = Nothing
Set m_pMap = New Map
Debug.Assert Not m_pMap Is Nothing
If m_pMap Is Nothing Then
MsgBox "内存不足。"
Exit Sub
End If
m_pMap.AddLayer m_pLayer
End If
End If
Set m_colMapLayers = GetMapFeatLayers(m_pMap)
Dim i As Integer
For i = 1 To m_colMapLayers.Count
lstMapLayers.AddItem m_colMapLayers.Item(i)
Next i
lstMapLayers.ListIndex = 0
Set m_colMapLayers = Nothing
lvwSymbol.View = lvwReport
End Sub
'初始化动态显示界面
Private Sub InitDynamicDisplay()
picSample.Picture = LoadPicture(App.Path & "\Bitmaps\Unique.bmp")
'设置色带
InitColorRamp
End Sub
'设置色带
Private Sub InitColorRamp()
'非分类图`
If Not frmMapControl.m_enumThemeMapType = enumClassMap Then
'设置参数
m_intColorRampArray(0, 0) = 0
m_intColorRampArray(0, 1) = 360
m_intColorRampArray(0, 2) = 50
m_intColorRampArray(0, 3) = 100
m_intColorRampArray(0, 4) = 10
m_intColorRampArray(0, 5) = 60
m_intColorRampArray(1, 0) = 30
m_intColorRampArray(1, 1) = 30
m_intColorRampArray(1, 2) = 0
m_intColorRampArray(1, 3) = 50
m_intColorRampArray(1, 4) = 10
m_intColorRampArray(1, 5) = 20
m_intColorRampArray(2, 0) = 60
m_intColorRampArray(2, 1) = 160
m_intColorRampArray(2, 2) = 20
m_intColorRampArray(2, 3) = 100
m_intColorRampArray(2, 4) = 10
m_intColorRampArray(2, 5) = 60
'加载图例
With iltColorRamp
.ImageWidth = 202
.ImageHeight = 17
.ListImages.Add Picture:=LoadPicture(App.Path & "\bitmaps\1.2.bmp")
.ListImages.Add Picture:=LoadPicture(App.Path & "\bitmaps\1.3.bmp")
.ListImages.Add Picture:=LoadPicture(App.Path & "\bitmaps\1.5.bmp")
.ListImages.Add Picture:=LoadPicture(App.Path & "\bitmaps\YellowToRed.bmp")
.ListImages.Add Picture:=LoadPicture(App.Path & "\bitmaps\GreenToRed.bmp")
.ListImages.Add Picture:=LoadPicture(App.Path & "\bitmaps\GreenToBlue.bmp")
End With
Debug.Assert iltColorRamp.ListImages.Count > 0
imgcboColorRamp.ImageList = iltColorRamp
End If
'暂时设提供三种选择色带
imgcboColorRamp.ComboItems.Add 1, , , 1
imgcboColorRamp.ComboItems.Add 2, , , 2
imgcboColorRamp.ComboItems.Add 3, , , 3
imgcboColorRamp.ComboItems.Add 4, , , 4
imgcboColorRamp.ComboItems.Add 5, , , 5
imgcboColorRamp.ComboItems.Add 6, , , 6
imgcboColorRamp.ComboItems(1).Selected = True
End Sub
'释放内存
Private Sub Form_Unload(cancel As Integer)
Set m_pSymbolsArray = Nothing
Set m_colValues = Nothing
Set m_colMapLayers = Nothing
End Sub
'消去色带焦点
Private Sub imgcboColorRamp_Click()
cmdOK.SetFocus
' '刷新（以后更改）
' cmdAddAllValues_Click
End Sub
'选择图层
Private Sub lstMapLayers_Click()
Debug.Assert Not m_pMap Is Nothing
If m_pMap Is Nothing Then Exit Sub
'得到图层
If lstMapLayers.Text = "" Then Exit Sub
Set m_pGeoFeatureLayer = GetFeatureLayer(lstMapLayers.Text, m_pMap)
Debug.Assert Not m_pGeoFeatureLayer Is Nothing
If m_pGeoFeatureLayer Is Nothing Then Exit Sub
If m_pGeoFeatureLayer.FeatureClass Is Nothing Then
Exit Sub
End If
'确定图层类型
m_strShapeType = GetLayerShapeType(m_pGeoFeatureLayer)
Debug.Assert Not m_strShapeType = ""
If m_strShapeType = "" Then Exit Sub
'设置字段
Dim pLayerFieldsArray As IArray
Debug.Assert Not lstMapLayers.Text = ""
If lstMapLayers.Text = "" Then Exit Sub
Set pLayerFieldsArray = GetLayerFields(m_pMap, lstMapLayers.Text)
Debug.Assert Not pLayerFieldsArray Is Nothing
If pLayerFieldsArray Is Nothing Then Exit Sub
cmbFields.Clear
Dim pField As IField
Dim i As Integer
For i = 0 To pLayerFieldsArray.Count - 1
Set pField = pLayerFieldsArray.Element(i)
If (Not pField.Name = "FID") And (Not pField.Name = "ID") And (pField.VarType = 2 Or pField.VarType = 3 Or pField.VarType = 4 Or pField.VarType = 5) Then
cmbFields.AddItem pField.Name
End If
Next i
If cmbFields.ListCount > 1 Then
cmbFields.ListIndex = 1
ElseIf cmbFields.ListCount = 1 Then
cmbFields.ListIndex = 0
End If
' '创建所有符号，显示之
' cmdAddAllValues_Click
End Sub
'创建所有符号，显示之
Private Sub cmdAddAllValues_Click()
If m_pGeoFeatureLayer Is Nothing Or m_pGeoFeatureLayer.FeatureClass Is Nothing Then Exit Sub
'得到图层
Dim pSym As IFillSymbol
Dim pColor As IColor
Dim pNextUniqueColor As IColor
Dim pEnumRamp As IEnumColors
Dim pTable As ITable
Dim fieldNumber As Long
Dim pNextRow As IRow
Dim pNextRowBuffer As IRowBuffer
Dim pCursor As ICursor
Dim pQueryFilter As IQueryFilter
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -