VB-fun.de - 3D-Landkarten mit Regions (Tipp 0112)

Tipp 0112

3D-Landkarten mit Regions

Autor/Einsender:
Datum:

Kerry B. Rogers
16.08.2001

Entwicklungsumgebung:

VB 5

Dieses grafisch sehr schöne Beispiel zeigt auf, wie man z.B. auf Landkarten die einzelnen Regionen oder Landstriche separat hervorheben kann, indem die Grafiken "offscreen" (im Hintergrund) manipuliert werden, und dass Buttons/Regionen nicht unbedingt auf vier Ecken begrenzt sein müssen.

Code im Codebereich des Moduls

Option Explicit

Public Declare Function ExtFloodFill Lib "gdi32" (ByVal hdc _
      As Long, ByVal x As Long, ByVal y As Long, ByVal crColor _
      As Long, ByVal wFillType As Long) As Long

Public Declare Function GetPixel Lib "gdi32" (ByVal hdc _
      As Long, ByVal x As Long, ByVal y As Long) As Long

Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC _
      As Long, ByVal x As Long, ByVal y As Long, ByVal _
      nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC _
      As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
      ByVal dwRop As Long) As Long

Global gsStateName$()
Global giaX%(), giaY%()
Global gbMassUpdate%
Global giX&, giY&
Global Const DARK_GRAY = &H808080
Global Const LITE_GRAY = &HC0C0C0
Global Const SHOWN_MAP = 0
Global Const HIDDEN_MAP = 1
Global Const BACKUP_MAP = 2

Sub Main()
  Dim i%

  Screen.MousePointer = 11            'Hourglass

  ReDim gsStateName(0 To 60), giaX(0 To 60), giaY(0 To 60)

  gsStateName(0) = "Alabama": giaX(0) = 362: giaY(0) = 201
  gsStateName(1) = "Alaska": giaX(1) = 79: giaY(1) = 247
  gsStateName(2) = "Arizona": giaX(2) = 118: giaY(2) = 181
  gsStateName(3) = "Arkansas": giaX(3) = 304: giaY(3) = 187
  gsStateName(4) = "California": giaX(4) = 45: giaY(4) = 142
  gsStateName(5) = "Colorado": giaX(5) = 179: giaY(5) = 139
  gsStateName(6) = "Connecticut": giaX(6) = 468: giaY(6) = 83
  gsStateName(7) = _
          "D.C. (Washington)": giaX(7) = 484: giaY(7) = 143
  gsStateName(8) = "Delaware": giaX(8) = 454: giaY(8) = 119
  gsStateName(9) = "Florida": giaX(9) = 425: giaY(9) = 247
  gsStateName(10) = "Georgia": giaX(10) = 393: giaY(10) = 195
  gsStateName(11) = "Hawaii": giaX(11) = 146: giaY(11) = 280
  gsStateName(12) = "Idaho": giaX(12) = 105: giaY(12) = 74
  gsStateName(13) = "Illinois": giaX(13) = 328: giaY(13) = 124
  gsStateName(14) = "Indiana": giaX(14) = 355: giaY(14) = 123
  gsStateName(15) = "Iowa": giaX(15) = 289: giaY(15) = 105
  gsStateName(16) = "Kansas": giaX(16) = 245: giaY(16) = 145
  gsStateName(17) = "Kentucky": giaX(17) = 375: giaY(17) = 149
  gsStateName(18) = "Louisiana": giaX(18) = 306: giaY(18) = 224
  gsStateName(19) = "Maine": giaX(19) = 485: giaY(19) = 36
  gsStateName(20) = "Maryland": giaX(20) = 438: giaY(20) = 119
  gsStateName(21) = "Massachusettes": giaX(21) = 468: giaY(21) = 76
  gsStateName(22) = "Michigan": giaX(22) = 361: giaY(22) = 86
  gsStateName(23) = "Minnesota": giaX(23) = 276: giaY(23) = 60
  gsStateName(24) = "Mississippi": giaX(24) = 334: giaY(24) = 207
  gsStateName(25) = "Missouri": giaX(25) = 299: giaY(25) = 145
  gsStateName(26) = "Montana": giaX(26) = 155: giaY(26) = 48
  gsStateName(27) = "Nebraska": giaX(27) = 235: giaY(27) = 114
  gsStateName(28) = "Nevada": giaX(28) = 78: giaY(28) = 125
  gsStateName(29) = "New Hampshire": giaX(29) = 472: giaY(29) = 63
  gsStateName(30) = "New Jersey": giaX(30) = 457: giaY(30) = 109
  gsStateName(31) = "New Mexico": giaX(31) = 171: giaY(31) = 190
  gsStateName(32) = "New York": giaX(32) = 447: giaY(32) = 73
  gsStateName(33) = _
          "North Carolina": giaX(33) = 431: giaY(33) = 161
  gsStateName(34) = "North Dakota": giaX(34) = 228: giaY(34) = 47
  gsStateName(35) = "Ohio": giaX(35) = 384: giaY(35) = 116
  gsStateName(36) = "Oklahoma": giaX(36) = 255: giaY(36) = 181
  gsStateName(37) = "Oregon": giaX(37) = 58: giaY(37) = 68
  gsStateName(38) = "Pensylvania": giaX(38) = 427: giaY(38) = 101
  gsStateName(39) = "Rhode Island": giaX(39) = 478: giaY(39) = 80
  gsStateName(40) = _
          "South Carolina": giaX(40) = 417: giaY(40) = 182
  gsStateName(41) = "South Dakota": giaX(41) = 229: giaY(41) = 80
  gsStateName(42) = "Tennessee": giaX(42) = 364: giaY(42) = 170
  gsStateName(43) = "Texas": giaX(43) = 240: giaY(43) = 227
  gsStateName(44) = "Utah": giaX(44) = 125: giaY(44) = 131
  gsStateName(45) = "Vermont": giaX(45) = 462: giaY(45) = 57
  gsStateName(46) = "Virginia": giaX(46) = 430: giaY(46) = 139
  gsStateName(47) = "Washington": giaX(47) = 72: giaY(47) = 32
  gsStateName(48) = _
          "West Virginia": giaX(48) = 407: giaY(48) = 134
  gsStateName(48) = "West Virginia": giaX(48) = 407: giaY(48) = 134
  gsStateName(49) = "Wisconsin": giaX(49) = 319: giaY(49) = 78
  gsStateName(50) = "Wyoming": giaX(50) = 166: giaY(50) = 94
  gsStateName(51) = "Alaska": giaX(51) = 47: giaY(51) = 272
  gsStateName(52) = "Alaska": giaX(52) = 40: giaY(52) = 273
  gsStateName(53) = "Alaska": giaX(53) = 35: giaY(53) = 270
  gsStateName(54) = "Alaska": giaX(54) = 29: giaY(54) = 268
  gsStateName(55) = _
          "D.C. (Washington)": giaX(55) = 479: giaY(55) = 146
  gsStateName(56) = "Hawaii": giaX(56) = 139: giaY(56) = 274
  gsStateName(57) = "Hawaii": giaX(57) = 132: giaY(57) = 270
  gsStateName(58) = "Hawaii": giaX(58) = 124: giaY(58) = 266
  gsStateName(59) = "Hawaii": giaX(59) = 115: giaY(59) = 268
  gsStateName(60) = "Michigan": giaX(60) = 339: giaY(60) = 59

  frmMapMain.Show
  Screen.MousePointer = 0
End Sub

Code im Codebereich der Form

Option Explicit

Private Sub Form_Load()
  Dim i%

  For i = 0 To 50
    lstStates.AddItem gsStateName(i)
  Next i
End Sub

Private Sub cmdSelectAll_Click()
  Dim i%

  lstStates.Visible = False
  gbMassUpdate = True

  For i% = 0 To lstStates.ListCount - 1
    lstStates.Selected(i) = True
  Next i

  gbMassUpdate = False
  lstStates.Visible = True
  PaintShownMapFromList
End Sub

Private Sub cmdClearAll_Click()
  Dim i%

  lstStates.Visible = False
  gbMassUpdate = True

  For i% = 0 To lstStates.ListCount - 1
    lstStates.Selected(i) = False
  Next i

  gbMassUpdate = False
  lstStates.Visible = True
  UpdateThe SHOWN_MAP, BACKUP_MAP
  picShown.Refresh
End Sub

Private Sub lstStates_Click()
  If gbMassUpdate Then Exit Sub
  UpdateThe HIDDEN_MAP, BACKUP_MAP
  PaintShownMapFromList
End Sub

Private Function MapStateClicked%()
  Dim i%

  For i = 0 To 60
    If GetPixel(picHidden.hdc, giaX(i), giaY(i)) = _
        DARK_GRAY Then Exit For
  Next i

  Select Case i
    Case 1, 51 To 54
       i = 1
    Case 7, 55
       i = 7
    Case 11, 56 To 59
       i = 11
    Case 22, 60
       i = 22
  End Select
  MapStateClicked = i
End Function

Private Sub ClearState()
  Dim i&

  UpdateThe HIDDEN_MAP, BACKUP_MAP
  PaintSpot
  lstStates.Selected((MapStateClicked())) = False
  PaintShownMapFromList
End Sub

Private Sub PaintShownMapFromList()
  Dim i%

  UpdateThe HIDDEN_MAP, BACKUP_MAP
  For i = 0 To lstStates.ListCount - 1
    If lstStates.Selected(i) Then
      Select Case i
        Case 1, 51 To 54
          giX = 79: giY = 247: PaintSpot
          giX = 47: giY = 273: PaintSpot
          giX = 41: giY = 273: PaintSpot
          giX = 35: giY = 270: PaintSpot
          giX = 29: giY = 268: PaintSpot
        Case 7, 55
          giX = 484: giY = 143: PaintSpot
          giX = 479: giY = 146: PaintSpot
        Case 11, 56 To 59
          giX = 146: giY = 280: PaintSpot
          giX = 139: giY = 274: PaintSpot
          giX = 132: giY = 270: PaintSpot
          giX = 124: giY = 266: PaintSpot
          giX = 115: giY = 268: PaintSpot
        Case 22, 60
          giX = 361: giY = 86: PaintSpot
          giX = 339: giY = 59: PaintSpot
        Case Else
          giX = giaX(i): giY = giaY(i): PaintSpot
      End Select
    End If
  Next i

  UpdateThe SHOWN_MAP, HIDDEN_MAP
  picShown.Refresh
End Sub

Private Sub PaintSpot()
  Dim iRet%, lStopColor&, iFillType%

  lStopColor = RGB(0, 0, 0)
  iFillType = 0
  picHidden.FillColor = &H808080
  iRet = ExtFloodFill _
         (picHidden.hdc, giX, giY, lStopColor, iFillType)
End Sub

Private Sub PaintState()
  Dim i%

  gbMassUpdate = True
  UpdateThe HIDDEN_MAP, BACKUP_MAP
  PaintSpot
  i = MapStateClicked()

  If lstStates.MultiSelect > 0 Then
    UpdateThe HIDDEN_MAP, SHOWN_MAP
  End If

  Select Case i
    Case 1, 51 To 54
      giX = 79: giY = 247: PaintSpot
      giX = 47: giY = 273: PaintSpot
      giX = 41: giY = 273: PaintSpot
      giX = 35: giY = 270: PaintSpot
      giX = 29: giY = 268: PaintSpot
    Case 7, 55
      giX = 484: giY = 143: PaintSpot
      giX = 479: giY = 146: PaintSpot
    Case 11, 56 To 59
      giX = 146: giY = 280: PaintSpot
      giX = 139: giY = 274: PaintSpot
      giX = 132: giY = 270: PaintSpot
      giX = 124: giY = 266: PaintSpot
      giX = 115: giY = 268: PaintSpot
    Case 22, 60
      giX = 361: giY = 86: PaintSpot
      giX = 339: giY = 59: PaintSpot
    Case Else
      giX = giaX(i): giY = giaY(i): PaintSpot
  End Select

  lstStates.Selected(i) = True
  gbMassUpdate = False
  UpdateThe SHOWN_MAP, HIDDEN_MAP
  picShown.Refresh
End Sub

Private Sub picHidden_MouseDown(Button As Integer, Shift _
      As Integer, x As Single, y As Single)
  Dim i%, lStopColor&, iFillType%, iRet%, iLi%, iX&, iY&

  iX = CInt(x)
  iY = CInt(y)
  giX = iX
  giY = iY

  Select Case GetPixel(picHidden.hdc, iX, iY)
    Case LITE_GRAY
      PaintState
    Case DARK_GRAY
      ClearState
  End Select
End Sub

Private Sub picShown_MouseDown(Button As Integer, Shift _
      As Integer, x As Single, y As Single)
  picHidden_MouseDown Button, Shift, x, y
End Sub

Private Sub UpdateThe(iDest&, iSrc&)
  Dim hDestDC&, iDestX&, iDestY&, iWidth&, iHeight&
  Dim hSrcDC&, iXSrc&, iYSrc&, lRasterOp&, iRet&

  Select Case iDest
    Case 0: hDestDC = picShown.hdc
    Case 1: hDestDC = picHidden.hdc
    Case 2: hDestDC = picBackup.hdc
  End Select

  iDestX = 0
  iDestY = 0
  iWidth = picShown.ScaleWidth
  iHeight = picShown.ScaleHeight

  Select Case iSrc
    Case 0: hSrcDC = picShown.hdc
    Case 1: hSrcDC = picHidden.hdc
    Case 2: hSrcDC = picBackup.hdc
  End Select

  iXSrc = 0
  iYSrc = 0
  lRasterOp = &HCC0020
  iRet = BitBlt(hDestDC, iDestX, iDestY, iWidth, iHeight, hSrcDC, _
                iXSrc, iYSrc, lRasterOp)
End Sub

Weitere Links zum Thema

Bereiche mit Farbe ausfüllen

Windows-Version

98/SE

2000

Vista

Win 7

VB-Version

VBA 5

VBA 6

VB 4/16

VB 4/32

VB 5

VB 6

Download (43 kB)

Downloads bisher: [ 5394 ]

Vorheriger Tipp

Zum Seitenanfang

Nächster Tipp

Startseite \| Projekte \| Tutorials \| API-Referenz \| VB-/VBA-Tipps \| Komponenten \| Bücherecke \| VB/VBA-Forum \| VB.Net-Forum \| DirectX-Forum \| Foren-Archiv \| DirectX \| VB.Net-Tipps \| Chat \| Spielplatz \| Links \| Suchen \| Stichwortverzeichnis \| Feedback \| Impressum

Seite empfehlen	Bug-Report

Letzte Aktualisierung: Dienstag, 9. August 2011