📄 drilldownsample.frm
字号:
End Select
ElseIf strLevel = "MultiRegion" Then
NewLevel = "States"
Select Case DelKeys(0)
Case "mrRgn1"
westLevel = westLevel + 5
ReDim AddKeys(4)
AddKeys(0) = "16"
AddKeys(1) = "30"
AddKeys(2) = "41"
AddKeys(3) = "53"
AddKeys(4) = "56"
Case "mrRgn2"
westLevel = westLevel + 6
ReDim AddKeys(5)
AddKeys(0) = "04"
AddKeys(1) = "06"
AddKeys(2) = "08"
AddKeys(3) = "32"
AddKeys(4) = "35"
AddKeys(5) = "49"
Case "mrRgn3"
westLevel = westLevel + 5
ReDim AddKeys(4)
AddKeys(0) = "19"
AddKeys(1) = "27"
AddKeys(2) = "31"
AddKeys(3) = "38"
AddKeys(4) = "46"
Case "mrRgn4"
westLevel = westLevel + 6
ReDim AddKeys(5)
AddKeys(0) = "48"
AddKeys(1) = "22"
AddKeys(2) = "05"
AddKeys(3) = "40"
AddKeys(4) = "20"
AddKeys(5) = "29"
Case "mrRgn5"
eastLevel = eastLevel + 5
ReDim AddKeys(4)
AddKeys(0) = "17"
AddKeys(1) = "55"
AddKeys(2) = "18"
AddKeys(3) = "26"
AddKeys(4) = "39"
Case "mrRgn6"
eastLevel = eastLevel + 9
ReDim AddKeys(8)
AddKeys(0) = "33"
AddKeys(1) = "09"
AddKeys(2) = "23"
AddKeys(3) = "25"
AddKeys(4) = "34"
AddKeys(5) = "36"
AddKeys(6) = "42"
AddKeys(7) = "44"
AddKeys(8) = "50"
Case "mrRgn7"
eastLevel = eastLevel + 8
ReDim AddKeys(7)
AddKeys(0) = "21"
AddKeys(1) = "37"
AddKeys(2) = "47"
AddKeys(3) = "51"
AddKeys(4) = "54"
AddKeys(5) = "10"
AddKeys(6) = "11"
AddKeys(7) = "24"
Case "mrRgn8"
eastLevel = eastLevel + 5
ReDim AddKeys(4)
AddKeys(0) = "28"
AddKeys(1) = "01"
AddKeys(2) = "12"
AddKeys(3) = "13"
AddKeys(4) = "45"
End Select
Else
MsgBox "Can't drilldown any further; Level: " + strLevel + " Key: " + DelKeys(0)
Exit Sub
End If
ElseIf fs.Count = 0 Then
MsgBox "No features selected."
Exit Sub
Else
MsgBox "More than one feature selected; can only drilldown on exactly one item."
Exit Sub
End If
drilldownLayer.DrillDownRemoveFeatures strLevel, DelKeys
drilldownLayer.DrillDownAddFeatures NewLevel, AddKeys
' ---------------------------------------------
' Contract
' ----------------------------------------------
ElseIf (ToolNum = customDrilldownContractTool And Ctrl = False) Or (ToolNum = customDrilldownExpandTool And Ctrl = True) Then
pnt.Set X1, Y1
Set fs = drilldownLayer.SearchAtPoint(pnt)
If fs.Count = 1 Then
ReDim DelKeys(0)
drilldownLayer.KeyField = "Level"
strLevel = fs(1).KeyValue
drilldownLayer.KeyField = "Key"
DelKeys(0) = fs(1).KeyValue
If strLevel = "States" Then
NewLevel = "MultiRegion"
Select Case DelKeys(0)
Case "16", "30", "41", "53", "56"
westLevel = westLevel - 5
ReDim DelKeys(4)
ReDim AddKeys(0)
AddKeys(0) = "mrRgn1"
DelKeys(0) = "16"
DelKeys(1) = "30"
DelKeys(2) = "41"
DelKeys(3) = "53"
DelKeys(4) = "56"
Case "04", "06", "08", "32", "35", "49"
westLevel = westLevel - 6
ReDim DelKeys(5)
ReDim AddKeys(0)
AddKeys(0) = "mrRgn2"
DelKeys(0) = "04"
DelKeys(1) = "06"
DelKeys(2) = "08"
DelKeys(3) = "32"
DelKeys(4) = "35"
DelKeys(5) = "49"
Case "19", "27", "31", "38", "46"
westLevel = westLevel - 5
ReDim DelKeys(4)
ReDim AddKeys(0)
AddKeys(0) = "mrRgn3"
DelKeys(0) = "19"
DelKeys(1) = "27"
DelKeys(2) = "31"
DelKeys(3) = "38"
DelKeys(4) = "46"
Case "48", "22", "05", "40", "20", "29"
westLevel = westLevel - 6
ReDim DelKeys(5)
ReDim AddKeys(0)
AddKeys(0) = "mrRgn4"
DelKeys(0) = "48"
DelKeys(1) = "22"
DelKeys(2) = "05"
DelKeys(3) = "40"
DelKeys(4) = "20"
DelKeys(5) = "29"
Case "17", "55", "18", "26", "39"
eastLevel = eastLevel - 5
ReDim DelKeys(4)
ReDim AddKeys(0)
AddKeys(0) = "mrRgn5"
DelKeys(0) = "17"
DelKeys(1) = "55"
DelKeys(2) = "18"
DelKeys(3) = "26"
DelKeys(4) = "39"
Case "33", "09", "23", "25", "34", "36", "42", "44", "50"
eastLevel = eastLevel - 9
ReDim DelKeys(8)
ReDim AddKeys(0)
AddKeys(0) = "mrRgn6"
DelKeys(0) = "33"
DelKeys(1) = "09"
DelKeys(2) = "23"
DelKeys(3) = "25"
DelKeys(4) = "34"
DelKeys(5) = "36"
DelKeys(6) = "42"
DelKeys(7) = "44"
DelKeys(8) = "50"
Case "21", "37", "47", "51", "54", "10", "11", "24"
eastLevel = eastLevel - 8
ReDim DelKeys(7)
ReDim AddKeys(0)
AddKeys(0) = "mrRgn7"
DelKeys(0) = "21"
DelKeys(1) = "37"
DelKeys(2) = "47"
DelKeys(3) = "51"
DelKeys(4) = "54"
DelKeys(5) = "10"
DelKeys(6) = "11"
DelKeys(7) = "24"
Case "28", "01", "12", "13", "45"
eastLevel = eastLevel - 5
ReDim DelKeys(4)
ReDim AddKeys(0)
AddKeys(0) = "mrRgn8"
DelKeys(0) = "28"
DelKeys(1) = "01"
DelKeys(2) = "12"
DelKeys(3) = "13"
DelKeys(4) = "45"
End Select
ElseIf strLevel = "MultiRegion" Then
NewLevel = "2Region"
Select Case DelKeys(0)
Case "mrRgn1", "mrRgn2", "mrRgn3", "mrRgn4"
If westLevel > 0 Then
MsgBox "Can't roll-up West region: there are still" & Str(westLevel) & " visible states in the West."
Exit Sub
End If
usaLevel = usaLevel - 1
ReDim DelKeys(3)
ReDim AddKeys(0)
AddKeys(0) = "West"
DelKeys(0) = "mrRgn1"
DelKeys(1) = "mrRgn2"
DelKeys(2) = "mrRgn3"
DelKeys(3) = "mrRgn4"
Case "mrRgn5", "mrRgn6", "mrRgn7", "mrRgn8"
If eastLevel > 0 Then
MsgBox "Can't roll-up East region: there are still" & Str(eastLevel) & " visible states in the East."
Exit Sub
End If
usaLevel = usaLevel - 1
ReDim DelKeys(3)
ReDim AddKeys(0)
AddKeys(0) = "East"
DelKeys(0) = "mrRgn5"
DelKeys(1) = "mrRgn6"
DelKeys(2) = "mrRgn7"
DelKeys(3) = "mrRgn8"
End Select
ElseIf strLevel = "2Region" Then
If usaLevel > 0 Or westLevel > 0 Or eastLevel > 0 Then
MsgBox "Can't roll-up to USA level: the lower levels are not fully rolled up."
Exit Sub
End If
NewLevel = "USA"
ReDim DelKeys(1)
ReDim AddKeys(0)
AddKeys(0) = "1"
DelKeys(0) = "West"
DelKeys(1) = "East"
Else
MsgBox "Can't contract any more; Level: " + strLevel + " Key: " + DelKeys(0)
Exit Sub
End If
ElseIf fs.Count = 0 Then
MsgBox "No features under cursor."
Exit Sub
Else
MsgBox "Multiple features under cursor; Can only Drilldown on one feature"
Exit Sub
End If
drilldownLayer.DrillDownRemoveFeatures strLevel, DelKeys
drilldownLayer.DrillDownAddFeatures NewLevel, AddKeys
End If
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As ComctlLib.Button)
Select Case Button.Index
Case 1
Map1.CurrentTool = miZoomInTool
Case 2
Map1.CurrentTool = miZoomOutTool
Case 3
Map1.CurrentTool = miPanTool
Case 4
Map1.CurrentTool = miSelectTool
Case 5
Map1.CurrentTool = miArrowTool
Case 6
Map1.CurrentTool = customDrilldownExpandTool
Case 7
Map1.CurrentTool = customDrilldownContractTool
End Select
End Sub
Private Sub Form_Resize()
If Me.ScaleWidth > 3975 And Me.ScaleHeight > 1455 Then
Map1.Width = Me.ScaleWidth
Map1.Height = Me.ScaleHeight - 1455
Frame1.Top = Me.ScaleHeight - Frame1.Height
Frame1.Left = Me.ScaleWidth - Frame1.Width
LayerControlBtn.Top = Me.ScaleHeight - 510
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -