frmthemewizard1_r.frm

都是基于VB所做的程序集合,值得大家作为实践的参考资料.

            Case 3 '开方
                  objThemeR.Make scrSquareRoot, nBreakCount
      End Select
      
      MSFlexGrid1.Col = 0
      For i = 1 To nBreakCount
            MSFlexGrid1.Row = i
            If nDtType = scdRegion Then
                  objThemeR.Style(i).BrushColor = MSFlexGrid1.CellBackColor
            Else
                  objThemeR.Style(i).PenColor = MSFlexGrid1.CellBackColor
            End If
      Next i
      
      objThemeR.Enable = True
      objLayer.ThemeUnique.Enable = False
      frmMain.SuperMap1.Refresh

      Set objLayer = Nothing
      Set objThemeR = Nothing
      
      Unload frmTheme1
      Unload Me
End Sub

Private Sub btnReCompute_Click()
      If cmbFieldName.Text = "" Then
            Exit Sub
      Else
            Dim objLayer As soLayer
            Dim objThemeRange As soThemeRange
            Dim objColors As New soColors
            
            Dim nBreakCount As Integer
            Dim i As Integer
            
            Set objLayer = frmMain.SuperMap1.Layers.Item(frmTheme1.cmbLayerName.Text)
            If objLayer Is Nothing Then Exit Sub
            Set objThemeRange = objLayer.ThemeRange
            objThemeRange.Field = Me.cmbFieldName
            nBreakCount = cmbCount.Text
            Select Case cmbCarveUp.ListIndex
                  Case 0 '等距
                        objThemeRange.Make scrConstant, nBreakCount
                  Case 1 '等计数
                        objThemeRange.Make scrEqualCount, nBreakCount
                  Case 2 '对数
                        objThemeRange.Make scrLog, nBreakCount
                  Case 3 '开方
                        objThemeRange.Make scrSquareRoot, nBreakCount
            End Select
            
            objColors.MakeGradientColorset Val(cmbCount.Text), lblStartColor.BackColor, lblEndColor.BackColor
            MSFlexGrid1.Rows = nBreakCount + 1
            MSFlexGrid1.Row = 1
            MSFlexGrid1.Col = 0
            MSFlexGrid1.CellBackColor = objColors.Item(1)
            MSFlexGrid1.Col = 1
            MSFlexGrid1.Text = "Value < " & objThemeRange.BreakValue(1)
            For i = 2 To nBreakCount - 1
                  MSFlexGrid1.Row = i
                  MSFlexGrid1.Col = 0
                  MSFlexGrid1.CellBackColor = objColors.Item(i)
                  MSFlexGrid1.Col = 1
                  MSFlexGrid1.Text = objThemeRange.BreakValue(i - 1) & " < Value < " & objThemeRange.BreakValue(i)
            Next i
            MSFlexGrid1.Row = nBreakCount
            MSFlexGrid1.Col = 0
            MSFlexGrid1.CellBackColor = objColors.Item(nBreakCount)
            MSFlexGrid1.Col = 1
            MSFlexGrid1.Text = "Value > " & objThemeRange.BreakValue(nBreakCount)
      End If
End Sub

Private Sub btnRndSetColor_Click()
      Dim i As Integer
      Randomize
      MSFlexGrid1.Col = 0
      For i = 1 To MSFlexGrid1.Row - 1
            MSFlexGrid1.Row = i
            MSFlexGrid1.CellBackColor = Int(16777216 * Rnd)
      Next i
End Sub

Private Sub cmbCarveUp_Click()
      With MSFlexGrid1
            .Rows = 1
            .Clear
            .Row = 0
            .Col = 0
            .Text = "颜色"
            .Col = 1
            .Text = "范围"
      End With
End Sub

Private Sub cmbCount_Click()
      If cmbCount.Text = "" Then Exit Sub
      Dim objDt As soDataset
      Dim objDtVector As soDatasetVector
      Set objDt = frmMain.SuperMap1.Layers.Item(frmTheme1.cmbLayerName.Text).Dataset
      If objDt Is Nothing Then
            MsgBox "数据集" & frmTheme1.cmbLayerName.Text & "不存在!", vbInformation
            Exit Sub
      End If
      Set objDtVector = objDt
      If objDtVector Is Nothing Then
            MsgBox "错误！", vbInformation
            Exit Sub
      End If
      
      Set objDt = Nothing
      Set objDtVector = Nothing
      '刷新MSFlexGrid1
      With MSFlexGrid1
            .Rows = 1
            .Clear
            .Row = 0
            .Col = 0
            .Text = "颜色"
            .Col = 1
            .Text = "范围"
      End With
      btnReCompute.Enabled = True
End Sub

Private Sub cmbCount_KeyPress(KeyAscii As Integer)
            If KeyAscii > Asc("9") Or KeyAscii < Asc("0") Then
            If (KeyAscii <> vbKeyBack) Then
                  KeyAscii = 0
                  Beep
            End If
      End If
End Sub

Private Sub cmbFieldName_Click()
      If cmbFieldName.Text = "" Then
            Exit Sub
      Else
            With MSFlexGrid1
                  .Rows = 1
                  .Clear
                  .Row = 0
                  .Col = 0
                  .Text = "颜色"
                  .Col = 1
                  .Text = "范围"
            End With
      End If
End Sub

Private Sub cmbPrecision_Click()
      With MSFlexGrid1
            .Rows = 1
            .Clear
            .Row = 0
            .Col = 0
            .Text = "颜色"
            .Col = 1
            .Text = "范围"
      End With
End Sub

Private Sub Form_Load()
    lblEndColor.BackColor = RGB(29, 194, 122)
      '初始化表头
      With MSFlexGrid1
            .Row = 0
            .Col = 0
            .CellBackColor = &H80000004
            .Text = "颜色"
            .Col = 1
            .CellBackColor = &H80000004
            .Text = "范围"
            .ColWidth(0) = 570
            .ColWidth(1) = .Width - .ColWidth(0) - 350
            .ColAlignment(0) = flexAlignCenterCenter
            .ColAlignment(1) = flexAlignLeftCenter
      End With
      '添加字段列表框
      Dim objDt As soDataset
      Dim objDtVector As soDatasetVector
      Dim objFieldInfo As soFieldInfo
      Set objDt = frmMain.SuperMap1.Layers.Item(frmTheme1.cmbLayerName.Text).Dataset
      If objDt Is Nothing Then
            MsgBox LoadResString(3052) & frmTheme1.cmbLayerName.Text & LoadResString(5155), vbInformation
            Exit Sub
      End If
      
      Set objDtVector = objDt
      If objDtVector Is Nothing Then
            MsgBox "错误！", vbInformation
            Exit Sub
      End If
      Set objDt = Nothing

      Dim i As Integer
      For i = 1 To objDtVector.FieldCount
            Set objFieldInfo = objDtVector.GetFieldInfo(i)
            If objFieldInfo Is Nothing Then
                  MsgBox "错误！", vbInformation
                  Exit Sub
            End If
            Select Case objFieldInfo.Type
                  Case scfInteger, scfLong, scfDouble, scfSingle
                        cmbFieldName.AddItem objFieldInfo.Name
                  Case Else
                  
            End Select
      Next i
      cmbFieldName.ListIndex = 1
      Set objFieldInfo = Nothing
      Set objDtVector = Nothing
      '添加分段数量列表框(cmbCount)
      cmbCount.Clear
      For i = 2 To 32
            cmbCount.AddItem i
      Next i
      cmbCount.Text = 10
      '添加舍入精度列表框(cmbPrecision)
      For i = -6 To 0
            cmbPrecision.AddItem 10 ^ i
      Next
      cmbPrecision.Text = 10 ^ (-3)
      '添加分段方法列表框
      With cmbCarveUp
            .AddItem "等距分段"
            .AddItem "等计数分段"
            .AddItem "对数分段"
            .AddItem "开方分段"
            .ListIndex = 0
      End With
End Sub

Private Sub lblEndColor_Click()
      cdlColor.ShowColor
      If cdlColor.Color <> 0 Then
            lblEndColor.BackColor = cdlColor.Color
      End If
End Sub

Private Sub lblStartColor_Click()
      cdlColor.ShowColor
      If cdlColor.Color <> 0 Then
            lblStartColor.BackColor = cdlColor.Color
      End If
End Sub

Private Sub MSFlexGrid1_DblClick()
      Dim objLayer As soLayer
      Dim Stl As soStyle
      Dim bResult As Boolean
      
      Set objLayer = frmMain.SuperMap1.Layers.Item(frmTheme1.cmbLayerName.Text)
      If objLayer Is Nothing Then
            MsgBox "错误！", vbInformation
            Exit Sub
      End If
      Set Stl = objLayer.Style
      If Stl Is Nothing Then
            MsgBox "错误！", vbInformation
            Exit Sub
      End If
      If objLayer.Dataset.Type = scdRegion Then
            bResult = frmMain.SuperMap1.ShowStylePicker(Stl, 2)
      ElseIf objLayer.Dataset.Type = scdLine Then
            bResult = frmMain.SuperMap1.ShowStylePicker(Stl, 1)
      End If
End Sub