uclayersymbol.ctl

arcengine+vb开发原码

    '计算可见符号个数
    CalculateSymbolsNum

    '得到符号(存于 m_pSymbolsArray 中)
    GetSymbols

    '显示符号（只显示可见的9个符号）
    Dim i As Integer
    i = 0
    
    For i = 0 To m_intCurDisplayingSymbolsNum - 1
            
        picShowSymbol(i).Visible = True
        SymbolName(i).Visible = True
        
         '画符号（包括显示名称）
         DrawSymbol i

    Next i
    
    For i = m_intCurDisplayingSymbolsNum To 8
    
        picShowSymbol(i).Visible = False
        SymbolName(i).Visible = False
    
    Next i

End Sub

'计算当前应该显示的符号个数（一般为9个）
Private Sub CalculateSymbolsNum()

    If m_intTotalSymbolsNum - m_intLTSymbolID < 9 Then
        m_intCurDisplayingSymbolsNum = m_intTotalSymbolsNum - m_intLTSymbolID
    Else
        m_intCurDisplayingSymbolsNum = 9
    End If

End Sub

'根据垂直滚动条位置，计算当前应显示的第一个符号ID（第一行，第一列，最左上角哪个）
Private Sub CalculateLTSymbolID()

    Dim dblTemp As Double

    '计算索引(不全？多余？)
    If m_intTotalSymbolsNum < 9 Then                                 '符号总数小于9（等于时？？？）
        m_intLTSymbolID = 0
        Exit Sub
    ElseIf vsbSymbol.Value = vsbSymbol.Max Then                      '滚动条处于最下边
        If m_intTotalSymbolsNum Mod 3 <> 0 Then
            dblTemp = (Int(m_intTotalSymbolsNum / 3) - 2) * 3
        End If
    Else                                                             '滚动条处于其它位置
        dblTemp = vsbSymbol.Value * 3
    End If

    m_intLTSymbolID = dblTemp

End Sub

'得到从指定索引开始的一定数量（一般为 9 个）的符号（存于m_SymbolArray）
Private Sub GetSymbols()

    '检查符号个数是否正确
    If m_intCurDisplayingSymbolsNum > 9 Or m_intCurDisplayingSymbolsNum < 1 Then
        CatchErrors ErrorVisibleSymbolsNum
        Exit Sub
    End If

    Dim pEnumStyleGalleryItem As IEnumStyleGalleryItem
    Set pEnumStyleGalleryItem = m_pStyleGallery.Items(m_strShapeType, m_pStylePath, "")
    Dim pStyleGalleryItem As IStyleGalleryItem
    Set pStyleGalleryItem = pEnumStyleGalleryItem.Next
    Dim strStyleClass As String
    strStyleClass = cmbGeometryType.List(cmbGeometryType.ListIndex)

    Dim pSymbol As ISymbol
    Dim i As Integer
    i = 0

    '得到符号（根据类型及ID）
    Select Case strStyleClass

        Case "面符号"

            Set pEnumStyleGalleryItem = m_pStyleGallery.Items("Fill Symbols", m_pStylePath, "")

            '不能打开符号库文件
            If pEnumStyleGalleryItem Is Nothing Then
                CatchErrors ErrirCanntLoadStyleFile
                Exit Sub
            End If

            Set pStyleGalleryItem = pEnumStyleGalleryItem.Next

           '符号库文件已经损坏
            If pStyleGalleryItem Is Nothing Then
                CatchErrors ErrorBadStyleFile
                Exit Sub
            End If

            Do While Not pStyleGalleryItem Is Nothing

                If TypeOf pStyleGalleryItem.Item Is IFillSymbol And pStyleGalleryItem.ID = m_intLTSymbolID + 1 Then
                    For i = 0 To m_intCurDisplayingSymbolsNum - 1
                        Set m_pSymbolsArray(i) = pStyleGalleryItem.Item
                        m_strSymbolNameArray(i) = pStyleGalleryItem.Name
                        m_strSymbolName = pStyleGalleryItem.Name
                        m_intSymbolID = pStyleGalleryItem.ID
                        Set pStyleGalleryItem = pEnumStyleGalleryItem.Next
                    Next i
                    GoTo endGetSymbol

                End If

                Set pStyleGalleryItem = pEnumStyleGalleryItem.Next

                '符号库文件已经损坏
                If pStyleGalleryItem Is Nothing Then
                    CatchErrors ErrorBadStyleFile
                    Exit Sub
                End If

            Loop

        Case "线符号"

            Set pEnumStyleGalleryItem = m_pStyleGallery.Items("Line Symbols", m_pStylePath, "")

            '不能打开符号库文件
            If pEnumStyleGalleryItem Is Nothing Then
                CatchErrors ErrirCanntLoadStyleFile
                Exit Sub
            End If

            Set pStyleGalleryItem = pEnumStyleGalleryItem.Next

            '符号库文件已经损坏
            If pStyleGalleryItem Is Nothing Then
                CatchErrors ErrorBadStyleFile
                Exit Sub
            End If

            Do While Not pStyleGalleryItem Is Nothing
                If TypeOf pStyleGalleryItem.Item Is ILineSymbol And pStyleGalleryItem.ID = m_intLTSymbolID + 1 Then
                    For i = 0 To m_intCurDisplayingSymbolsNum - 1
                        Set m_pSymbolsArray(i) = pStyleGalleryItem.Item
                        m_strSymbolNameArray(i) = pStyleGalleryItem.Name
                        m_strSymbolName = pStyleGalleryItem.Name
                        m_intSymbolID = pStyleGalleryItem.ID
                        Set pStyleGalleryItem = pEnumStyleGalleryItem.Next
                    Next i
                    GoTo endGetSymbol
                End If
                Set pStyleGalleryItem = pEnumStyleGalleryItem.Next
            Loop

        Case "点符号"

            Set pEnumStyleGalleryItem = m_pStyleGallery.Items("Marker Symbols", m_pStylePath, "")

            '不能打开符号库文件
            If pEnumStyleGalleryItem Is Nothing Then
                CatchErrors ErrirCanntLoadStyleFile
                Exit Sub
            End If

            Set pStyleGalleryItem = pEnumStyleGalleryItem.Next

            '符号库文件已经损坏
            If pStyleGalleryItem Is Nothing Then
                CatchErrors ErrorBadStyleFile
                Exit Sub
            End If

            Do While Not pStyleGalleryItem Is Nothing
                If TypeOf pStyleGalleryItem.Item Is IMarkerSymbol And pStyleGalleryItem.ID = m_intLTSymbolID + 1 Then
                    For i = 0 To m_intCurDisplayingSymbolsNum - 1
                        Set m_pSymbolsArray(i) = pStyleGalleryItem.Item
                        m_strSymbolNameArray(i) = pStyleGalleryItem.Name
                        m_strSymbolName = pStyleGalleryItem.Name
                        m_intSymbolID = pStyleGalleryItem.ID
                        Set pStyleGalleryItem = pEnumStyleGalleryItem.Next
                    Next i
                    GoTo endGetSymbol
                End If
                Set pStyleGalleryItem = pEnumStyleGalleryItem.Next
            Loop

    End Select

endGetSymbol:

End Sub

'画符号
Private Sub DrawSymbol(i As Integer)

    '检查左上角符号索引是否正确
    If m_intLTSymbolID > m_intTotalSymbolsNum - 1 Or m_intLTSymbolID < 0 Or (m_intLTSymbolID Mod 3) <> 0 Then
        CatchErrors ErrorLTSymbolID
        Exit Sub
    End If

    '检查符号个数是否正确
    If m_intCurDisplayingSymbolsNum > 9 Or m_intCurDisplayingSymbolsNum < 1 Then
        CatchErrors ErrorVisibleSymbolsNum
        Exit Sub
    End If

    '检查符号索引是否正确
    If i > 9 Or i < 0 Then
        CatchErrors ErrorDisplaySymbol
        Exit Sub
    End If

    '显示符号名称
    SymbolName(i).Caption = m_strSymbolNameArray(i)

    '画出符号
    On Error GoTo errH
'    Dim strTemp As String
'    strTemp = CStr(m_intSymbolID)
    Dim bResult As Boolean

    bResult = DrawToDC(picShowSymbol(i).hdc, picShowSymbol(i).ScaleWidth, picShowSymbol(i).ScaleHeight, m_pSymbolsArray(i), 2)
    If bResult = False Then CatchErrors ErrorPreview
    picShowSymbol(i).Refresh

errH:
    If Err.Number <> 0 Then
    If Not m_pSymbolsArray(i) Is Nothing Then
      m_pSymbolsArray(i).ResetDC
    End If
    End If

End Sub

'改变线符号或点符号的尺寸
Private Sub txtLineOrPointWidth_Change()
    
    If txtLineOrPointWidth.Text = "" Or txtLineOrPointWidth.Text = "0" Then Exit Sub
    
    '更新符号尺寸
    UpdateSymbolProp

End Sub

Private Sub txtLineOrPointWidth_KeyPress(KeyAscii As Integer)

    Select Case KeyAscii
        Case Asc("0") To Asc("9"), vbKeyBack
        Case Else
        KeyAscii = 0
    End Select
    
End Sub

'更改轮廓线尺寸
Private Sub txtOutLineSize_Change()

    If txtOutLineSize.Text = "" Or txtOutLineSize.Text = "0" Then Exit Sub
    
    '更新符号尺寸
    UpdateSymbolProp

End Sub

Private Sub txtOutLineSize_KeyPress(KeyAscii As Integer)

    Select Case KeyAscii
        Case Asc("0") To Asc("9"), vbKeyBack
        Case Else
        KeyAscii = 0
    End Select
    
End Sub


Private Sub picOutlineColor_Click()

    dlgCommon.ShowColor
    picOutlineColor.BackColor = dlgCommon.color

    '更新符号属性
    UpdateSymbolProp

End Sub

'选择面符号填充颜色
Private Sub picFillColor_Click()

    dlgCommon.ShowColor
    picFillColor.BackColor = dlgCommon.color

    '更新符号属性
    UpdateSymbolProp

End Sub

'选择线符号或点符号的颜色
Private Sub picLineOrPointColor_Click()

    dlgCommon.ShowColor
    picLineOrPointColor.BackColor = dlgCommon.color

    '更新符号属性
    UpdateSymbolProp

End Sub

'更新符号属性
Private Sub UpdateSymbolProp()
    
    Dim pColor As IColor
    Dim pLineSymbol As ILineSymbol
    Dim pFillSymbol As IFillSymbol
    Dim pMarkerSymbol As IMarkerSymbol
    Dim bResult As Boolean
    
    '更新符号PictureBox中的符号
    If m_bHasSelectedOneSymbol = True Then

        '面符号
        If m_strShapeType = "Fill Symbols" Then

            Set pFillSymbol = m_pOutputSymbol
            Set pColor = pFillSymbol.color

            '填充颜色
            pColor.RGB = picFillColor.BackColor
            pFillSymbol.color = pColor

            '轮廓线颜色
            Set pLineSymbol = pFillSymbol.Outline
            Set pColor = pLineSymbol.color
            pColor.RGB = picOutlineColor.BackColor
            pLineSymbol.color = pColor
            pLineSymbol.Width = txtOutLineSize.Text
            pFillSymbol.Outline = pLineSymbol

        End If

        '线符号
        If m_strShapeType = "Line Symbols" Then

            Set pLineSymbol = m_pOutputSymbol
            Set pColor = pLineSymbol.color

            pColor.RGB = picLineOrPointColor.BackColor
            pLineSymbol.color = pColor
            pLineSymbol.Width = txtLineOrPointWidth.Text

        End If

        '点符号
        If m_strShapeType = "Marker Symbols" Then

            Set pMarkerSymbol = m_pOutputSymbol
            Set pColor = pMarkerSymbol.color
            pColor.RGB = picLineOrPointColor.BackColor
            pMarkerSymbol.color = pColor
            pMarkerSymbol.SIZE = txtLineOrPointWidth

        End If

        '显示
        m_pOutputSymbol.ResetDC
        bResult = DrawToDC(picPreview.hdc, picPreview.ScaleWidth, picPreview.ScaleHeight, m_pOutputSymbol)
        picPreview.Refresh
        If bResult = False Then CatchErrors ErrorPreview

    Else '更新输入的符号（参数传进来的）
        
        Debug.Assert Not m_pInputSymbol Is Nothing
        If m_pInputSymbol Is Nothing Then Exit Sub
        
        '面符号
        If m_strShapeType = "Fill Symbols" Then
        
            Set pFillSymbol = m_pInputSymbol
            Set pColor = pFillSymbol.color
            
            '填充颜色
            pColor.RGB = picFillColor.BackColor
            pFillSymbol.color = pColor
            
            '轮廓线颜色
            Set pLineSymbol = pFillSymbol.Outline
            Set pColor = pLineSymbol.color
            pColor.RGB = picOutlineColor.BackColor
            pLineSymbol.color = pColor
            pLineSymbol.Width = txtOutLineSize.Text
            pFillSymbol.Outline = pLineSymbol
        
        End If
        
        '线符号
        If m_strShapeType = "Line Symbols" Then
        
            Set pLineSymbol = m_pInputSymbol
            Set pColor = pLineSymbol.color
            
            pColor.RGB = picLineOrPointColor.BackColor
            pLineSymbol.color = pColor
            pLineSymbol.Width = txtLineOrPointWidth.Text
            
        End If
        
        '点符号
        If m_strShapeType = "Marker Symbols" Then
        
            Set pMarkerSymbol = m_pInputSymbol
            Set pColor = pMarkerSymbol.color
            pColor.RGB = picLineOrPointColor.BackColor
            pMarkerSymbol.color = pColor
            pMarkerSymbol.SIZE = txtLineOrPointWidth
        
        End If
        
        '显示
        m_pInputSymbol.ResetDC
        bResult = DrawToDC(picPreview.hdc, picPreview.ScaleWidth, picPreview.ScaleHeight, m_pInputSymbol)
        picPreview.Refresh
        If bResult = False Then CatchErrors ErrorPreview
        
    End If

End Sub

'搜索默认符号库目录下符号库文件
Private Sub GetStyleFile()
    
    '删除以前符号库文件
    cmbSymbolFiles.Clear
    
    Dim intDefaultStyleFileIndex As Integer
    intDefaultStyleFileIndex = 0
    Dim strStyleFilesPath As String
    Dim StyleFileName As String
    strStyleFilesPath = App.Path & "\style"
    StyleFileName = Dir(strStyleFilesPath & "\*.serverstyle")
    
    Dim i As Integer
    i = 0
    
    Do While StyleFileName <> ""
        cmbSymbolFiles.AddItem StyleFileName
        i = i + 1
        If UCase(StyleFileName) = "FORESTRY.SERVERSTYLE" Then intDefaultStyleFileIndex = i
        StyleFileName = Dir
    Loop

    cmbSymbolFiles.AddItem "其它"
    cmbSymbolFiles.ListIndex = intDefaultStyleFileIndex - 1

End Sub