frmthemeunique.frm

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

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form frmThemeUnique 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "单值专题图"
   ClientHeight    =   3885
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6315
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3885
   ScaleWidth      =   6315
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  'CenterScreen
   Tag             =   "2919"
   Begin VB.PictureBox Picture1 
      AutoSize        =   -1  'True
      Height          =   3090
      Left            =   225
      Picture         =   "frmThemeUnique.frx":0000
      ScaleHeight     =   3030
      ScaleWidth      =   1635
      TabIndex        =   6
      Top             =   150
      Width           =   1695
   End
   Begin VB.CommandButton btnBack 
      Caption         =   "上一步(&B)"
      Height          =   375
      Left            =   2055
      TabIndex        =   5
      Tag             =   "3129"
      Top             =   3465
      Width           =   1200
   End
   Begin VB.CommandButton btnCancel 
      Cancel          =   -1  'True
      Caption         =   "放弃(&C)"
      Height          =   375
      Left            =   4830
      TabIndex        =   4
      Tag             =   "3058"
      Top             =   3465
      Width           =   1200
   End
   Begin VB.CommandButton btnOK 
      Caption         =   "完成(&O)"
      Default         =   -1  'True
      Enabled         =   0   'False
      Height          =   375
      Left            =   3255
      TabIndex        =   3
      Tag             =   "3133"
      Top             =   3465
      Width           =   1200
   End
   Begin VB.CommandButton btnRandom 
      Caption         =   "随机设色"
      Height          =   330
      Left            =   3945
      TabIndex        =   1
      Tag             =   "3240"
      Top             =   795
      Width           =   1860
   End
   Begin VB.ComboBox cmbField 
      Height          =   315
      Left            =   2205
      Style           =   2  'Dropdown List
      TabIndex        =   0
      Top             =   795
      Width           =   1650
   End
   Begin MSComDlg.CommonDialog cdlColor 
      Left            =   930
      Top             =   3375
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin MSFlexGridLib.MSFlexGrid MSFlexGrid1 
      Height          =   1935
      Left            =   2175
      TabIndex        =   2
      Top             =   1290
      Width           =   3645
      _ExtentX        =   6429
      _ExtentY        =   3413
      _Version        =   393216
      Rows            =   1
      FixedRows       =   0
      FixedCols       =   0
      RowHeightMin    =   200
      BackColorBkg    =   -2147483634
      FillStyle       =   1
      GridLines       =   2
      ScrollBars      =   2
      AllowUserResizing=   1
   End
   Begin VB.Line Line2 
      BorderColor     =   &H80000014&
      X1              =   15
      X2              =   6405
      Y1              =   3345
      Y2              =   3345
   End
   Begin VB.Line Line1 
      BorderColor     =   &H80000003&
      X1              =   15
      X2              =   6420
      Y1              =   3330
      Y2              =   3330
   End
End
Attribute VB_Name = "frmThemeUnique"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'说 明：用来创建单值专题图
Option Explicit

Private Sub btnBack_Click()
      Unload Me
      frmTheme1.Show vbModal
End Sub

Private Sub btnCancel_Click()
      Unload frmTheme1
      Unload Me
End Sub

Private Sub btnOK_Click()
      Dim i As Integer
      Dim Layer As soLayer
      Dim ThemeUnique As soThemeUnique
      Set Layer = frmMain.SuperMap1.Layers.Item(frmTheme1.cmbLayerName.Text)
      If Layer Is Nothing Then
            MsgBox "错误！", vbInformation
            Exit Sub
      End If
      Set ThemeUnique = Layer.ThemeUnique
      If ThemeUnique Is Nothing Then
            MsgBox "错误！", vbInformation
            Set Layer = Nothing
      End If
      ThemeUnique.Enable = True
      ThemeUnique.Field = cmbField.Text
      ThemeUnique.MakeDefault
      MSFlexGrid1.Col = 0
      ThemeUnique.ValueCount = MSFlexGrid1.Rows - 1
      For i = 1 To MSFlexGrid1.Rows - 1
            MSFlexGrid1.Row = i
            ThemeUnique.Style(i).PenColor = MSFlexGrid1.CellBackColor
      Next i
      Layer.ThemeRange.Enable = False
      
      frmMain.SuperMap1.Refresh
'      frmmain.SuperLegend1.Refresh
      
      Unload Me
      Unload frmTheme1
      Set Layer = Nothing
      Set ThemeUnique = Nothing
End Sub

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

Private Sub cmbField_Click()
      If cmbField.Text = "" Then Exit Sub
      Dim i As Integer
      Dim Layer As soLayer
      Dim ThemeUnique As soThemeUnique
      Set Layer = frmMain.SuperMap1.Layers.Item(frmTheme1.cmbLayerName.Text)
      If Layer Is Nothing Then
            MsgBox "错误！", vbInformation
            Exit Sub
      End If
      Set ThemeUnique = Layer.ThemeUnique
      If ThemeUnique Is Nothing Then
            MsgBox "错误！", vbInformation
            Exit Sub
      End If
      ThemeUnique.Field = cmbField.Text
      If ThemeUnique.MakeDefault = False Then
            MsgBox "错误！", vbInformation
            Exit Sub
      End If
      MSFlexGrid1.Rows = ThemeUnique.ValueCount + 1
      MSFlexGrid1.Col = 0
      For i = 1 To ThemeUnique.ValueCount
            MSFlexGrid1.Row = i
            MSFlexGrid1.CellBackColor = ThemeUnique.Style(i).BrushColor '  PenColor
      Next i
      MSFlexGrid1.Col = 1
      For i = 1 To ThemeUnique.ValueCount
            MSFlexGrid1.Row = i
            MSFlexGrid1.Text = Space$(3) & ThemeUnique.Value(i)
      Next i
      btnOK.Enabled = True
      Set Layer = Nothing
      Set ThemeUnique = Nothing
End Sub

Private Sub Form_Activate()
      Dim DS As soDataSource
      Dim DtVector As soDatasetVector
      Dim FieldInfo As soFieldInfo
      Dim strName As String
      
      strName = Mid$(frmTheme1.cmbLayerName.Text, InStr(frmTheme1.cmbLayerName.Text, "@") + 1)
      Set DS = frmMain.SuperWorkspace1.Datasources.Item(strName)
      If DS Is Nothing Then
            MsgBox "错误！", vbInformation
            Exit Sub
      End If
      strName = frmMain.SuperMap1.Layers.Item(frmTheme1.cmbLayerName.Text).Dataset.Name
      Set DtVector = DS.Datasets.Item(strName)
      If DtVector Is Nothing Then
            Set DS = Nothing
            MsgBox "错误！", vbInformation
            Exit Sub
      End If
      DtVector.Open
      Dim i As Integer
      For i = 1 To DtVector.FieldCount
            Set FieldInfo = DtVector.GetFieldInfo(i)
            If FieldInfo Is Nothing Then
                  MsgBox "错误！", vbInformation
                  Exit Sub
            End If
            Select Case FieldInfo.Type
                  Case scfText, scfInteger, scfDouble, scfLong, scfSingle
                        cmbField.AddItem FieldInfo.Name
                  Case Else
                  
            End Select
      Next
      Set DS = Nothing
      Set DtVector = Nothing
      Set FieldInfo = Nothing
End Sub

Private Sub Form_Load()
      MSFlexGrid1.ColWidth(0) = 700
      MSFlexGrid1.ColWidth(1) = MSFlexGrid1.Width - MSFlexGrid1.ColWidth(0)
      MSFlexGrid1.ColAlignment(0) = flexAlignLeftCenter
      MSFlexGrid1.ColAlignment(1) = flexAlignLeftCenter
      MSFlexGrid1.Col = 0
      MSFlexGrid1.Row = 0
      MSFlexGrid1.CellBackColor = &H80000004
      MSFlexGrid1.Text = "颜色"
      MSFlexGrid1.Col = 1
      MSFlexGrid1.CellBackColor = &H80000004
      MSFlexGrid1.Text = "分类值"
End Sub

Private Sub MSFlexGrid1_DblClick()
      If (MSFlexGrid1.Col = 0) And (MSFlexGrid1.Row <> 0) Then
            cdlColor.CancelError = False
            cdlColor.ShowColor
            If cdlColor.Color <> "0" Then
                  MSFlexGrid1.CellBackColor = cdlColor.Color
            End If
      End If
End Sub