uclayersymbol.ctl

arcengine+vb开发原码

         Top             =   1320
         Width           =   1095
      End
      Begin VB.PictureBox UpDown1 
         Height          =   375
         Left            =   1920
         ScaleHeight     =   315
         ScaleWidth      =   180
         TabIndex        =   5
         Top             =   720
         Width           =   240
      End
      Begin VB.Label Label6 
         Caption         =   "颜色："
         Height          =   255
         Left            =   360
         TabIndex        =   7
         Top             =   1440
         Width           =   735
      End
      Begin VB.Label lblSizeCaption 
         Caption         =   "宽度："
         Height          =   255
         Left            =   360
         TabIndex        =   6
         Top             =   840
         Width           =   615
      End
   End
   Begin VB.Frame Frame2 
      Caption         =   "预览"
      Height          =   2055
      Left            =   5520
      TabIndex        =   0
      Top             =   760
      Width           =   2535
      Begin VB.PictureBox picPreview 
         Appearance      =   0  'Flat
         AutoRedraw      =   -1  'True
         BackColor       =   &H80000005&
         ForeColor       =   &H80000008&
         Height          =   1575
         Left            =   170
         ScaleHeight     =   103
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   145
         TabIndex        =   1
         Top             =   300
         Width           =   2200
      End
   End
   Begin MSComDlg.CommonDialog dlgCommon 
      Left            =   0
      Top             =   0
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
End
Attribute VB_Name = "ucLayerSymbol"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

'符号化控件错误
Private Enum errorControl

    ErrirCanntLoadStyleFile = 1                        '不能加载符号库文件
    ErrorNoMatchedSymbol = 2                           '符号库没有与图层匹配的符号（设定了符号几何类型(点、线、面)）
    ErrorNoSymbols = 3                                 '符号库没有点、线、面符号（目前只考虑这三种）
    ErrorNoEnoughMemory = 4                            '内存不足
    ErrorNoSelectedSymbol = 5                          '没有选中符号
    ErrorPreview = 6                                   '不能预览符号
    ErrorNoSytleFileSelected = 7                       '“符号库”下拉框没有选择文件
    ErrorSetSymbolClass = 8                            '传入参数错误，只能为“Fill Symbols”、“Line Symbols”、“Marke Symbols”
    ErrorBadStyleFile = 9                              '符号文件已经损坏
    ErrorVisibleSymbolsNum = 10                        '计算可见的符号个数错误（一般为 9 个）
    ErrorLTSymbolID = 11                               '计算可见的第一个（左上角）符号索引错误
    ErrorDisplaySymbol = 12                            '显示符号错误

End Enum

Private m_enumSymbolGeometryType  As esriGeometryType  '符号几何类型(点、线、面)
Private m_pOutputSymbol As ISymbol                     '控件输出的符号
Private m_pInputSymbol As ISymbol                      '控件输入的符号
Private m_pOriginalSymbol As ISymbol                   '保存控件输入的符号
Private m_pStyleGallery As IStyleGallery               '用于访问所有的符号
Private m_bHasFillSymbolInFile As Boolean              '符号库含有面符号
Private m_bHasLineSymbolInFile As Boolean              '符号库含有线符号
Private m_bHasMarkerSymbolInFile As Boolean            '符号库含有点符号
Private m_intTotalSymbolsNum As Integer                '当前符号库文件中的指定符号类型（点、线、面）的符号个数
Private m_pStylePath  As String                        '当前符号库（含文件名，目前默认forestry.serverstyle）
Private m_bControlStart  As Boolean                    '是否控件刚启动
Private m_strSymbolName As String                      '某个符号的名称,预览符号时出错处理显示用,以后删除
Private m_intSymbolID  As Long                         '某个符号的ID,预览符号时出错处理显示用，以后删除
Private m_pSymbolsArray(9) As ISymbol                   '当前可见符号（一般为九个）
Private m_strSymbolNameArray(9) As String              '当前可见符号的名称（一般为九个）
Private m_bChangStyleFile As Boolean                   '重新选择符号库文件
Private m_intLTSymbolID As Integer                     '控件左上角（第一行，第一列）哪个符号的ID
Private m_intCurDisplayingSymbolsNum As Integer        '当前控件上应该显示的符号个数（一般为九个）
Private m_bResetHscrollBar  As Boolean                 '是否需要重新复位垂直滚动条
Private m_intSize As Integer                           '当前选中的符号的线宽（面符号和线符号）或直径（点符号）
Private m_strShapeType As String                       '符号类型
Private m_bHasSelectedOneSymbol As Boolean             '是否选择了符号（预览之前提）
Private m_bLoadFileFromOtherDirectory As Boolean       '不从默认目录下加载符号库文件
Private m_strLineOrPointWidth As String                '顾名思意
Private m_strOutLineSize As String                     '顾名思意

'错误处理
Private Sub CatchErrors(errorType As errorControl)

    Select Case errorType

        Case ErrirCanntLoadStyleFile:

            MsgBox "不能加栽符号库文件"

        Case ErrorNoMatchedSymbol:

            MsgBox "符号库没有你需要的符号。"

        Case ErrorNoSymbols:

            MsgBox "符号库没有面标注符号、线标注符号、点标注符号。"

        Case ErrorNoEnoughMemory:

            MsgBox "内存不足。"

        Case ErrorNoSelectedSymbol:

            MsgBox "没有选中符号。"

        Case ErrorPreview:

            MsgBox "不能预览符号符号。"

        Case ErrorNoSytleFileSelected:

            MsgBox "请在'符号库'下拉框中选则符号库"

        Case ErrorSetSymbolClass:

            MsgBox "符号类型只能为“Fill Symbols”、“Line Symbols”、“Marke Symbols”"

        Case ErrorBadStyleFile:

            MsgBox "符号库文件已经损坏。"

        Case ErrorVisibleSymbolsNum:

            MsgBox "计算当前显示的符号个数作物。"

        Case ErrorLTSymbolID:

            MsgBox "计算符号索引错误。"

        Case ErrorDisplaySymbol:

            MsgBox "显示符号错误（非预览）。"


    End Select

End Sub

'控件属性--图层类型（in）（点、线、面）
Public Property Let GeometryType(intGeometryType As esriGeometryType)

    '初始化几何类型(点、线还是面)
    m_enumSymbolGeometryType = intGeometryType

    '几何类型是否非空
    If Not (intGeometryType = esriGeometryPoint Or intGeometryType = esriGeometryPolyline Or _
            intGeometryType = esriGeometryLine Or intGeometryType = esriGeometryEnvelope Or _
            intGeometryType = esriGeometryEnvelope) Then

        CatchErrors ErrorSetSymbolClass
        Exit Property

    End If

    '更新静态显示界面
    UpdateStaticDisplaying

    '更新动态显示界面
    UpdateDynamicDisplaying

End Property

'控件属性--输入符号(in)
Public Property Let Symbol(pSymbol As ISymbol)

    Set m_pInputSymbol = pSymbol
    Dim pCloneFatherSymbol As IClone
    Set pCloneFatherSymbol = pSymbol
    Set m_pOriginalSymbol = pCloneFatherSymbol.Clone
    If m_pInputSymbol Is Nothing Then Exit Property
    
    cmbGeometryType.Visible = False
    txtInputSymbolType.Visible = True
    lblSymbolType.Left = 600
    If TypeOf m_pInputSymbol Is IFillSymbol Then txtInputSymbolType.Text = "面符号"
    If TypeOf m_pInputSymbol Is ILineSymbol Then txtInputSymbolType.Text = "线符号"
    If TypeOf m_pInputSymbol Is IMarkerSymbol Then txtInputSymbolType.Text = "点符号"
    
End Property

'控件属性--输出符号（out）
Public Property Get Symbol() As ISymbol
    
    Debug.Assert Not (m_pInputSymbol Is Nothing And m_pOutputSymbol Is Nothing)
    If m_pInputSymbol Is Nothing And m_pOutputSymbol Is Nothing Then Exit Sub
    
    If m_pOutputSymbol Is Nothing Then
        Set Symbol = m_pInputSymbol
    Else
        Set Symbol = m_pOutputSymbol
    End If

End Property

Private Sub cmdDefaultValue_Click()
    
    Dim pFatherCloneSymbol As IClone
    Set pFatherCloneSymbol = m_pOriginalSymbol
    Set m_pInputSymbol = pFatherCloneSymbol.Clone
    UserControl_Initialize
    UserControl_Show

End Sub

Private Sub Label5_DragDrop(Source As Control, x As Single, y As Single)

End Sub

'选中符号
Private Sub picShowSymbol_Click(Index As Integer)
    
    m_bHasSelectedOneSymbol = True
        
    '当前符号是否为空
    If m_pSymbolsArray(Index) Is Nothing Then

        CatchErrors ErrorNoSelectedSymbol
        Exit Sub

    End If

    '返回符号(存于 m_pOutputSymbol)
    GetSelectedSymbol m_pSymbolsArray(Index)

End Sub

 '返回鼠标选择的符号
Private Sub GetSelectedSymbol(pSymbol As ISymbol)

    Set m_pOutputSymbol = pSymbol

    '可视化符号
    Dim bResult As Boolean
    bResult = DrawToDC(picPreview.hdc, picPreview.ScaleWidth, picPreview.ScaleHeight, m_pOutputSymbol, 2)
    If bResult = False Then CatchErrors ErrorPreview
    picPreview.Refresh

    '显示信息
    DisplaySymbolProp

End Sub

'显示选中的符号的颜色尺寸信息
Private Sub DisplaySymbolProp()
    
    If m_pInputSymbol Is Nothing And m_pOutputSymbol Is Nothing Then Exit Sub
    
    Dim pSymbol As ISymbol
    If m_bControlStart = True Then Set pSymbol = m_pInputSymbol
    If m_bControlStart = False Then Set pSymbol = m_pOutputSymbol
    
    If m_strShapeType = "Fill Symbols" Then

        Dim pFillSymbol As IFillSymbol
        Set pFillSymbol = pSymbol
        picOutlineColor.BackColor = pFillSymbol.Outline.color.RGB
        picFillColor.BackColor = pFillSymbol.color.RGB
        txtOutLineSize.Text = CStr(pFillSymbol.Outline.Width)

    End If

    If m_strShapeType = "Line Symbols" Then

        Dim pLineSymbol As ILineSymbol
        Set pLineSymbol = pSymbol
        picLineOrPointColor.BackColor = pLineSymbol.color.RGB
        txtLineOrPointWidth.Text = pLineSymbol.Width

    End If

    If m_strShapeType = "Marker Symbols" Then

        Dim pMarkerSymbol As IMarkerSymbol
        Set pMarkerSymbol = pSymbol
        picLineOrPointColor.BackColor = pMarkerSymbol.color.RGB
        txtLineOrPointWidth = pMarkerSymbol.SIZE

    End If

End Sub

'控件初始化
Private Sub UserControl_Initialize()

    m_enumSymbolGeometryType = esriGeometryNull
    Set m_pStyleGallery = Nothing
    Set m_pOutputSymbol = Nothing
    m_bHasFillSymbolInFile = False
    m_bHasLineSymbolInFile = False
    m_bHasMarkerSymbolInFile = False
    m_bChangStyleFile = False
    m_bControlStart = True
    m_intTotalSymbolsNum = -1
    m_intSymbolID = 0
    m_bControlStart = True
    m_intLTSymbolID = 0
    m_intCurDisplayingSymbolsNum = 0
    m_bResetHscrollBar = True
    m_bHasSelectedOneSymbol = False
    m_bLoadFileFromOtherDirectory = False
    m_strLineOrPointWidth = ""
    m_strOutLineSize = ""

End Sub

'控件刚显示时发生
Private Sub UserControl_Show()

    '启动时显示
    If m_bControlStart = True Or m_bChangStyleFile = True Then

        '加载符号库（“.style”)
        If LoadSymbolsFromFiles = False Then Exit Sub

        '更新静态显示界面
        UpdateStaticDisplaying

        '更新动态显示界面
        UpdateDynamicDisplaying

        '更新启动标志（防止下拉框click函数在初始化时就执行）
        m_bControlStart = False

    End If

End Sub

'更改符号库
Private Sub cmbSymbolFiles_Click()

    '控件刚显示时，不执行该过程
    If m_bControlStart = True Then Exit Sub

    '释放上一个符号库文件内存
    Set m_pStyleGallery = Nothing
    
    Screen.MousePointer = ccHourglass
    
    '初始化控件
    UserControl_Initialize

    If cmbSymbolFiles.List(cmbSymbolFiles.ListIndex) = "其它" Then
        
        dlgCommon.Filter = "符号文件(*.serverstyle)|*.serverstyle"
        dlgCommon.ShowOpen
        
        If dlgCommon.FileName = "" Then GoTo Pos_End
        m_pStylePath = dlgCommon.FileName
        Dim strFileName As String
        Dim intPos As Integer
        intPos = InStrRev(m_pStylePath, "\")
        strFileName = Right(m_pStylePath, Len(m_pStylePath) - intPos)
        
        m_bLoadFileFromOtherDirectory = True
        
    End If

    '显示控件
    m_bChangStyleFile = True
    UserControl_Show
    
Pos_End:
    m_bControlStart = False
    Screen.MousePointer = vbDefault
    cmdDefaultValue.SetFocus

End Sub

'加载符号库（当前默认"forestry.serverstyle")
Private Function LoadSymbolsFromFiles() As Boolean

    Dim i As Long
    Dim pStylePath As String
    Dim pStyleGalleryStorage As IStyleGalleryStorage
    Set m_pStyleGallery = New ServerStyleGallery
    Debug.Assert Not m_pStyleGallery Is Nothing
    If m_pStyleGallery Is Nothing Then
        MsgBox "内存不足。"
        Exit Function
    End If

    '错误处理
    If m_pStyleGallery Is Nothing Then
        CatchErrors ErrorNoEnoughMemory
        LoadSymbolsFromFiles = False
        Set m_pStyleGallery = Nothing
        Exit Function
    End If

    Set pStyleGalleryStorage = m_pStyleGallery

    '加载符号库文件
    If m_bChangStyleFile = False Then

         '系统刚启动,加载默认文件
         m_pStylePath = App.Path & "\style" & "\forestry.serverStyle "

    Else

        If m_bLoadFileFromOtherDirectory = True Then

            m_bLoadFileFromOtherDirectory = False

        Else

            '“符号库”列表框是否为空(测试用，以后删除，不增加错误处理)
            If cmbSymbolFiles.ListCount = 0 Then
                CatchErrors ErrorNoSytleFileSelected
                LoadSymbolsFromFiles = False
                Set m_pStyleGallery = Nothing
                Exit Function
            Else
                '用户更改符号库文件（单击符号库下拉框）
                m_pStylePath = App.Path & "\style" & "\" & cmbSymbolFiles.List(cmbSymbolFiles.ListIndex)
            End If

        End If

    End If

    '未选择符号文件（针对“其它”选项）
    If m_pStylePath = "" Then
    
        LoadSymbolsFromFiles = False
        Set m_pStyleGallery = Nothing
        Exit Function
    
    End If
    
    '不能加栽文件
    pStyleGalleryStorage.AddFile m_pStylePath
    If pStyleGalleryStorage Is Nothing Then
        CatchErrors ErrirCanntLoadStyleFile
        LoadSymbolsFromFiles = False