Die Community zu .NET und Classic VB.
Menü

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

 von 

Beschreibung 

Hier wird gezeigt, wie man ein Bildobjekt aus (beliebigen) Daten im Speicher erstellen kann. Hierzu werden OLE-Funktionen genutzt, um ein IPicture-Objekt zu erstellen und die Bilddaten per Stream "hineinzuschieben".
(s.a. die Umkehrfunktion "Picture-Objektdaten in ein Bytearray kopieren", Tipp 697)

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

CLSIDFromString (OLE_CID2BAR), CreateStreamOnHGlobal (OLE_CreateStream), OleLoadPicture (OLE_LoadPicture), RtlMoveMemory (memCPY)

Download:

Download des Beispielprojektes [4,06 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 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-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

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

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

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.

Kommentar von Allien am 12.10.2011 um 17:44

Hallo,
der Tipp funktioniert eigentlich ganz gut ... aber :)
Momentan erstelle ich Bilder im Format 7168 x 7168 Pixel (benötigt werden aber eigentlich auch Grössen bis 65536 x 65536); die Bilddaten sind 1-Byte-Zeiger in eine 256-Farben- Farbtabelle. Mit Picture.Pset() dauert dies recht lange.
Um den Tipp anzuwenden, dimensioniere ich den Speicher mit

Dim ram() As Long

und
ReDim ram(0 To 7167, 0 To 7167)

Das führt zum Abbruch mit der Fehlermeldung "Nicht genügend Speicher", was wohl an den VB6-Grenzen liegt.

Lässt sich der Tipp auch für grössere 8-Bit-Bitmaps anpassen? Wenn ja: Wie?

mfg

Kommentar von Udo Schmidt am 01.07.2010 um 21:28

Hallo, fr34k!

Schreibe folgende drei Zeilen in den Deklarationsteil des Formulars (und lösche sie in der Form_Load-Prozedur)

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


Wenn Du Deinen Code ein wenig abänderst, sollte er funktionieren:
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


Udo

Kommentar von fr34k am 29.06.2010 um 20:54

Hi ich hab bei dem Quelltext für Pictur1 folgenden Code eingefügt:

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

buf(x * 3 + 0, Picture1.ScaleHeight - y - 1) = Int((250 * Rnd) + 1)
buf(x * 3 + 1, Picture1.ScaleHeight - y - 1) = Int((250 * Rnd) + 1)
buf(x * 3 + 2, Picture1.ScaleHeight - y - 1) = Int((250 * Rnd) + 1)
' Zulangsam bei Grossen Bitmaps
' StdPicture-Objekt erstellen
If crtPIC(wid, hgt, 24, VarPtr(buf(0, 0)), std) Then
Set Me.Picture1 = std
End If
Me.Caption = "X= " & x & " / Y= " & y
End Sub

Damit der im dem Bild Punkte einzeichnet.
Doch es klappt nicht könnt ihr mir da helfen?

Kommentar von Timo am 29.11.2005 um 11:15

Gold Wert dieser Tipp!

Kommentar von Udo Schmidt am 08.04.2005 um 21:26

s. im Tips&Tricks-Forum

Kommentar von am 07.04.2005 um 20:24

Es wäre schön, wenn es noch einen Tipp gäbe, bei dem aus einem stdpicture ein Array erstellt wird. Also genau umgekehrt...