?? uclayersymbol.ctl

?? arcengine+vb開發原碼
?? CTL
?? 第 1 頁 / 共 4 頁
字號:
上一頁 1 2 34

    '計算可見符號個數
    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
上一頁 1 2 34
?? 文件大小 477 K
?? 上傳用戶 moxcki
?? 所屬分類其他
??? 相關標簽

#arcengine #vb
?? 快捷鍵說明

復制代碼 Ctrl + C
搜索代碼 Ctrl + F
全屏模式 F11
切換主題 Ctrl + Shift + D
顯示快捷鍵 ?
增大字號 Ctrl + =
減小字號 Ctrl + -
亚洲欧美第一页_禁久久精品乱码_粉嫩av一区二区三区免费野_久草精品视频

?? uclayersymbol.ctl

?? 快捷鍵說明
