Startseite / Tipps / VB 5/6-Tipp 0654: Bild aus im Speicher liegenden Daten erstellen

VB 5/6-Tipp 0654: Bild aus im Speicher liegenden Daten erstellen

 von Udo Schmidt

'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 Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Bildfeld-Steuerelement "Picture1"

Option Explicit

Private Sub Form_Load()
   Dim std   As StdPicture
    Dim wid   As Long
    Dim hgt   As Long
    Dim row   As Long
    Dim col   As Long
    Dim buf() As Byte
    
    ' Bildbreite und -höhe festlegen
    wid = 256
    hgt = 256
    
    ' Puffer entsprechend dimensionieren
    ReDim buf(wid * 3 - 1, hgt - 1)
    
    ' beliebige Bilddaten erstellen
    For row = 0 To hgt - 1
        For col = 0 To wid - 1
            If ((row Or (col + 2)) And 7) = 0 Then
                buf(col * 3 + 0, row) = 255
                buf(col * 3 + 1, row) = 255
                buf(col * 3 + 2, row) = 255
            Else
                buf(col * 3 + 0, row) = 200
                buf(col * 3 + 1, row) = col
                buf(col * 3 + 2, row) = row
            End If
        Next
    Next
    
    ' StdPicture-Objekt erstellen
    If crtPIC(wid, hgt, 24, VarPtr(buf(0, 0)), std) Then
        Set Me.Picture1 = std
    End If
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'--------- Anfang Modul "Module1" alias Module1.bas ---------


'----------------------------------------------------------------------
' Function  : crtPIC
' Author    : (softKUS) - I/2005
' Purpose   : creating a StdPicture-object from any
'             data by using a stream
'
' Hints     - You may use this code in your programs at your own risk
'           - You may not publish/sell it without the authour's agreement
'
'           - If you have suggestions for improvements or corrections,
'             please do not hesitate to email them to info@softkus.de
'----------------------------------------------------------------------

Option Explicit

' constants
' =====================================================================
Private Const S_OK              As Long = 0
Private Const BI_RGB            As Long = 0
Private Const IPictureIID       As String = _
    "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"


Private 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

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


' externals
' =====================================================================
Private Declare Function OLE_CID2BAR _
    Lib "ole32" Alias "CLSIDFromString" _
   (ByVal lpszProgID As Long, _
    ByRef pCLSID As Any) As Long

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 Function OLE_LoadPicture _
    Lib "oleaut32" Alias "OleLoadPicture" _
   (ByVal lpstream As Long, _
    ByVal lSize As Long, _
    ByVal fRunmode As Long, _
    ByRef riid As Any, _
    ByRef lplpvObj As Any) As Long
         
Private Declare Sub memCPY _
    Lib "kernel32" Alias "RtlMoveMemory" _
   (ByRef hpvDest As Any, _
    ByRef hpvSource As Any, _
    ByVal cbCopy As Long)

' crtPIC        create picture object
'
' CALL:         crtPIC(wid, hgt, bpp, ptr, @std, [@ecd])
'
' IN:           lng:wid width
'               lng:hgt height
'               lng:bpp bits/pixel
'               lng:ptr points to bitmap data
'               obj:std picture object to be created
'               lng:ecd error code
'                       -1: ole error
'                       -2: stream object creation error
'                       -3: picture creation failed
'
' OUT:          bol     success
'
Function crtPIC( _
    wid As Long, _
    hgt As Long, _
    bpp As Long, _
    ptr As Long, _
    std As StdPicture, _
    Optional ecd As Long) As Boolean
    
    Dim bfh     As BITMAPFILEHEADER
    Dim bmi     As BITMAPINFOHEADER
    Dim pic     As IPicture     ' picture object
    Dim obj     As IUnknown     ' stream object
    Dim buf()   As Byte         ' stream buffer
    Dim iid(15) As Byte         ' IPicture-guid
    
    ' set BitmapInfoHeader according to parameters
    With bmi
        .biSize = Len(bmi)
        .biCompression = BI_RGB
        .biBitCount = bpp
        .biWidth = wid
        .biHeight = hgt
        .biPlanes = 1
        .biSizeImage = ((wid * bpp / 8 + 3) And -4&) * hgt
    End With
    
    ' ... and the BitmapFileHeader
    With bfh
        .bfType = &H4D42    ' "BM"
        .bfOffBits = Len(bfh) + Len(bmi)
        .bfSize = .bfOffBits + bmi.biSizeImage
    End With
    
    ' Create bitmap file information within memory
    ' 1st: allocate memory
    ReDim buf(bfh.bfSize - 1)
    
    ' 2nd: copy BitmapFileHeader (take care of pad bytes!)
    memCPY buf(0), bfh, 2
    memCPY buf(2), ByVal VarPtr(bfh.bfSize), Len(bfh) - 2
            
    ' 3rd: copy BitmapInfoHeader
    memCPY buf(Len(bfh)), bmi, Len(bmi)
    
    ' 4th: copy data
    memCPY buf(Len(bfh) + Len(bmi)), ByVal ptr, bmi.biSizeImage

    ' convert iid
    If OLE_CID2BAR(StrPtr(IPictureIID), iid(0)) <> S_OK Then
        ecd = -1        ' ole error
    
    ' create stream
    ElseIf OLE_CreateStream(buf(0), False, obj) <> S_OK Then
        ecd = -2        ' stream object creation error

    ' create picture
    ElseIf OLE_LoadPicture(ObjPtr(obj), bfh.bfSize, False, iid(0), pic) <> S_OK Then
        ecd = -3        ' picture creation failed
    
    Else
        ecd = 0         ' error code 0
        Set std = pic   ' set target
        crtPIC = True   ' return success
    End If
    
    Set pic = Nothing
    Set obj = Nothing
End Function


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

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 6 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.

Dim ram() As Long

ReDim ram(0 To 7167, 0 To 7167)

Dim buf() As Byte
Dim wid   As Long
Dim hgt   As Long

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim std As StdPicture
    Dim cvx As Long
    Dim cvy As Long
    
    cvy = Me.ScaleY(y, Me.Picture1.ScaleMode, vbPixels) + 1
    If cvy > hgt Then cvy = hgt
    cvy = hgt - cvy
    
    cvx = Me.ScaleX(x, Me.Picture1.ScaleMode, vbPixels) + 1
    If cvx > wid Then cvx = wid
    cvx = (cvx - 1) * 3
        
    buf(cvx + 0, cvy) = Int((250 * Rnd) + 1)
    buf(cvx + 1, cvy) = Int((250 * Rnd) + 1)
    buf(cvx + 2, cvy) = Int((250 * Rnd) + 1)
    
    If crtPIC(wid, hgt, 24, VarPtr(buf(0, 0)), std) Then Set Me.Picture1 = std
    Me.Caption = "X= " & cvx & " / Y= " & cvy
End Sub