frmtheme.frm

arcengine+vb开发原码

    Dim vntCodeValue As Variant
    Dim vntTempValue As Variant
    
    Debug.Assert Not m_pMap Is Nothing
    If m_pMap Is Nothing Then Exit Sub
    Debug.Assert Not lstMapLayers.Text = ""
    If lstMapLayers.Text = "" Then Exit Sub
    If cmbFields.Text = "" Then Exit Sub
    
    Screen.MousePointer = vbHourglass
    Set pTable = m_pGeoFeatureLayer
    fieldNumber = pTable.FindField(cmbFields.Text)
    Debug.Assert fieldNumber > -1
    If fieldNumber = -1 Then Exit Sub
    
    Dim pColorRamp As IRandomColorRamp
    Set pColorRamp = New RandomColorRamp
    Debug.Assert Not pColorRamp Is Nothing
    If pColorRamp Is Nothing Then Exit Sub

    '选择色带
    Dim i As Integer
    For i = 0 To 2
        If imgcboColorRamp.SelectedItem.Index = i + 1 Then
            pColorRamp.StartHue = m_intColorRampArray(i, 0)
            pColorRamp.EndHue = m_intColorRampArray(i, 1)
            
            pColorRamp.MinValue = m_intColorRampArray(i, 2)
            pColorRamp.maxValue = m_intColorRampArray(i, 3)
            
            pColorRamp.MinSaturation = m_intColorRampArray(i, 4)
            pColorRamp.MaxSaturation = m_intColorRampArray(i, 5)
        End If
    Next i
    
    pColorRamp.SIZE = 100
    pColorRamp.CreateRamp True
    Set pEnumRamp = pColorRamp.Colors
    Set pNextUniqueColor = Nothing
    
    Set pQueryFilter = New QueryFilter
    pQueryFilter.AddField cmbFields.Text
    Set pCursor = pTable.Search(pQueryFilter, True)
    Set pNextRow = pCursor.NextRow

    m_intSymbolsNum = 0
    
    '面图层
    If m_strShapeType = "Fill Symbols" Then
            
        Dim pFillSymbol As IFillSymbol
        
        Set m_pSymbolsArray = Nothing
        Set m_pSymbolsArray = New esriSystem.Array
        Debug.Assert Not m_pSymbolsArray Is Nothing
        If m_pSymbolsArray Is Nothing Then Exit Sub
        
        Set m_colValues = Nothing
        Set m_colValues = New Collection
        Debug.Assert Not m_colValues Is Nothing
        If m_colValues Is Nothing Then Exit Sub
        
        Do While Not pNextRow Is Nothing
        
            Set pNextRowBuffer = pNextRow
            vntCodeValue = pNextRowBuffer.Value(fieldNumber)
            
            If Not (vntTempValue = vntCodeValue) Or m_intSymbolsNum = 0 Then
            
                Set pNextUniqueColor = pEnumRamp.Next
                If pNextUniqueColor Is Nothing Then
                    pEnumRamp.Reset
                    Set pNextUniqueColor = pEnumRamp.Next
                End If
                
                Set pFillSymbol = New SimpleFillSymbol
                Debug.Assert Not pFillSymbol Is Nothing
                If pFillSymbol Is Nothing Then Exit Sub
                
                pFillSymbol.color = pNextUniqueColor
                m_pSymbolsArray.Add pFillSymbol
                m_colValues.Add vntCodeValue
                m_intSymbolsNum = m_intSymbolsNum + 1
                   
                vntTempValue = vntCodeValue
                Set pFillSymbol = Nothing
                
            End If
            
            Set pNextRow = pCursor.NextRow
            
        Loop
         
    End If
    
    '线图层
    If m_strShapeType = "Line Symbols" Then

        Dim pLineSymbol As ILineSymbol
        
        Set m_pSymbolsArray = Nothing
        Set m_pSymbolsArray = New esriSystem.Array
        Debug.Assert Not m_pSymbolsArray Is Nothing
        If m_pSymbolsArray Is Nothing Then Exit Sub
        
        Set m_colValues = Nothing
        Set m_colValues = New Collection
        Debug.Assert Not m_colValues Is Nothing
        If m_colValues Is Nothing Then Exit Sub
        
        Do While Not pNextRow Is Nothing
        
            Set pNextRowBuffer = pNextRow
            vntCodeValue = pNextRowBuffer.Value(fieldNumber)
            
            If Not (vntTempValue = vntCodeValue) Or m_intSymbolsNum = 0 Then
            
                Set pNextUniqueColor = pEnumRamp.Next
                If pNextUniqueColor Is Nothing Then
                    pEnumRamp.Reset
                    Set pNextUniqueColor = pEnumRamp.Next
                End If
                
                Set pLineSymbol = New SimpleLineSymbol
                Debug.Assert Not pLineSymbol Is Nothing
                If pLineSymbol Is Nothing Then Exit Sub
                
                pLineSymbol.color = pNextUniqueColor
                m_pSymbolsArray.Add pLineSymbol
                m_colValues.Add vntCodeValue
                m_intSymbolsNum = m_intSymbolsNum + 1
                
                vntTempValue = vntCodeValue
                Set pLineSymbol = Nothing
            
            End If
            
            Set pNextRow = pCursor.NextRow
            
        Loop
            
    End If
    
    '点图层
    If m_strShapeType = "Marker Symbols" Then
        
        Dim pMarkerSymbol As IMarkerSymbol
        
        Set m_pSymbolsArray = Nothing
        Set m_pSymbolsArray = New esriSystem.Array
        Debug.Assert Not m_pSymbolsArray Is Nothing
        If m_pSymbolsArray Is Nothing Then Exit Sub
        
        Set m_colValues = Nothing
        Set m_colValues = New Collection
        Debug.Assert Not m_colValues Is Nothing
        If m_colValues Is Nothing Then Exit Sub
        
        Do While Not pNextRow Is Nothing
        
            Set pNextRowBuffer = pNextRow
            vntCodeValue = pNextRowBuffer.Value(fieldNumber)
            
            If Not (vntTempValue = vntCodeValue) Or m_intSymbolsNum = 0 Then
            
                Set pNextUniqueColor = pEnumRamp.Next
                If pNextUniqueColor Is Nothing Then
                    pEnumRamp.Reset
                    Set pNextUniqueColor = pEnumRamp.Next
                End If
                
                Set pMarkerSymbol = New SimpleMarkerSymbol
                Debug.Assert Not pMarkerSymbol Is Nothing
                If pMarkerSymbol Is Nothing Then Exit Sub
                
                pMarkerSymbol.color = pNextUniqueColor
                m_pSymbolsArray.Add pMarkerSymbol
                m_colValues.Add vntCodeValue
                m_intSymbolsNum = m_intSymbolsNum + 1
                
                Set pLineSymbol = Nothing

            End If
            
            Set pNextRow = pCursor.NextRow
            
        Loop
        
     End If
     
     Set pColorRamp = Nothing
     Set pQueryFilter = Nothing
     Set pColorRamp = Nothing
     
    '显示符号
    cmdApply.Enabled = True
    DisplaySymbols
    
    Screen.MousePointer = vbDefault

End Sub

'显示符号
Private Sub DisplaySymbols()
    
    Dim pEnumVariantSimple As IEnumVariantSimple
    Set pEnumVariantSimple = GetUniqueValue(cmbFields.List(cmbFields.ListIndex), m_pMap, m_pGeoFeatureLayer.Name, m_pGeoFeatureLayer)
    Dim vntUniqueValue As Variant
    
    Dim pSymbol As ISymbol
    Dim i As Integer
    Dim hBmpNew As Long
    
    lvwSymbol.ListItems.Clear
    lvwSymbol.Refresh
    
    '使用第一个imagelist
    If m_bChangeImageList = False Then
    
        If m_intSymbolsNum > 4000 Then
            MsgBox "当前需要生成的符号总数太多（大于4000），无法显示"
            cmdApply.Enabled = False
            Exit Sub
        End If
        
        For i = 0 To m_intSymbolsNum - 1
            Set pSymbol = m_pSymbolsArray.Element(i)
            picTemp.Picture = CreatePictureFromSymbol(picTemp.hdc, hBmpNew, pSymbol, picTemp.ScaleWidth, picTemp.ScaleHeight, -1)
            
            Debug.Assert Not picTemp.Picture Is Nothing
            If picTemp.Picture Is Nothing Then Exit Sub
            
            With iltFirst
            .ImageWidth = 64
            .ImageHeight = 18
            .ListImages.Add , , picTemp.Picture
            End With
        Next i
        
        vntUniqueValue = pEnumVariantSimple.Next
        For i = 1 To m_intSymbolsNum
            With lvwSymbol
            .Arrange = lvwAutoTop
            .BackColor = vbWhite
            .LabelEdit = lvwManual
            .SmallIcons = iltFirst
            .ListItems.Add , , "", , i
            .ListItems(i).SubItems(1) = vntUniqueValue
            .ListItems(i).SubItems(2) = CStr(i)
            End With
            vntUniqueValue = pEnumVariantSimple.Next
        Next i
        
        Dim intTemp As Integer
        intTemp = iltSecond.ListImages.Count
        iltSecond.ListImages.Clear
        m_bChangeImageList = True
        
    ElseIf m_bChangeImageList = True Then '使用第二个imagelist
    
        If m_intSymbolsNum > 4000 Then
            MsgBox "当前需要生成的符号总数太多(大于4000)，无法显示"
            cmdApply.Enabled = False
            Exit Sub
        End If
        
        For i = 0 To m_intSymbolsNum - 1
            Set pSymbol = m_pSymbolsArray.Element(i)
            picTemp.Picture = CreatePictureFromSymbol(picTemp.hdc, hBmpNew, pSymbol, picTemp.ScaleWidth, picTemp.ScaleHeight, -1)
            
            Debug.Assert Not picTemp.Picture Is Nothing
            If picTemp.Picture Is Nothing Then Exit Sub
            picTemp.Refresh
            
            With iltSecond
            .ImageWidth = 64
            .ImageHeight = 18
            .ListImages.Add , , picTemp.Picture
            End With
        Next i
        
        vntUniqueValue = pEnumVariantSimple.Next
        For i = 1 To m_intSymbolsNum
            With lvwSymbol
            .Arrange = lvwAutoTop
            .BackColor = vbWhite
            .LabelEdit = lvwManual
            .SmallIcons = iltSecond
            .ListItems.Add , , "", , i
            .ListItems(i).SubItems(1) = vntUniqueValue
            .ListItems(i).SubItems(2) = CStr(i)
            End With
            vntUniqueValue = pEnumVariantSimple.Next
        Next i
        
        intTemp = iltFirst.ListImages.Count
        iltFirst.ListImages.Clear
        m_bChangeImageList = False
        
    End If

End Sub

'着色、刷新图层
Private Sub cmdApply_Click()
    
    cmdApply.Enabled = False
    
    Screen.MousePointer = vbHourglass
    
    '着色
    If m_colValues Is Nothing Or m_pSymbolsArray Is Nothing Then Exit Sub
    
    Dim pUniqueValueRenderer As IUniqueValueRenderer
    Set pUniqueValueRenderer = New UniqueValueRenderer
    Debug.Assert Not pUniqueValueRenderer Is Nothing
    If pUniqueValueRenderer Is Nothing Then Exit Sub
    
    pUniqueValueRenderer.FieldCount = 1
    pUniqueValueRenderer.Field(0) = cmbFields.Text
    
    Dim i As Integer
    Dim pSymbol As ISymbol
    
    For i = 0 To m_intSymbolsNum - 1
        Set pSymbol = m_pSymbolsArray.Element(i)
        pUniqueValueRenderer.AddValue m_colValues.Item(i + 1), m_colValues.Item(i + 1), pSymbol
    Next i
    
    '刷新
    Set m_pGeoFeatureLayer.Renderer = pUniqueValueRenderer
    frmMapControl.arcMapControl.Refresh esriViewGeography
    frmMapControl.ArcTOCControl.Update
    Set pUniqueValueRenderer = Nothing
    Screen.MousePointer = vbDefault
    
End Sub

'着色、刷新图层、退出
Private Sub cmdOk_Click()
    If cmdApply.Enabled = True Then cmdApply_Click
    Unload Me
End Sub

Private Sub lvwSymbol_DblClick()
    m_bChangeSymbol = True
End Sub

'更改符号
Private Sub lvwSymbol_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Dim liClicked As ListItem
    Dim intSymbolIndex As Integer
    Dim pSymbol As ISymbol
    
    If m_bChangeSymbol = True Then
        If (Button = vbLeftButton) Then
                
            m_bChangeSymbol = False
            Set liClicked = lvwSymbol.HitTest(X, Y)
            If liClicked Is Nothing Then Exit Sub
            
            '以后选择符号时，传入图层类型？？？
            intSymbolIndex = liClicked.Index
            frmSymbolSelector.Symbol = m_pSymbolsArray.Element(intSymbolIndex - 1)
            frmSymbolSelector.Show 1
            
            Set pSymbol = frmSymbolSelector.Symbol
            Debug.Assert Not m_strShapeType = ""
            If pSymbol Is Nothing Or m_strShapeType = "" Then Exit Sub
            
            If m_strShapeType = "Fill Symbols" And (Not TypeOf pSymbol Is IFillSymbol) Then
                MsgBox "图层类型不匹配。"
                Exit Sub
            End If
            
            If m_strShapeType = "Line Symbols" And (Not TypeOf pSymbol Is ILineSymbol) Then
                MsgBox "图层类型不匹配。"
                Exit Sub
            End If
            
            If m_strShapeType = "Marker Symbols" And (Not TypeOf pSymbol Is IMarkerSymbol) Then
                MsgBox "图层类型不匹配。"
                Exit Sub
            End If
            
            If pSymbol Is Nothing Then Exit Sub
            
            m_pSymbolsArray.Remove (intSymbolIndex - 1)
            m_pSymbolsArray.Insert intSymbolIndex - 1, pSymbol
            
            '更新列表框符号显示（目前全部重画，以后只画修改的）
            DisplaySymbols
            cmdApply.Enabled = True
                
        End If
    End If
    
End Sub

Public Function GetFeatureLayer(ByVal slayer As String, ByVal m_pMap As IMap) As IFeatureLayer
    
    Set GetFeatureLayer = Nothing
    
    Dim pLayers As IEnumLayer '枚举图层接口
    Dim pLayer As ILayer '图层接口
    
    On Error GoTo errorhandle
    
    If m_pMap.LayerCount = 0 Then Exit Function
    
    Set pLayers = m_pMap.Layers
    Set pLayer = pLayers.Next
    
    Do While Not pLayer Is Nothing
        
        If TypeOf pLayer Is IFeatureLayer And UCase(slayer) = UCase(pLayer.Name) Then '找到要素图层
            
            Set GetFeatureLayer = pLayer
            Exit Function
        
        End If
        
        Set pLayer = pLayers.Next
        
    Loop
    
    Set pLayer = Nothing
    Set pLayers = Nothing
    
    Exit Function
errorhandle:
    
    Set GetFeatureLayer = Nothing
    
End Function