addtheme.frm

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

VERSION 5.00
Begin VB.Form AddTheme 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Add Theme"
   ClientHeight    =   3840
   ClientLeft      =   1470
   ClientTop       =   3060
   ClientWidth     =   6105
   Icon            =   "AddTheme.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   3840
   ScaleWidth      =   6105
   ShowInTaskbar   =   0   'False
   Begin VB.CommandButton cmdLegend 
      Caption         =   "&Legend..."
      Height          =   315
      Left            =   4740
      TabIndex        =   7
      Top             =   1500
      Width           =   1215
   End
   Begin VB.ListBox lstFields 
      Height          =   1620
      Left            =   180
      MultiSelect     =   2  'Extended
      TabIndex        =   6
      Top             =   1500
      Width           =   4395
   End
   Begin VB.TextBox txtThemeName 
      Height          =   315
      Left            =   1260
      TabIndex        =   9
      Top             =   3360
      Width           =   3315
   End
   Begin VB.CommandButton cmdAdd 
      Caption         =   "&Add"
      Default         =   -1  'True
      Enabled         =   0   'False
      Height          =   375
      Left            =   4740
      TabIndex        =   11
      Top             =   3300
      Width           =   1215
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "&Cancel"
      Height          =   375
      Left            =   4740
      TabIndex        =   10
      Top             =   2880
      Width           =   1215
   End
   Begin VB.CommandButton cmdOptions 
      Caption         =   "&Options..."
      Height          =   315
      Left            =   4740
      TabIndex        =   4
      Top             =   660
      Width           =   1215
   End
   Begin VB.ComboBox cmbThemeType 
      Height          =   315
      ItemData        =   "AddTheme.frx":000C
      Left            =   1380
      List            =   "AddTheme.frx":0025
      Style           =   2  'Dropdown List
      TabIndex        =   3
      Top             =   660
      Width           =   3195
   End
   Begin VB.ComboBox cmbDataset 
      Height          =   315
      ItemData        =   "AddTheme.frx":0081
      Left            =   1380
      List            =   "AddTheme.frx":0083
      Style           =   2  'Dropdown List
      TabIndex        =   1
      Top             =   180
      Width           =   4575
   End
   Begin VB.Label lblFields 
      Caption         =   "&Pick up fields:"
      Height          =   255
      Left            =   180
      TabIndex        =   5
      Top             =   1200
      Width           =   1155
   End
   Begin VB.Label lblThemeName 
      Caption         =   "Theme &name:"
      Height          =   255
      Left            =   180
      TabIndex        =   8
      Top             =   3420
      Width           =   1035
   End
   Begin VB.Label lblThemeType 
      Caption         =   "&Theme type:"
      Height          =   255
      Left            =   180
      TabIndex        =   2
      Top             =   720
      Width           =   1155
   End
   Begin VB.Label lblDataset 
      Caption         =   "&Dataset name:"
      Height          =   255
      Left            =   180
      TabIndex        =   0
      Top             =   240
      Width           =   1155
   End
End
Attribute VB_Name = "AddTheme"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' This sample application and corresponding sample code is provided
' for example purposes only.  It has not undergone rigorous testing
' and as such should not be shipped as part of a final application
' without extensive testing on the part of the organization releasing
' the end-user product.

Dim gMap As Map

Public Sub Activate(MapXMap As Map)
  Set gMap = MapXMap
  InitDataSets
  RangeOptions.bOptionsSet = False
  BarOptions.bOptionsSet = False
  PieOptions.bOptionsSet = False
  GradOptions.bOptionsSet = False
  DotOptions.bOptionsSet = False
  RangeOptions.bVisible = True
  BarOptions.bVisible = True
  PieOptions.bVisible = True
  GradOptions.bVisible = True
  DotOptions.bVisible = True
  LegendStyle.bLegendSet = False
  If cmbDataset.ListCount = 0 Then
    Exit Sub
  End If
  txtThemeName = ""
  FormToCenter AddTheme.hWnd
  Show 1
End Sub

Private Sub FillFields(ByVal DatasetInd As Integer)
  Dim i As Integer
  
  lstFields.Clear
  For i = 1 To gMap.Datasets(DatasetInd + 1).Fields.Count
    lstFields.AddItem gMap.Datasets(DatasetInd + 1).Fields(i).Name
  Next
End Sub

Private Sub InitDataSets()
  Dim i As Integer

  cmbDataset.Clear
  If gMap.Datasets.Count = 0 Then
    i = MsgBox("There are no datasets.", vbOKOnly, "Add Theme")
    Exit Sub
  End If
  For i = 1 To gMap.Datasets.Count
    cmbDataset.AddItem gMap.Datasets(i).Layer.Name & " - (" & gMap.Datasets(i).Name & ")"
  Next
  cmbDataset.ListIndex = 0
  cmbThemeType.ListIndex = 0
  
  FillFields 0
End Sub

Private Sub cmbDataset_Click()
  FillFields cmbDataset.ListIndex
End Sub

Private Sub cmbThemeType_Click()
  If cmbThemeType.ListIndex >= 5 Then
    cmdOptions.Enabled = False
  Else
    cmdOptions.Enabled = True
  End If
End Sub

Private Sub cmdAdd_Click()
  Dim i As Integer, iSelCnt As Integer, vFlds As Variant, lColors() As Long
  Dim lResRGB() As Long, bNoTheme As Boolean, iGF As Integer, r As Integer
  Dim lTheme As Theme
  Dim fldCollection As MapXLib.Fields
  Dim fldItem As MapXLib.Field

  iSelCnt = 0
  If lstFields.SelCount = 0 Then
    i = MsgBox("Please select at least one field.", vbOKOnly, "Add Theme")
    Exit Sub
  End If
  bNoTheme = False
  On Error GoTo NoTheme
  iGF = gMap.Datasets(cmbDataset.ListIndex + 1).Themes(txtThemeName.Text).Type
  On Error GoTo 0
  If Not bNoTheme Then
    r = MsgBox("Theme " & txtThemeName.Text & " already exists. Please enter another name.", vbOKOnly, "Add Theme")
    Exit Sub
  End If

  ReDim vFlds(1 To lstFields.SelCount)
  For i = 0 To lstFields.ListCount - 1
    If lstFields.Selected(i) Then
      iSelCnt = iSelCnt + 1
      vFlds(iSelCnt) = i + 1
    End If
  Next
  
  Set fldCollection = gMap.Datasets(cmbDataset.ListIndex + 1).Fields
  Select Case cmbThemeType.ListIndex
    Case miThemeIndividualValue
        If fldCollection(vFlds(1)).Type <> miTypeString Then
            MsgBox "Cannot create Individual value theme on field not aggregated by Individual Value."
            Exit Sub
        End If
    Case Else
        For i = 1 To UBound(vFlds)
            If fldCollection(vFlds(i)).Type = miTypeString Then
                MsgBox "Cannot create selected theme with a field aggregated by Individual Value."
                Exit Sub
            End If
        Next
  End Select
  
  gMap.AutoRedraw = False
  If txtThemeName.Text <> "" Then
    Set lTheme = gMap.Datasets(cmbDataset.ListIndex + 1).Themes.Add(cmbThemeType.ListIndex, vFlds, txtThemeName.Text)
  Else
    Set lTheme = gMap.Datasets(cmbDataset.ListIndex + 1).Themes.Add(cmbThemeType.ListIndex, vFlds)
  End If
  
  Select Case cmbThemeType.ListIndex
    Case miThemeRanged ' Ranged
      If RangeOptions.bOptionsSet Then
        lTheme.AutoRecompute = False
        With lTheme.Properties
          .NumRanges = RangeOptions.RangesCount
          If RangeOptions.DistribMethod = 0 Then
            .DistMethod = miEqualCountPerRange
          Else
            .DistMethod = miEqualRangeSize
          End If
          lTheme.AutoRecompute = True
          If RangeOptions.iMethod = 1 Then
            .SpreadBy = miSpreadByColor
            .RangeCategories(1).Style.RegionColor = RangeOptions.BeginColor
            .RangeCategories(.RangeCategories.Count).Style.RegionColor = RangeOptions.EndColor
          Else
            .SpreadBy = miSpreadByNone
            ReDim lResRGB(.RangeCategories.Count)
            Fill_HSV_Colors RangeOptions.BeginColor, RangeOptions.EndColor, .RangeCategories.Count, lResRGB
            For i = 1 To .RangeCategories.Count
              .RangeCategories(i).Style.RegionColor = lResRGB(i)
            Next
          End If
        End With
        lTheme.Visible = RangeOptions.bVisible
      End If
    Case miThemeBarChart ' Bars
      If BarOptions.bOptionsSet Then
        lTheme.AutoRecompute = False
        With lTheme.Properties
          .DataValue = BarOptions.BarValue
          .Size = BarOptions.BarSize
          .Width = BarOptions.BarWidth
          .Independent = BarOptions.bIndependent
        End With
        lTheme.AutoRecompute = True
        lTheme.Visible = BarOptions.bVisible
      End If
    Case miThemePieChart ' Pie
      If PieOptions.bOptionsSet Then
        lTheme.AutoRecompute = False
        With lTheme.Properties
          .DataValue = PieOptions.PieValue
          .Size = PieOptions.PieSize
          .Graduated = PieOptions.bGraduated
        End With
        lTheme.AutoRecompute = True
        lTheme.Visible = PieOptions.bVisible
      End If
    Case miThemeGradSymbol ' GradSymb
      If GradOptions.bOptionsSet Then
        lTheme.AutoRecompute = False
        With lTheme.Properties
          .DataValue = GradOptions.GradValue
          .SymbolStyle.SymbolFont.Size = GradOptions.GradSize
          .SymbolStyle.SymbolFontColor = GradOptions.GradColor
        End With
        lTheme.AutoRecompute = True
        lTheme.Visible = GradOptions.bVisible
      End If
    Case miThemeDotDensity ' DotDens
      If DotOptions.bOptionsSet Then
        lTheme.AutoRecompute = False
        With lTheme.Properties
          .ValuePerDot = DotOptions.DotValue
          If DotOptions.DotSize = 0 Then
            .DotSize = DotSizeConstants.miDotSizeSmall
          Else
            .DotSize = DotSizeConstants.miDotSizeLarge
          End If
        End With
        lTheme.AutoRecompute = True
        lTheme.Visible = DotOptions.bVisible
      End If
  End Select
  If Not LegendStyle.bLegendSet Then
    GoTo EndLegend
  End If
  With lTheme.Legend
    .Visible = LegendStyle.bVisible
    .Compact = LegendStyle.bCompact
    .CurrencyFormat = LegendStyle.bCurrency
    If LegendStyle.bCompact Then
      If LegendStyle.bOverrideTitle Then
        .CompactTitle = LegendStyle.sTitle
'        Set .CompactTitleStyle = LegendStyle.txtTitle
      End If
    Else
      If LegendStyle.bOverrideTitle Then
        .Title = LegendStyle.sTitle
'        Set .TitleStyle = LegendStyle.txtTitle
      End If
      If LegendStyle.bOverrideSubTitle Then
        .SubTitle = LegendStyle.sSubTitle
'        Set .SubTitleStyle = LegendStyle.txtSubTitle
      End If
    End If
  End With
EndLegend:
  gMap.AutoRedraw = True
  
  Hide
  Exit Sub
NoTheme:
  bNoTheme = True
  Resume Next
End Sub

Private Sub cmdCancel_Click()
  Hide
End Sub

Private Sub cmdLegend_Click()
  LegendStyle.Activate
End Sub

Private Sub cmdOptions_Click()
  Select Case cmbThemeType.ListIndex
    Case 0 ' Ranges
      RangeOptions.Activate
    Case 1 ' Bar
      BarOptions.BarValue = GetMaxValue
      BarOptions.Activate gMap.PaperUnit
    Case 2 ' Pie
      PieOptions.PieValue = GetMaxValue
      PieOptions.Activate gMap.PaperUnit
    Case 3 ' GradSymb
      GradOptions.GradValue = GetMaxValue
      GradOptions.Activate
    Case 4 ' DotDens
      DotOptions.DotValue = CLng(GetMaxValue / 50#)
      DotOptions.Activate
  End Select
End Sub

Private Sub lstFields_Click()
  cmdAdd.Enabled = (lstFields.SelCount > 0)
  FillName
End Sub

Private Sub FillName()
  Dim sName As String, sep As String, i As Integer
  
  sName = ""
  sep = ""

  For i = 0 To lstFields.ListCount - 1
    If lstFields.Selected(i) Then
      sName = sName & sep & lstFields.List(i)
      sep = ","
    End If
  Next
  
  txtThemeName.Text = sName
  
End Sub
Private Function GetMaxValue() As Double
  Dim ds As Dataset, fVal As Double, fMaxVal As Double, i As Integer, iCn As Integer
  
  Set ds = gMap.Datasets(cmbDataset.ListIndex + 1)
  For i = 0 To lstFields.ListCount - 1
    If lstFields.Selected(i) Then
      If ds.Fields(i + 1).Type = 1 Then
        iCn = iCn + 1
        If iCn = 1 Then
          fMaxVal = GetMaxFieldVal(ds, i + 1)
        Else
          fVal = GetMaxFieldVal(ds, i + 1)
          If fMaxVal < fVal Then
            fMaxVal = fVal
          End If
        End If
      End If
    End If
  Next
  GetMaxValue = fMaxVal
End Function

Private Function GetMaxFieldVal(ds As Dataset, ByVal iFld As Integer) As Double
  Dim i As Long, fVal As Double, fMaxVal As Double

  fMaxVal = ds.Value(1, iFld)
  For i = 1 To ds.RowCount
    fVal = ds.Value(i, iFld)
    If fVal > fMaxVal Then
      fMaxVal = fVal
    End If
  Next
  GetMaxFieldVal = fMaxVal
End Function