📄 drilldownsample.vb
字号:
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 (eventArgs.toolNum = customDrilldownContractTool And eventArgs.ctrl = False) Or (eventArgs.toolNum = customDrilldownExpandTool And eventArgs.ctrl = True) Then
pnt.Set(eventArgs.x1, eventArgs.y1)
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 eventSender As System.Object, ByVal eventArgs As AxComctlLib.IToolbarEvents_ButtonClickEvent) Handles Toolbar1.ButtonClick
Select Case eventArgs.button.Index
Case 1
Map1.CurrentTool = MapXLib.ToolConstants.miZoomInTool
Case 2
Map1.CurrentTool = MapXLib.ToolConstants.miZoomOutTool
Case 3
Map1.CurrentTool = MapXLib.ToolConstants.miPanTool
Case 4
Map1.CurrentTool = MapXLib.ToolConstants.miSelectTool
Case 5
Map1.CurrentTool = MapXLib.ToolConstants.miArrowTool
Case 6
Map1.CurrentTool = customDrilldownExpandTool
Case 7
Map1.CurrentTool = customDrilldownContractTool
End Select
End Sub
Private Sub DrilldownMap_Resize(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles MyBase.Resize
If VB6.PixelsToTwipsX(Me.ClientRectangle.Width) > 3975 And VB6.PixelsToTwipsY(Me.ClientRectangle.Height) > 1455 Then
Map1.Width = Me.ClientRectangle.Width
Map1.Height = VB6.TwipsToPixelsY(VB6.PixelsToTwipsY(Me.ClientRectangle.Height) - 1455)
Frame1.Top = VB6.TwipsToPixelsY(VB6.PixelsToTwipsY(Me.ClientRectangle.Height) - VB6.PixelsToTwipsY(Frame1.Height))
Frame1.Left = VB6.TwipsToPixelsX(VB6.PixelsToTwipsX(Me.ClientRectangle.Width) - VB6.PixelsToTwipsX(Frame1.Width))
LayerControlBtn.Top = VB6.TwipsToPixelsY(VB6.PixelsToTwipsY(Me.ClientRectangle.Height) - 510)
End If
End Sub
End Class⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -