📄 frmdrawprops.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Object = "{9BD6A640-CE75-11D1-AF04-204C4F4F5020}#2.0#0"; "MO20.OCX"
Begin VB.Form frmDrawProps
Caption = "Drawing Properties"
ClientHeight = 6675
ClientLeft = 60
ClientTop = 345
ClientWidth = 6690
LinkTopic = "Form3"
ScaleHeight = 6675
ScaleWidth = 6690
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdOK
Caption = "OK"
Height = 375
Left = 1560
TabIndex = 13
Top = 6000
Width = 1215
End
Begin VB.CommandButton cmdCancel
Caption = "Cancel"
Height = 375
Left = 3840
TabIndex = 12
Top = 6000
Width = 1215
End
Begin VB.Frame TFrame
Height = 4095
Index = 1
Left = 120
TabIndex = 8
Top = 1560
Width = 6135
Begin MSFlexGridLib.MSFlexGrid grdValues
Height = 2415
Left = 2040
TabIndex = 11
Top = 1080
Width = 3735
_ExtentX = 6588
_ExtentY = 4260
_Version = 393216
BackColorFixed = -2147483637
BackColorSel = -2147483643
BackColorBkg = -2147483643
AllowBigSelection= 0 'False
HighLight = 0
GridLines = 2
GridLinesFixed = 1
AllowUserResizing= 1
End
Begin VB.ComboBox cboUnique
Height = 315
Left = 2880
Style = 2 'Dropdown List
TabIndex = 9
Top = 360
Width = 2895
End
Begin VB.Label Label4
Caption = "Field"
Height = 315
Left = 1680
TabIndex = 10
Top = 360
Width = 855
End
End
Begin VB.Frame TFrame
Height = 4095
Index = 0
Left = 120
TabIndex = 1
Top = 1560
Width = 6135
Begin VB.TextBox txtSize
Height = 375
Left = 3120
TabIndex = 7
Text = "Text1"
Top = 1860
Width = 735
End
Begin VB.ComboBox cboStyle
Height = 315
Left = 3120
TabIndex = 6
Text = "Combo1"
Top = 2640
Width = 2055
End
Begin VB.PictureBox pctColor
Height = 375
Left = 3120
ScaleHeight = 315
ScaleWidth = 675
TabIndex = 5
Top = 1080
Width = 735
End
Begin VB.Label Label3
Caption = "Style"
Height = 375
Left = 1440
TabIndex = 4
Top = 2640
Width = 735
End
Begin VB.Label Label2
Caption = "Size"
Height = 375
Left = 1440
TabIndex = 3
Top = 1860
Width = 735
End
Begin VB.Label Label1
Caption = "Color"
Height = 375
Left = 1440
TabIndex = 2
Top = 1080
Width = 735
End
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 480
Top = 5880
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin ComctlLib.TabStrip TabStrip1
Height = 5175
Left = 120
TabIndex = 0
Top = 720
Width = 6375
_ExtentX = 11245
_ExtentY = 9128
_Version = 327682
BeginProperty Tabs {0713E432-850A-101B-AFC0-4210102A8DA7}
NumTabs = 2
BeginProperty Tab1 {0713F341-850A-101B-AFC0-4210102A8DA7}
Caption = "Single Symbol"
Key = "SingleSymbol"
Object.Tag = ""
ImageVarType = 2
EndProperty
BeginProperty Tab2 {0713F341-850A-101B-AFC0-4210102A8DA7}
Caption = "Unique Value"
Key = "Unique"
Object.Tag = ""
ImageVarType = 2
EndProperty
EndProperty
End
Begin MapObjects2.Map MapDrawSymbol
Height = 315
Left = 480
TabIndex = 15
Top = 1200
Width = 870
_Version = 131072
_ExtentX = 1524
_ExtentY = 547
_StockProps = 225
BackColor = 16777215
BorderStyle = 1
Contents = "frmDrawProps.frx":0000
End
Begin VB.Label lblLayerName
BorderStyle = 1 'Fixed Single
Height = 375
Left = 3240
TabIndex = 14
Top = 120
Width = 2895
End
End
Attribute VB_Name = "frmDrawProps"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public curTab As Integer
Public vmr As New MapObjects2.ValueMapRenderer
Public tempSymbol As New MapObjects2.symbol
Public curDrawSymbol As New clsDrawSymbol
Public curFeatureType As Integer
Public curFeatureName As String
Dim tabUp As Boolean
Private Sub RestoreSingleValueMap()
With drawLayer
pctColor.BackColor = .symbol.Color
txtSize = .symbol.Size
cboStyle.Clear
Select Case .shapeType
Case moPoint
cboStyle.AddItem "Circle"
cboStyle.AddItem "Square"
cboStyle.AddItem "Triangle"
cboStyle.AddItem "Cross"
Case moLine
cboStyle.AddItem "Solid Line"
cboStyle.AddItem "Dash Line"
cboStyle.AddItem "Dot Line"
cboStyle.AddItem "Dash Dot"
cboStyle.AddItem "Dash Dot Dot"
Case moPolygon
Label2.Visible = False
txtSize.Visible = False
cboStyle.AddItem "Solid Fill"
cboStyle.AddItem "Transparent"
cboStyle.AddItem "Horizontal"
cboStyle.AddItem "Verical"
cboStyle.AddItem "Upward Diagonal"
cboStyle.AddItem "Downward Diagonal"
cboStyle.AddItem "Cross"
cboStyle.AddItem "Diagonal Cross"
End Select
cboStyle.ListIndex = .symbol.Style
End With
End Sub
Private Sub RestoreUniqueValueMap()
Dim recs As New MapObjects2.Recordset
Set recs = drawLayer.Records
Dim fld As MapObjects2.Field
cboUnique.Clear
cboUnique.AddItem "None"
cboUnique.ListIndex = 0
'the layer is not currently a unique value map
For Each fld In recs.Fields
If fld.Name <> "Shape" Then
If fld.Name <> "FeatureId" Then
cboUnique.AddItem fld.Name
End If
End If
Next
cboUnique.ListIndex = 0
End Sub
Private Sub cboUnique_Click()
Dim recs As New MapObjects2.Recordset
Dim uniquevals As New MapObjects2.Strings
Dim retval As Integer
Dim goOn As Boolean
Dim i As Integer
If tabUp Then
Exit Sub
End If
Const tpi = 1440 'Twips per inch
'Size the grid initially to 2 by 2 and grow as needed.
grdValues.Clear
grdValues.Cols = 2: grdValues.Rows = 2
'Position on first row and set first column settings
grdValues.Row = 0: grdValues.Col = 0
grdValues.ColWidth(0) = tpi * 1.3
grdValues.ColAlignment(0) = 1 'right align
grdValues.Text = "Value"
'Second column settings
grdValues.Col = 1
grdValues.ColWidth(1) = tpi * 0.6
grdValues.Text = "Symbol"
grdValues.FixedRows = 1: grdValues.FixedCols = 0
If cboUnique.List(cboUnique.ListIndex) <> "None" Then
'Load up the grid
Set recs = drawLayer.Records
recs.MoveFirst
goOn = False
Do While Not recs.EOF
uniquevals.Add recs(cboUnique.Text).Value
If uniquevals.Count > 25 And goOn = False Then
retval = MsgBox("There are more than 25 unique values. Continue?", vbYesNo)
If retval = vbNo Then
Exit Do
Else
goOn = True
End If
End If
recs.MoveNext
Loop
'have the list, build the grid
'Set drawLayer.Renderer = vmr
curFeatureType = drawLayer.shapeType
Select Case drawLayer.shapeType
Case moPoint
vmr.SymbolType = moPointSymbol
Case moLine
vmr.SymbolType = moLineSymbol
Case moPolygon
vmr.SymbolType = moFillSymbol
End Select
vmr.ValueCount = uniquevals.Count
vmr.Field = cboUnique.Text
'Add the values and pictures to the flex grid grdValues
For i = 0 To vmr.ValueCount - 1
grdValues.Row = i + 1
grdValues.Col = 0
grdValues.Text = uniquevals(i)
'go to second column
grdValues.Col = 1
vmr.Value(i) = uniquevals(i)
Set tempSymbol = vmr.symbol(i)
MapDrawSymbol.TrackingLayer.Refresh True
MapDrawSymbol.CopyMap 1
Set grdValues.CellPicture = Clipboard.GetData
grdValues.CellPictureAlignment = flexAlignCenterCenter
grdValues.Rows = grdValues.Rows + 1
Next
'Remove blank line at end
grdValues.Rows = grdValues.Rows - 1
grdValues.RowHeight(-1) = tpi * 0.25
End If
End Sub
Private Sub mapDrawSymbol_AfterTrackingLayerDraw(ByVal hDC As StdOle.OLE_HANDLE)
If cboUnique.ListIndex > 0 Then
Set curDrawSymbol.mapControl = Me.MapDrawSymbol
Set curDrawSymbol.symbol = tempSymbol
curDrawSymbol.Draw
End If
End Sub
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdOK_Click()
Select Case TabStrip1.SelectedItem.index
Case 1
Set drawLayer.Renderer = Nothing
drawLayer.Tag = ""
With drawLayer.symbol
.Color = pctColor.BackColor
.Style = cboStyle.ListIndex
If drawLayer.shapeType <> moPolygon Then
.Size = txtSize
End If
End With
Case 2
'Set drawLayer.Renderer = vmr
Dim rv As New MapObjects2.ValueMapRenderer
Set drawLayer.Renderer = rv
rv.Field = vmr.Field
rv.SymbolType = vmr.SymbolType
rv.ValueCount = vmr.ValueCount
Dim i As Integer
For i = 0 To vmr.ValueCount - 1
rv.Value(i) = vmr.Value(i)
rv.symbol(i).Color = vmr.symbol(i).Color
rv.symbol(i).Style = vmr.symbol(i).Style
rv.symbol(i).Size = vmr.symbol(i).Size
Next
drawLayer.Tag = "UniqueValue"
End Select
Form1.Map1.Refresh
Unload Me
End Sub
Private Sub Form_Load()
Dim i As Integer
lblLayerName = drawLayer.Name
'when first loaded into the map, all layers have a blank tag
If drawLayer.Tag = "" Then drawLayer.Tag = "SingleSymbol"
Select Case drawLayer.Tag
Case "SingleSymbol"
curTab = 1
RestoreSingleValueMap
Case "UniqueValue"
curTab = 2
RestoreUniqueValueMap
End Select
For i = 1 To TabStrip1.Tabs.Count
If curTab = i Then
TFrame(i - 1).Visible = True
Else
TFrame(i - 1).Visible = False
End If
Next
End Sub
Private Sub grdValues_Click()
If grdValues.Col = 0 Then
Exit Sub
End If
If grdValues.Row = 0 Then
Exit Sub
End If
Set tempSymbol = vmr.symbol(grdValues.Row - 1)
grdValues.Col = grdValues.Col - 1
curFeatureName = grdValues.Text
frmSymbol.Show vbModal
End Sub
Private Sub pctColor_Click()
Dim curcolor As Long
CommonDialog1.CancelError = True
On Error GoTo ErrHandler
CommonDialog1.ShowColor
curcolor = CommonDialog1.Color
pctColor.BackColor = curcolor
Exit Sub
ErrHandler:
'do nothing, just exit
Exit Sub
End Sub
Private Sub TabStrip1_Click()
Dim i As Integer
For i = 1 To TabStrip1.Tabs.Count
If TabStrip1.SelectedItem.index = i Then
TFrame(i - 1).Visible = True
Else
TFrame(i - 1).Visible = False
End If
Next
Select Case TabStrip1.SelectedItem.index
Case 1
RestoreSingleValueMap
Case 2
tabUp = True
RestoreUniqueValueMap
tabUp = False
End Select
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -