mod_symbol.bas

arcengine+vb开发原码

Attribute VB_Name = "ModSymbol"
Option Explicit
'功能：符号预览

Public Const COLORONCOLOR = 3

Public Const HORZSIZE = 4
Public Const VERTSIZE = 6
Public Const HORZRES = 8
Public Const VERTRES = 10
Public Const ASPECTX = 40
Public Const ASPECTY = 42
Public Const LOGPIXELSX = 88
Public Const LOGPIXELSY = 90

Public Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(7) As Byte
End Type

Public Type PicDesc
  SIZE As Long
  Type As Long
  hBmp As Long
  hPal As Long
  Reserved As Long
End Type

Public Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Public Type SIZE
  X As Long
  Y As Long
End Type

Public Type POINTAPI
  X As Long
  Y As Long
End Type

Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (pDesc As PicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, pPic As IPicture) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function FillRect Lib "USER32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Public Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Public Declare Function GetDC Lib "USER32" (ByVal hWnd As Long) As Long
Public Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Public Declare Function GetWindowExtEx Lib "gdi32" (ByVal hdc As Long, lpSize As SIZE) As Long
Public Declare Function GetViewportExtEx Lib "gdi32" (ByVal hdc As Long, lpSize As SIZE) As Long
Public Declare Function GetMapMode Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function LPtoDP Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Public Declare Function GetClientRect Lib "USER32" (ByVal hWnd As Long, lpRect As RECT) As Long

Public Function SaveSymbolToBitmapFile(ByVal hDCOld As Long, ByVal pSymbol As ISymbol, ByVal lWidth As Long, ByVal lHeight As Long, ByVal sFilePath As String, Optional lGap As Long = 0) As Boolean

  On Error GoTo errH
    
  SaveSymbolToBitmapFile = False
    
  Dim pPicture As IPicture, hBmpNew As Long
  Set pPicture = CreatePictureFromSymbol(hDCOld, hBmpNew, pSymbol, lWidth, lHeight, lGap)
  If Not pPicture Is Nothing Then
    SavePicture pPicture, sFilePath
    DeleteObject hBmpNew
    SaveSymbolToBitmapFile = True
  End If
  
Exit Function
errH:
  If Err.Number <> 0 Then
    Dim sError As String, lError As Long
    sError = Err.Description
    lError = Err.Number
    Err.Clear
    Err.Raise vbObjectError + 7020, "basDrawSymbol.SaveSymbolToBitmapFile", "Error occured while saving to bitmap file." & vbNewLine & "Error " & CStr(lError) & sError
  End If
End Function

Public Function CreatePictureFromSymbol(ByVal hDCOld As Long, ByRef hBmpNew As Long, ByVal pSymbol As ISymbol, ByVal lWidth As Long, ByVal lHeight As Long, Optional lGap As Long = 0) As IPictureDisp
  On Error GoTo errH
  
  Dim hDCNew As Long, hBmpOld As Long
  hDCNew = CreateCompatibleDC(hDCOld)
  hBmpNew = CreateCompatibleBitmap(hDCOld, lWidth, lHeight)
  hBmpOld = SelectObject(hDCNew, hBmpNew)
  
  Dim lResult As Long
  lResult = DrawToDC(hDCNew, lWidth, lHeight, pSymbol, lGap)
  
  hBmpNew = SelectObject(hDCNew, hBmpOld)
  DeleteDC hDCNew

  Set CreatePictureFromSymbol = CreatePictureFromBitmap(hBmpNew)

Exit Function
errH:
  If Err.Number <> 0 Then
    If Not pSymbol Is Nothing Then
      pSymbol.ResetDC
      If hBmpNew <> 0 And hDCNew <> 0 And hBmpOld <> 0 Then
        hBmpNew = SelectObject(hDCNew, hBmpOld)
        DeleteDC hDCNew
      End If
    End If
  End If
End Function

Private Function CreatePictureFromBitmap(ByVal hBmpNew As OLE_HANDLE) As IPictureDisp
  Dim pic As PicDesc
  Dim pPic As IPicture
  Dim IID_IDispatch As GUID

  With IID_IDispatch
     .Data1 = &H20400
     .Data4(0) = &HC0
     .Data4(7) = &H46
  End With

  With pic
     .SIZE = Len(pic)
     .Type = vbPicTypeBitmap
     .hBmp = hBmpNew
     .hPal = 0
  End With

  Dim Result As Long
  Result = OleCreatePictureIndirect(pic, IID_IDispatch, True, pPic)
  Debug.Print "Result OLE call: " & Result
  
  Set CreatePictureFromBitmap = pPic
End Function

Public Function DrawToWnd(ByVal hWnd As OLE_HANDLE, ByVal pSymbol As ISymbol, Optional lGap As Long = 0) As Boolean
  On Error GoTo errH
  
  DrawToWnd = False
  
  Dim hdc As OLE_HANDLE
  If hWnd <> 0 Then
           
    Dim udtRect As RECT, lResult  As Long
    lResult = GetClientRect(hWnd, udtRect)
    
    If lResult <> 0 Then
      Dim lWidth As Long, lHeight As Long
      lWidth = udtRect.Right - udtRect.Left
      lHeight = udtRect.Bottom - udtRect.Top
      
      hdc = GetDC(hWnd)
      If hdc <> 0 Then
        DrawToWnd = DrawToDC(hdc, lWidth, lHeight, pSymbol, lGap)
      End If
      ReleaseDC hWnd, hdc
    End If
  End If

Exit Function
errH:
  If Err.Number <> 0 Then
    If Not pSymbol Is Nothing Then
      pSymbol.ResetDC
    End If
    If hWnd <> 0 And hdc <> 0 Then
      ReleaseDC hWnd, hdc
    End If
    Exit Function
  End If
End Function

Public Function DrawToDC(ByVal hdc As OLE_HANDLE, lWidth As Long, lHeight As Long, ByVal pSymbol As ISymbol, Optional lGap As Long = 0) As Boolean
  On Error GoTo errH
  
  DrawToDC = False
  
  If hdc <> 0 Then
  
    If Not Clear(hdc, &HFFFFFF, 0, 0, lWidth, lHeight) Then
      Err.Raise vbObjectError + 7002, "basDrawSymbol.DrawToDC", "Could not clear the Device Context."
      Exit Function
    End If
            
    Dim pEnvelope As IEnvelope, pTransformation As ITransformation, pGeom As IGeometry
    Set pEnvelope = New Envelope
    pEnvelope.PutCoords lGap, lGap, lWidth - lGap, lHeight - lGap
    Set pTransformation = CreateTransFromDC(hdc, lWidth, lHeight)
    Set pGeom = CreateSymShape(pSymbol, pEnvelope)
    
    If Not pTransformation Is Nothing And Not pGeom Is Nothing Then
      pSymbol.SetupDC hdc, pTransformation
      pSymbol.Draw pGeom
      pSymbol.ResetDC
      DrawToDC = True
    Else
      Err.Raise vbObjectError + 7008, "basDrawSymbol.DrawToDC", "Could not create required Transformation or Geometry for this draw operation."
    End If
  End If

Exit Function
errH:
  If Err.Number <> 0 Then
    If Not pSymbol Is Nothing Then
      pSymbol.ResetDC
    End If
  End If
End Function

Private Function Clear(ByVal hdc As Long, ByVal backgroundColor As Long, ByVal xMin As Long, ByVal yMin As Long, ByVal xMax As Long, ByVal yMax As Long) As Boolean
  
  On Error GoTo errH
  
  Dim hBrushBackground As Long, udtBounds As RECT, lResult  As Long
  With udtBounds
    .Left = xMin
    .Top = yMin
    .Right = xMax
    .Bottom = yMax
  End With
  
  hBrushBackground = CreateSolidBrush(backgroundColor)
  If hBrushBackground = 0 Then
    Err.Raise vbObjectError + 7003, "basDrawSymbol.Clear", "Could not create GDI Brush."
    Exit Function
  End If
  
  lResult = FillRect(hdc, udtBounds, hBrushBackground)
  If hBrushBackground = 0 Then
    Err.Raise vbObjectError + 7004, "basDrawSymbol.Clear", "Could not fill Device Context."
  End If
    
  lResult = DeleteObject(hBrushBackground)
  If hBrushBackground = 0 Then
    Err.Raise vbObjectError + 7005, "basDrawSymbol.Clear", "Could not delete GDI Brush."
  End If
  
  Clear = True
  
Exit Function
errH:
  If Err.Number <> 0 Then
    Clear = False
    If hBrushBackground <> 0 Then
      lResult = DeleteObject(hBrushBackground)
    End If
  End If
End Function

Private Function CreateTransFromDC(ByVal hdc As Long, ByVal lWidth As Long, ByVal lHeight As Long) As ITransformation
  
  On Error GoTo errH
  
  Dim pBoundsEnvelope As IEnvelope
  Set pBoundsEnvelope = New Envelope
  pBoundsEnvelope.PutCoords 0, 0, lWidth, lHeight
  
  Dim deviceRect As tagRECT
  With deviceRect
    .Left = 0
    .Top = 0
    .Right = lWidth
    .Bottom = lHeight
  End With
  
  Dim dpi As Long
  dpi = GetDeviceCaps(hdc, LOGPIXELSY)
  If dpi = 0 Then
    Err.Raise vbObjectError + 7006, "basDrawSymbol.CreateTransFromDC", "Could not retrieve Resolution from device context."
    Exit Function
  End If
  
  Dim pDisplayTransformation As IDisplayTransformation
  Set CreateTransFromDC = New DisplayTransformation
  Set pDisplayTransformation = CreateTransFromDC
  With pDisplayTransformation
    .VisibleBounds = pBoundsEnvelope
    .Bounds = pBoundsEnvelope
    .DeviceFrame = deviceRect
    .Resolution = dpi
  End With

Exit Function
errH:
  If Err.Number <> 0 Then
    Set CreateTransFromDC = Nothing
  End If
End Function

Private Function CreateSymShape(ByVal pSymbol As ISymbol, ByVal pEnvelope As IEnvelope) As IGeometry
  
  On Error GoTo errH
  
  If TypeOf pSymbol Is IMarkerSymbol Then
    Dim pArea As IArea
    Set pArea = pEnvelope
    Set CreateSymShape = pArea.Centroid
  ElseIf TypeOf pSymbol Is ILineSymbol Or TypeOf pSymbol Is ITextSymbol Then
    Dim pPolyline As IPolyline
    Set pPolyline = New Polyline
    pPolyline.FromPoint = pEnvelope.LowerLeft
    pPolyline.ToPoint = pEnvelope.UpperRight
    Set CreateSymShape = pPolyline
  Else
    Set CreateSymShape = pEnvelope
  End If
  
Exit Function
errH:
  If Err.Number <> 0 Then
    Set CreateSymShape = Nothing
  End If
End Function

Public Function GetLayerSymbols(pLayer As ILayer) As IArray

    If pLayer Is Nothing Then Exit Function
    
    Dim i As Integer
            
    Dim pGeoFeatureLayer As IGeoFeatureLayer
    Set pGeoFeatureLayer = pLayer
    If pGeoFeatureLayer Is Nothing Then Exit Function
    Dim pMySymbolArray  As ISymbolArray
    
    Dim pSymbolArray As IArray
    Set pSymbolArray = New esriSystem.Array
    Debug.Assert Not pSymbolArray Is Nothing
    If pSymbolArray Is Nothing Then Exit Function
    
    '简单渲染图层
    If TypeOf pGeoFeatureLayer.Renderer Is ISimpleRenderer Then
        Dim pSimpleRender As ISimpleRenderer
        Set pSimpleRender = pGeoFeatureLayer.Renderer
        pSymbolArray.Add pSimpleRender.Symbol
    End If
    
    '单值渲染图层
    If TypeOf pGeoFeatureLayer.Renderer Is IUniqueValueRenderer Then
    
        Dim pUniqueValueRenderer As IUniqueValueRenderer
        Set pUniqueValueRenderer = pGeoFeatureLayer.Renderer
        Dim pSymbol As ISymbol
        Set pSymbol = pUniqueValueRenderer.Symbol(CStr(pUniqueValueRenderer.Value(0)))
        pSymbolArray.Add pSymbol
    
    End If
    
    '分类渲染图层
    If TypeOf pGeoFeatureLayer.Renderer Is IClassBreaksRenderer Then
    
        Dim pClassRenderer As IClassBreaksRenderer
        Set pClassRenderer = pGeoFeatureLayer.Renderer
        
        For i = 0 To pClassRenderer.BreakCount - 1
            pSymbolArray.Add pClassRenderer.Symbol(i)
        Next i
        
    End If
    
    '图表渲染图层
    If TypeOf pGeoFeatureLayer.Renderer Is IChartRenderer Then
        
        Dim pChartRenderer As IChartRenderer
        Set pChartRenderer = pGeoFeatureLayer.Renderer
        Dim pChartSymbol As IChartSymbol
        Set pChartSymbol = pChartRenderer.ChartSymbol
            
        Set pMySymbolArray = pChartSymbol
        Debug.Assert Not pMySymbolArray Is Nothing
        If pMySymbolArray Is Nothing Then Exit Function
        
        For i = 0 To pMySymbolArray.SymbolCount - 1
            pSymbolArray.Add pMySymbolArray.Symbol(i)
        Next i
        
        Debug.Assert Not pSymbolArray.Count < 1
    
    End If
    
    '点密度渲染图层(???)
    If TypeOf pGeoFeatureLayer.Renderer Is IDotDensityRenderer Then
    
        Dim pDotDensityRenderer As IDotDensityRenderer
        Set pDotDensityRenderer = pGeoFeatureLayer.Renderer
        Dim pDotDensityFillSymbol As IDotDensityFillSymbol
        Set pDotDensityFillSymbol = pDotDensityRenderer.DotDensitySymbol
        
        Set pMySymbolArray = pDotDensityFillSymbol
        
        For i = 0 To pMySymbolArray.SymbolCount - 1
            pSymbolArray.Add pMySymbolArray.Symbol(i)
        Next i
    
    End If
    
    If Not pSymbolArray.Count < 1 Then Set GetLayerSymbols = pSymbolArray
    Set pSymbolArray = Nothing
    
End Function

Public Function GetCurrentValueRanges(pLayer As ILayer) As Collection

    If pLayer Is Nothing Then Exit Function
    
    Dim pGeoFeatureLayer As IGeoFeatureLayer
    Set pGeoFeatureLayer = pLayer
    If pGeoFeatureLayer Is Nothing Then Exit Function
    
    Dim colValueRanges As Collection
    Set colValueRanges = New Collection
    Debug.Assert Not colValueRanges Is Nothing
    If colValueRanges Is Nothing Then Exit Function
    
    '分类渲染图层
    If TypeOf pGeoFeatureLayer.Renderer Is IClassBreaksRenderer Then
    
        Dim pClassRenderer As IClassBreaksRenderer
        Set pClassRenderer = pGeoFeatureLayer.Renderer
        
        colValueRanges.Add "0" & "--" & pClassRenderer.Break(0)
        
        Dim i As Integer
        For i = 0 To pClassRenderer.BreakCount - 2
            colValueRanges.Add pClassRenderer.Break(i) & "-" & pClassRenderer.Break(i + 1)
        Next i
        
    End If
    
    If Not colValueRanges.Count < 1 Then Set GetCurrentValueRanges = colValueRanges
    Set colValueRanges = Nothing
    
End Function
Public Sub FeatuerSymbol(ByVal color As Long)
    Dim tempFeatureLayer As IGeoFeatureLayer