mainform.frm

GIS地理信息系统开发。大名鼎鼎的MAPX＋VisualBasic6.0软件开发

      annot.Graphic.Style.TextFontDblSpace = mapxMap.DefaultStyle.TextFontDblSpace
      annot.Graphic.Style.TextFontHalo = mapxMap.DefaultStyle.TextFontHalo
      annot.Graphic.Style.TextFontOpaque = mapxMap.DefaultStyle.TextFontOpaque
      annot.Graphic.Style.TextFontShadow = mapxMap.DefaultStyle.TextFontShadow
    End If
  Next
End Sub

Private Sub Form_Activate()
  Dim popTheme As MapXLib.Theme, i As Integer

  If bActivateSet Then
    Exit Sub
  End If

  Set HubsDB = Workspaces(0).OpenDatabase(App.Path & "\hubplace.mdb")
  
  HubsDB.Execute "Delete * from ztHubs"
  HubsDB.Execute "Insert Into ztHubs Select * From Hubs"

  mapxMap.Layers("US Major Cities").Visible = True
  mapxMap.Layers("US Cities").Visible = False
  mapxMap.Layers("US Highways").Visible = True
  mapxMap.Layers("USA").Visible = True

  mapxMap.DataSets.Add miDataSetDAO, HubsDB.TableDefs("custs").OpenRecordset.Clone, "Customers"
  Set popTheme = mapxMap.DataSets("Customers").Themes.Add(miThemeDotDensity, 3, "Population")
  popTheme.Properties.DotSize = miDotSizeLarge
  popTheme.Properties.ValuePerDot = 100000
  popTheme.Legend.Compact = False
  popTheme.Legend.TitleStyle.TextFont.Size = 10
  popTheme.Legend.SubTitleStyle.TextFont.Size = 8
  popTheme.Legend.BodyTextStyle.TextFont.Size = 8
  popTheme.Legend.SubTitle = "by large cities population"
  popTheme.Legend.left = mapxMap.MapScreenWidth - mapxMap.DataSets(1).Themes(1).Legend.Width - 10
  popTheme.Legend.top = mapxMap.MapScreenHeight - mapxMap.DataSets(1).Themes(1).Legend.Height - 10
  
  Set hubTheme = mapxMap.DataSets("Customers").Themes.Add(miThemeGradSymbol, 3, "HubLegend")
  Set hubLegend = hubTheme.Legend
  hubLegend.Compact = False
  hubTheme.Visible = False
  hubLegend.Title = "Hubs Legend"
  hubLegend.LegendTexts.AutoGenerate = False
  For i = 1 To hubLegend.LegendTexts.Count
    hubLegend.LegendTexts(i).Text = "Hub symbol"
  Next

  mapxMap.CreateCustomTool 1, miToolTypePoint, miCrossCursor
  
  mapxMap.DefaultStyle.SymbolFont.Name = "Map Symbols"
  mapxMap.DefaultStyle.SymbolFont.Size = 48
  mapxMap.DefaultStyle.SymbolFontColor = vbMagenta
  mapxMap.DefaultStyle.SymbolCharacter = 35
  mapxMap.DefaultStyle.TextFontColor = vbBlue
  mapxMap.DefaultStyle.TextFontBackColor = vbYellow
  mapxMap.DefaultStyle.TextFont.Bold = True
  mapxMap.DefaultStyle.TextFontOpaque = True

  ckHighways.Value = 1
  ckCities.Value = 1

  ShowHubs
  iHubs = GetHubsCount()
  MakeHubsLegendStyle
  hubLegend.SubTitle = iHubs & " Hubs"
  hubLegend.left = 2150
  hubLegend.top = 3915

  MakeDefaultMapView
  mapxMap.Title.Caption = "US Hub Sites"
  mapxMap.Title.Visible = True
  mapxMap.CenterX = -95
  mapxMap.CenterY = 38

  bActivateSet = True
End Sub

Private Sub Form_Load()
  bActivateSet = False
'  DBCust.Columns.Add 2
'  DBCust.Columns(2).DataField = "POPULATION"
'  DBCust.Columns(2).Caption = "CUSTOMERS"
'  DBCust.Columns(2).Visible = True
'  DBCust.Columns(1).Width = 700
'  DBCust.Columns(2).Width = 1500
End Sub

Sub ShowHubs()

  mapxMap.AutoRedraw = False
  mapxMap.DefaultStyle.SymbolFont.Name = "Map Symbols"
  mapxMap.DefaultStyle.SymbolFont.Size = 12
  Set rsCustomers = HubsDB.TableDefs!custs.OpenRecordset
  Set rsHubs = HubsDB.TableDefs!ztHubs.OpenRecordset
  If rsHubs.EOF And rsHubs.BOF Then
    Exit Sub
  End If
  rsHubs.MoveFirst
  Do
    mapxMap.Annotations.AddSymbol rsHubs!X, rsHubs!Y
    rsHubs.MoveNext
  Loop While Not rsHubs.EOF
  mapxMap.AutoRedraw = True
End Sub

Private Sub mapxMap_AnnotationChanged(ByVal ChangeType As Integer, ByVal Annotation As Object, EnableDefault As Boolean)
  If ChangeType = miDeleteAnnotation And Annotation.Type = miSymbolAnnotation Then
    iHubs = iHubs - 1
    hubLegend.SubTitle = iHubs & " Hubs"
  End If
End Sub

Private Sub mapxMap_ToolUsed(ByVal ToolNum As Integer, ByVal x1 As Double, ByVal y1 As Double, ByVal x2 As Double, ByVal y2 As Double, ByVal Distance As Double, ByVal Shift As Boolean, ByVal Ctrl As Boolean, EnableDefault As Boolean)
  If ToolNum = 1 Then ' new hub
    AddHub x1, y1
    iHubs = iHubs + 1
    hubLegend.SubTitle = iHubs & " Hubs"
  End If
End Sub

Sub AddHub(ByVal X As Double, ByVal Y As Double)
  mapxMap.Annotations.AddSymbol X, Y
End Sub

Sub RecalcClosestCustomers()
  Dim s1 As String, s2 As String

  UpdateClosestCustomers
  mapxMap.AutoRedraw = False
  DeleteTextAnnotations
  
  rsHubs.MoveFirst
  Do
    s1 = Format(rsHubs!Closest, "#,#")
    s2 = Format(rsHubs!NumCust, "#,#")
    If s1 <> "" And s2 <> "" Then
      mapxMap.Annotations.AddText s1 & " / " & s2, rsHubs!X, rsHubs!Y, miPositionBL
    End If
    rsHubs.MoveNext
  Loop While Not rsHubs.EOF
  mapxMap.AutoRedraw = True
End Sub

Sub UpdateClosestCustomers()
  Dim cx As Double, cy As Double, bi As Variant, dDist As Double, dDist2 As Double

  StoreHubPlacement
  rsCustomers.MoveFirst
  Do
    cx = rsCustomers!X
    cy = rsCustomers!Y
    rsHubs.MoveFirst
    dDist = mapxMap.Distance(rsHubs!X, rsHubs!Y, cx, cy)
    bi = rsHubs.Bookmark
    Do
      dDist2 = mapxMap.Distance(rsHubs!X, rsHubs!Y, cx, cy)
      If dDist2 < dDist Then
        dDist = dDist2
        bi = rsHubs.Bookmark
      End If
      rsHubs.MoveNext
    Loop While Not rsHubs.EOF
    rsHubs.Bookmark = bi
    rsHubs.Edit
    rsHubs!Closest = rsHubs!Closest + 1
    rsHubs!NumCust = rsHubs!NumCust + rsCustomers!Population
    rsHubs.Update
    rsHubs.Bookmark = bi
    bi = rsCustomers.Bookmark
    rsCustomers.Edit
    rsCustomers!HubId = rsHubs!HubId
    rsCustomers.Update
    rsCustomers.Bookmark = bi
    rsCustomers.MoveNext
  Loop While Not rsCustomers.EOF
End Sub

Sub UpdateOwrCust()
  Dim bi As Variant, cx As Double, cy As Double, rs As Recordset, rsTotal As Recordset

  Set rs = rsHubs.OpenRecordset(dbOpenDynaset)
  Set rsTotal = HubsDB.QueryDefs!qryTotal.OpenRecordset(dbOpenDynaset)
  rsCustomers.MoveFirst
  Do
    bi = rsCustomers.Bookmark
    cx = rsCustomers!X
    cy = rsCustomers!Y
    If Not IsNull(rsCustomers!HubId) Then
      rs.FindFirst "HubId=" & rsCustomers!HubId
    Else
      GoTo NextCust
    End If
    rsCustomers.Edit
    rsTotal.FindFirst "STATE='" & rsCustomers!State & "'"
    If rs.NoMatch Then
      rsCustomers!OwrCust = 0
    Else
      rsCustomers!OwrCust = (rsCustomers!Population / mapxMap.Distance(cx, cy, rs!X, rs!Y)) / rsTotal!Popul
    End If
    rsCustomers.Update
    rsCustomers.Bookmark = bi
NextCust:
    rsCustomers.MoveNext
  Loop While Not rsCustomers.EOF
  rs.Close
  rsTotal.Close
End Sub

Sub DeleteTextAnnotations()
  Dim i As Integer

  i = 1
  Do While i <= mapxMap.Annotations.Count
    If mapxMap.Annotations(i).Type = miTextAnnotation Then
      mapxMap.Annotations.Remove i
    Else
      i = i + 1
    End If
  Loop
End Sub

Sub ShowSalesForecast()
  Dim bNoTheme As Boolean, bVisible As Boolean, LegTexts As New MapXLib.LegendTexts
  Dim tLegend As MapXLib.Legend, bHubLegendVisible As Boolean

  mapxMap.AutoRedraw = False
  StoreHubPlacement
  
  bHubLegendVisible = hubLegend.Visible
  
  UpdateClosestCustomers
  UpdateOwrCust
  mapxMap.DataSets("Customers").Refresh
  On Error GoTo NoTheme
  bNoTheme = False
  bVisible = mapxMap.DataSets("Customers").Themes("Sales").Visible
  On Error GoTo 0
  If bNoTheme Then
    mapxMap.DataSets("Customers").Themes.Add miThemeRanged, 7, "Sales"
'    mapxMap.Datasets("Customers").Themes("Sales").Properties.DistMethod = miEqualRangeSize
  End If
  mapxMap.DataSets("Customers").Themes("Sales").Visible = True
  Set tLegend = mapxMap.DataSets("Customers").Themes("Sales").Legend
  If bNoTheme Then
    tLegend.left = 0
    tLegend.top = mapxMap.MapScreenHeight - tLegend.Height - 10
  End If
  tLegend.BodyTextStyle.TextFont.Size = 8
  Set LegTexts = tLegend.LegendTexts
  tLegend.Visible = True
  If LegTexts(1).Text <> "Very Low" Then
    LegTexts(1).Text = "Very Low"
    LegTexts(2).Text = "Low"
    LegTexts(3).Text = "Medium"
    LegTexts(4).Text = "Good"
    LegTexts(5).Text = "Excellent"
  End If
  tLegend.Compact = False
  hubLegend.Visible = bHubLegendVisible
  mapxMap.AutoRedraw = True
  Exit Sub
NoTheme:
  bNoTheme = True
  Resume Next
End Sub

Sub StoreHubPlacement()
  Dim AnnotNum As Integer, i As Integer

  HubsDB.Execute "Delete * From ztHubs"
  AnnotNum = mapxMap.Annotations.Count
  
  For i = 1 To AnnotNum
    If mapxMap.Annotations(i).Type = miSymbolAnnotation Then
      rsHubs.AddNew
      rsHubs!X = mapxMap.Annotations(i).Graphic.X
      rsHubs!Y = mapxMap.Annotations(i).Graphic.Y
      rsHubs.Update
    End If
  Next
End Sub

Private Function GetHubsCount()
  Dim iCnt As Integer

  If rsHubs.BOF And rsHubs.EOF Then
    GetHubsCount = 0
    Exit Function
  End If
  rsHubs.MoveFirst
  iCnt = 0
  Do
    rsHubs.MoveNext
    iCnt = iCnt + 1
  Loop While Not rsHubs.EOF
  GetHubsCount = iCnt
End Function

Private Sub MakeDefaultMapView()
  mapxMap.MapUnit = miUnitMile
  mapxMap.CenterY = 33.63
  mapxMap.ZoomTo 3200, -98.8, 33.63
End Sub

Private Sub tlbMapTools_ButtonClick(ByVal Button As Button)
  Dim btn As Button

  Select Case Button.Index
    Case 1 ' select
      mapxMap.CurrentTool = miArrowTool
    Case 2 ' pan
      mapxMap.CurrentTool = miPanTool
    Case 3 ' zoom in
      mapxMap.CurrentTool = miZoomInTool
    Case 4 ' zoom out
      mapxMap.CurrentTool = miZoomOutTool
    Case 5 ' center
      mapxMap.CurrentTool = miCenterTool
    Case 7 ' symbol style
      ChooseSymbolStyle
    Case 8 ' text style
      ChooseTextStyle
  End Select
  If Button.Style = tbrCheck Then
    For Each btn In tlbMapTools.Buttons
      If btn.Style = tbrCheck Then
        If btn.Index = Button.Index Then
          btn.Value = 1
        Else
          btn.Value = 0
        End If
      End If
    Next
  End If
End Sub

Private Sub MakeHubsLegendStyle()
 ' Set hubTheme.Properties.SymbolStyle.SymbolFont = mapxMap.DefaultStyle.SymbolFont
  hubTheme.Properties.SymbolStyle.SymbolFont = mapxMap.DefaultStyle.SymbolFont
  hubTheme.Properties.SymbolStyle.SymbolCharacter = mapxMap.DefaultStyle.SymbolCharacter
  hubTheme.Properties.SymbolStyle.SymbolFontBackColor = mapxMap.DefaultStyle.SymbolFontBackColor
  hubTheme.Properties.SymbolStyle.SymbolFontColor = mapxMap.DefaultStyle.SymbolFontColor
  hubTheme.Properties.SymbolStyle.SymbolFontHalo = mapxMap.DefaultStyle.SymbolFontHalo
  hubTheme.Properties.SymbolStyle.SymbolFontOpaque = mapxMap.DefaultStyle.SymbolFontOpaque
  hubTheme.Properties.SymbolStyle.SymbolFontShadow = mapxMap.DefaultStyle.SymbolFontShadow
  hubLegend.Visible = True
End Sub