frmthemelabel.frm

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

VERSION 5.00
Begin VB.Form frmThemeLabel 
   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             =   "5258"
   Begin VB.CheckBox Check1 
      Caption         =   "固定标签大小"
      Height          =   300
      Left            =   3270
      TabIndex        =   7
      Top             =   2595
      Width           =   1605
   End
   Begin VB.CommandButton btnBack 
      Caption         =   "上一步(&B)"
      Height          =   370
      Left            =   2055
      TabIndex        =   6
      Tag             =   "3129"
      Top             =   3465
      Width           =   1200
   End
   Begin VB.CommandButton btnOK 
      Caption         =   "完成(&O)"
      Default         =   -1  'True
      Enabled         =   0   'False
      Height          =   370
      Left            =   3255
      TabIndex        =   5
      Tag             =   "3133"
      Top             =   3465
      Width           =   1200
   End
   Begin VB.CommandButton btnCancel 
      Cancel          =   -1  'True
      Caption         =   "放弃(&C)"
      Height          =   370
      Left            =   4830
      TabIndex        =   4
      Tag             =   "3058"
      Top             =   3465
      Width           =   1200
   End
   Begin VB.CommandButton btnLabelStyle 
      Caption         =   "标签风格设置"
      Height          =   375
      Left            =   3225
      TabIndex        =   2
      Tag             =   "5328"
      Top             =   2070
      Width           =   1620
   End
   Begin VB.ComboBox cmbFieldName 
      Height          =   315
      Left            =   3225
      Style           =   2  'Dropdown List
      TabIndex        =   0
      Top             =   1485
      Width           =   1620
   End
   Begin VB.Image Image1 
      BorderStyle     =   1  'Fixed Single
      Height          =   3090
      Left            =   225
      Picture         =   "frmThemeLabel.frx":0000
      Top             =   150
      Width           =   1695
   End
   Begin VB.Label Label2 
      Caption         =   "选择用于标注的字段，设置标注风格。"
      Height          =   675
      Left            =   2280
      TabIndex        =   3
      Tag             =   "5337"
      Top             =   420
      Width           =   3645
   End
   Begin VB.Label Label1 
      Alignment       =   2  'Center
      Caption         =   "字段名称"
      Height          =   210
      Left            =   1980
      TabIndex        =   1
      Tag             =   "3217"
      Top             =   1530
      Width           =   1200
   End
   Begin VB.Line Line1 
      BorderColor     =   &H80000009&
      X1              =   15
      X2              =   6315
      Y1              =   3345
      Y2              =   3345
   End
   Begin VB.Line Line2 
      BorderColor     =   &H80000003&
      X1              =   15
      X2              =   6315
      Y1              =   3330
      Y2              =   3330
   End
End
Attribute VB_Name = "frmThemeLabel"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'说 明：用来创建标注专题图
Option Explicit
Dim objTextStyle As New soTextStyle
Dim bSetStyle As Boolean

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

Private Sub btnCancel_Click()
      Set objTextStyle = Nothing
      bSetStyle = False
      Unload Me
      Unload frmTheme1
End Sub

Private Sub btnLabelStyle_Click()
      objTextStyle.Align = sctTopLeft
      objTextStyle.Bold = True
      objTextStyle.Color = vbRed
      objTextStyle.FontHeight = 4.2
      objTextStyle.Italic = False
      objTextStyle.Stroke = False
      objTextStyle.Underline = False
      bSetStyle = frmMain.SuperMap1.ShowTextStylePicker(objTextStyle)
      If (bSetStyle = True) And (cmbFieldName.ListIndex >= 0) Then btnOK.Enabled = True
End Sub

Private Sub btnOK_Click()
      Dim objThemeLabel As soThemeLabel
      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 objThemeLabel = objLayer.ThemeLabel
      If objThemeLabel Is Nothing Then
            MsgBox "错误！", vbInformation
            Set objLayer = Nothing
            Exit Sub
      End If
      Set objThemeLabel.TextStyle = objTextStyle
      
      objThemeLabel.Field = cmbFieldName.Text
      objThemeLabel.TextStyle.FixedSize = IIf(Check1.Value = vbChecked, True, False)
      objThemeLabel.Enable = True
      frmMain.SuperMap1.Refresh
      
      Set objLayer = Nothing
      Set objThemeLabel = Nothing
      Set objTextStyle = Nothing
      Unload Me
      Unload frmTheme1
End Sub

Private Sub cmbFieldName_Click()
      If (cmbFieldName.ListIndex >= 0) And (bSetStyle = True) Then btnOK.Enabled = True
      
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, scfText
                        cmbFieldName.AddItem objFieldInfo.Name
            End Select
      Next
      Set objLayer = Nothing
      Set objDtVector = Nothing
      Set objFieldInfo = Nothing
End Sub