frmthemedotdensity.frm

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

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.Form frmThemeDotDensity 
   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             =   "5259"
   Begin VB.CommandButton btnBack 
      Caption         =   "上一步(&B)"
      Height          =   370
      Left            =   2055
      TabIndex        =   12
      Tag             =   "3129"
      Top             =   3465
      Width           =   1200
   End
   Begin VB.CommandButton btnCancel 
      Cancel          =   -1  'True
      Caption         =   "放弃(&C)"
      Height          =   370
      Left            =   4830
      TabIndex        =   11
      Tag             =   "3058"
      Top             =   3465
      Width           =   1200
   End
   Begin VB.CommandButton btnOK 
      Caption         =   "完成(&O)"
      Default         =   -1  'True
      Enabled         =   0   'False
      Height          =   370
      Left            =   3255
      TabIndex        =   10
      Tag             =   "3133"
      Top             =   3465
      Width           =   1200
   End
   Begin MSComCtl2.UpDown UpDnDotVal 
      Height          =   255
      Left            =   5055
      TabIndex        =   9
      Top             =   2595
      Width           =   240
      _ExtentX        =   423
      _ExtentY        =   450
      _Version        =   393216
      OrigLeft        =   5430
      OrigTop         =   1890
      OrigRight       =   5670
      OrigBottom      =   2205
      Enabled         =   -1  'True
   End
   Begin MSComDlg.CommonDialog cdlColor 
      Left            =   2085
      Top             =   180
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin MSComCtl2.UpDown UpDnDotSize 
      Height          =   255
      Left            =   5055
      TabIndex        =   8
      Top             =   2040
      Width           =   240
      _ExtentX        =   423
      _ExtentY        =   450
      _Version        =   393216
      Value           =   1
      BuddyControl    =   "txtDotSize"
      BuddyDispid     =   196613
      OrigLeft        =   5460
      OrigTop         =   1380
      OrigRight       =   5700
      OrigBottom      =   1695
      Max             =   100
      Min             =   1
      SyncBuddy       =   -1  'True
      BuddyProperty   =   65547
      Enabled         =   -1  'True
   End
   Begin VB.ComboBox cmbFieldName 
      Height          =   315
      Left            =   3690
      Style           =   2  'Dropdown List
      TabIndex        =   0
      Top             =   915
      Width           =   1620
   End
   Begin VB.TextBox txtDotSize 
      Height          =   315
      Left            =   3690
      TabIndex        =   2
      Top             =   2015
      Width           =   1620
   End
   Begin VB.TextBox txtDotVal 
      Height          =   300
      Left            =   3690
      TabIndex        =   3
      Top             =   2565
      Width           =   1620
   End
   Begin VB.Image Image1 
      BorderStyle     =   1  'Fixed Single
      Height          =   3090
      Left            =   225
      Picture         =   "frmThemeDotDensity.frx":0000
      Top             =   150
      Width           =   1695
   End
   Begin VB.Line Line2 
      BorderColor     =   &H80000003&
      X1              =   15
      X2              =   6315
      Y1              =   3330
      Y2              =   3330
   End
   Begin VB.Line Line1 
      BorderColor     =   &H80000009&
      X1              =   15
      X2              =   6315
      Y1              =   3345
      Y2              =   3345
   End
   Begin VB.Label lblDotColor 
      BackColor       =   &H00000000&
      BorderStyle     =   1  'Fixed Single
      Height          =   315
      Left            =   3690
      TabIndex        =   1
      Top             =   1465
      Width           =   1620
   End
   Begin VB.Label Label4 
      Alignment       =   1  'Right Justify
      Caption         =   "每点代表的值"
      Height          =   210
      Left            =   2190
      TabIndex        =   7
      Tag             =   "5315"
      Top             =   2610
      Width           =   1335
   End
   Begin VB.Label Label3 
      Caption         =   "点大小(象素)"
      Height          =   210
      Left            =   2310
      TabIndex        =   6
      Tag             =   "5314"
      Top             =   2067
      Width           =   1230
   End
   Begin VB.Label Label2 
      Alignment       =   1  'Right Justify
      Caption         =   "点的颜色"
      Height          =   210
      Left            =   2325
      TabIndex        =   5
      Tag             =   "5313"
      Top             =   1517
      Width           =   1200
   End
   Begin VB.Label Label1 
      Alignment       =   1  'Right Justify
      Caption         =   "字段名称"
      Height          =   210
      Left            =   2250
      TabIndex        =   4
      Tag             =   "3217"
      Top             =   960
      Width           =   1275
   End
End
Attribute VB_Name = "frmThemeDotDensity"
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, frmMain
End Sub

Private Sub btnCancel_Click()
      Unload Me
      Unload frmTheme1
End Sub

Private Sub btnOK_Click()
      Dim objThemeDotDensity As soThemeDotDensity
      Dim objLayer As soLayer
      
      Set objLayer = frmMain.SuperMap1.Layers.Item(frmTheme1.cmbLayerName.Text)
      If objLayer Is Nothing Then
            MsgBox "错误！", vbInformation
            Exit Sub
      End If
      Set objThemeDotDensity = objLayer.ThemeDotDensity
      If objThemeDotDensity Is Nothing Then
            MsgBox "错误！", vbInformation
            Set objLayer = Nothing
            Exit Sub
      End If
      objThemeDotDensity.Field = cmbFieldName.Text
      objThemeDotDensity.DotColor = lblDotColor.BackColor
      objThemeDotDensity.DotSize = txtDotSize.Text
      objThemeDotDensity.DotValue = CDbl(txtDotVal.Text)
      objThemeDotDensity.Enable = True
      Set objThemeDotDensity = Nothing
      Set objLayer = Nothing
      frmMain.SuperMap1.Refresh

      Unload Me
      Unload frmTheme1
End Sub

Private Sub cmbFieldName_Click()
      Dim objLayer As soLayer
      Dim objDtVector As soDatasetVector
      Dim objRecordset As soRecordset
      Dim objFieldInfo As soFieldInfo
      Dim dFieldValSum As Double
      
      If cmbFieldName.Text = "" Then
            btnOK.Enabled = False
      Else
            btnOK.Enabled = True
            '以下代码使"每点代表的值"为所选字段值的总和的1/10000，即图上共有10000个点。
            Set objLayer = frmMain.SuperMap1.Layers.Item(frmTheme1.cmbLayerName.Text)
            If objLayer Is Nothing Then Exit Sub
            Set objDtVector = objLayer.Dataset
            If objDtVector Is Nothing Then Exit Sub
            objDtVector.Open
            Set objRecordset = objDtVector.Query("", False)
            If objRecordset Is Nothing Then Exit Sub
            objRecordset.MoveFirst
            '字段求和
            Do While Not (objRecordset.IsEOF)
                  dFieldValSum = dFieldValSum + Abs(objRecordset.GetFieldValue(cmbFieldName.Text))
                  objRecordset.MoveNext
            Loop
            '计算每点代表的值
            If dFieldValSum > 0 Then txtDotVal.Text = Round(dFieldValSum / 10000, 3)
      End If
      
      Set objLayer = Nothing
      Set objDtVector = Nothing
      Set objRecordset = Nothing
      Set objFieldInfo = Nothing
End Sub

Private Sub Form_Load()
      Dim objLayer As soLayer
      Dim objDtVector As soDatasetVector
      Dim objFieldInfo As soFieldInfo
      Dim i As Integer
      
      Set objLayer = frmMain.SuperMap1.Layers.Item(frmTheme1.cmbLayerName.Text)
      If objLayer Is Nothing Then
            MsgBox "错误！", vbInformation
            Exit Sub
      End If
      Set objDtVector = objLayer.Dataset
      If objDtVector Is Nothing Then
            MsgBox "错误！", vbInformation
            Exit Sub
      End If
      objDtVector.Open
      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, scfDouble, scfLong, scfSingle
                        cmbFieldName.AddItem objFieldInfo.Name
            End Select
      Next
      txtDotSize.Text = "1"
      txtDotVal = "10.0"
      Set objFieldInfo = Nothing
      Set objDtVector = Nothing
      Set objLayer = Nothing
End Sub

Private Sub lblDotColor_DblClick()
      cdlColor.CancelError = False
      cdlColor.ShowColor
      If cdlColor.Color > 0 Then
            lblDotColor.BackColor = cdlColor.Color
      End If
End Sub

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


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

Private Sub UpDnDotVal_DownClick()
      If Val(txtDotVal.Text) > 0.1 Then
            txtDotVal.Text = CStr(Val(txtDotVal.Text) - 0.1)
      End If
End Sub

Private Sub UpDnDotVal_UpClick()
      txtDotVal.Text = CStr(Val(txtDotVal.Text) + 0.1)
End Sub