Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0697: Picture-Objektdaten in ein Bytearray kopieren

VB 5/6-Tipp 0697: Picture-Objektdaten in ein Bytearray kopieren

 von Udo Schmidt

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CreateStreamOnHGlobal (OLE_CreateStream), RtlMoveMemory (memCPY)

Download: Download des Beispielprojektes [8,23 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
'--------- Anfang Modul "Module1" alias Module1.bas ---------

Option Explicit


' =====================================================================
' privates
' =====================================================================


' const
' =====================================================================
Private Const S_OK          As Long = 0


' types
' =====================================================================
Private Type BITMAPFILEHEADER
    bfType                      As Integer
    bfSize                      As Long
    bfReserved1                 As Integer
    bfReserved2                 As Integer
    bfOffBits                   As Long
End Type

Public Type BITMAPINFOHEADER
    biSize                      As Long
    biWidth                     As Long
    biHeight                    As Long
    biPlanes                    As Integer
    biBitCount                  As Integer
    biCompression               As Long
    biSizeImage                 As Long
    biXPelsPerMeter             As Long
    biYPelsPerMeter             As Long
    biClrUsed                   As Long
    biClrImportant              As Long
End Type


' externals
' =====================================================================
Private Declare Function OLE_CreateStream _
    Lib "ole32" Alias "CreateStreamOnHGlobal" _
   (ByRef hGlobal As Any, _
    ByVal fDeleteOnRelease As Boolean, _
    ByRef ppstm As Any) As Long

Private Declare Sub memCPY _
    Lib "kernel32" Alias "RtlMoveMemory" _
   (ByRef hpvDest As Any, _
    ByRef hpvSource As Any, _
    ByVal cbCopy As Long)

' STD2BAR   copy a standard picture's data to a byte array
'           (softKUS) - IV/2005
'
' CALL:     STD2BAR(std, @bmi, @bar, [adj], [@ecd])
'
' IN:       obj:std standard picture object
'           bol:adj .T.: remove bmf/bmi from array data
'                   .F.: do not change array data (dflt)
'
' OUT:      arr:bar target byte array
'           udt:bmi bitmapinfoheader filled acc.
'           lng:ecd error code
'                   -3: picture creation failed
'                   -4: saving object to stream failed
'
' RET:      bol     success
'
Function STD2BAR( _
    std As IPicture, _
    bmi As BITMAPINFOHEADER, _
    bar() As Byte, _
    Optional adj As Boolean, _
    Optional ecd As Long) As Boolean
    
    Dim stm     As IUnknown
    Dim bmf     As BITMAPFILEHEADER
    Dim lmx     As Long
    Dim wid     As Long
    Dim hgt     As Long
    Dim tmp     As Long
    Dim hmX     As Single
    Dim hmY     As Single
    
    ecd = 0
    
    ' calculate space needed
    ' assume maximal size  = 4 BytesPerPixel
    ' --------------------------------------------------------------------------
    hmX = 0.567 / Screen.TwipsPerPixelX ' HighMetric to vbPixel - X
    hmY = 0.567 / Screen.TwipsPerPixelY ' HighMetric to vbpixel - Y
    
    wid = (std.Width * hmX * 4 + 3) And -4&
    hgt = std.Height * hmY
    ReDim bar(Len(bmi) + Len(bmf) + wid * hgt)
    
    If OLE_CreateStream(bar(0), False, stm) <> S_OK Then
        ecd = -3    ' stream object creation error
            
    Else
        std.SaveAsFile ByVal ObjPtr(stm), True, lmx
        
        If lmx = 0 Then
            ecd = -4 ' saving object to stream failed
    
        Else
            memCPY bmi, bar(Len(bmf)), Len(bmi)
            
            If adj Then
                tmp = Len(bmf) + Len(bmi)
                memCPY bar(0), bar(tmp), lmx - tmp
            End If
            
            ReDim Preserve bar(lmx - tmp - 1)
            STD2BAR = True
        End If
    End If
    
    Set stm = Nothing
    Set std = Nothing
End Function



'---------- Ende Modul "Module1" alias Module1.bas ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.