basdrawsymbol.bas

ArcEngine 这是基于AE组件的源代码

Attribute VB_Name = "basDrawSymbol"

' Copyright 1995-2004 ESRI

' All rights reserved under the copyright laws of the United States.

' You may freely redistribute and use this sample code, with or without modification.

' Disclaimer: THE SAMPLE CODE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED
' WARRANTIES, INCLUDING THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
' FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ESRI OR
' CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY,
' OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
' SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
' INTERRUPTION) SUSTAINED BY YOU OR A THIRD PARTY, HOWEVER CAUSED AND ON ANY
' THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ARISING IN ANY
' WAY OUT OF THE USE OF THIS SAMPLE CODE, EVEN IF ADVISED OF THE POSSIBILITY OF
' SUCH DAMAGE.

' For additional information contact: Environmental Systems Research Institute, Inc.

' Attn: Contracts Dept.

' 380 New York Street

' Redlands, California, U.S.A. 92373

' Email: [e-mail]


Option Explicit

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
  ' This function Draws the Symbol to a device context in memory, before
  ' creating an OLE Picture from the context and saving it to a bmp file.
  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)
  
  ' Draw the symbol to the new device context.
  Dim lResult As Long
  lResult = DrawToDC(hDCNew, lWidth, lHeight, pSymbol, lGap)
  
  hBmpNew = SelectObject(hDCNew, hBmpOld)
  DeleteDC hDCNew

  ' Return the Bitmap as an OLE Picture.
  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

  ' Create Picture object.
  Dim result As Long
  result = OleCreatePictureIndirect(Pic, IID_IDispatch, True, pPic)
  Debug.Print "Result OLE call: " & result
  
  ' Return the new Picture object.
  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
           
    ' Calculate size of window.
    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)   ' Must release the DC afterwards.
      If hDC <> 0 Then
        DrawToWnd = DrawToDC(hDC, lWidth, lHeight, pSymbol, lGap)
      End If
      ReleaseDC hWnd, hDC ' Release cached DC obtained with GetDC.
    End If
  End If

Exit Function
errH:
  If Err.Number <> 0 Then
    If Not pSymbol Is Nothing Then
      pSymbol.ResetDC     ' try resetting DC, in case we have already called SetupDC for this symbol.
    End If
    If hWnd <> 0 And hDC <> 0 Then
      ReleaseDC hWnd, hDC ' try to release cached DC obtained with GetDC.
    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
  
    ' First clear the existing device context.
    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
            
    ' Create the Transformation and Geometry required by ISymbol::Draw.
    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)
    
    ' Perform the Draw operation.
    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
  ' This function fill the passed in device context with a solid brush,
  ' based on the OLE color passed in.
  
  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
  ' Calculate the parameters for the new transformation, based on the
  ' dimensions passed to this function.
  
  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
  
  ' Create a new display transformation and set its properties.
  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
  ' This function returns an appropriate Geometry type depending on the
  ' Symbol type passed in.
  
  On Error GoTo errH
  
  If TypeOf pSymbol Is IMarkerSymbol Then
    ' For a MarkerSymbol return a Point.
    Dim pArea As IArea
    Set pArea = pEnvelope
    Set CreateSymShape = pArea.Centroid
    
  ElseIf TypeOf pSymbol Is ILineSymbol Or TypeOf pSymbol Is ITextSymbol Then
    ' For a LineSymbol or TextSymbol return a Polyline.
    Dim pPolyline As IPolyline
    Set pPolyline = New Polyline
    pPolyline.FromPoint = pEnvelope.LowerLeft
    pPolyline.ToPoint = pEnvelope.UpperRight
    Set CreateSymShape = pPolyline
    
  Else
    ' For any FillSymbol return an Envelope.
    Set CreateSymShape = pEnvelope
  End If
  
Exit Function
errH:
  If Err.Number <> 0 Then
    Set CreateSymShape = Nothing
  End If
End Function