none
VBA: Bitmap dynamisch erzeugen und Image-Control zuweisen RRS feed

  • Frage

  • Hallo, allerseits!

    Ich hoffe, ich bin hier mit VBA nicht völlig falsch. Ich brauche aber eine kleine(?) Routine, die unter VB.Net wirklich ein Klacks ist, mir unter Excel-VBA aber echt Kopfzerbrechen bereitet.

    Ich müßte:
    a) ein Bitmap-Objekt im Speicher erstellen
    b) einige Zeichen-Operationen darauf durchführen
    c) das Bitmap einem Image-Control (ActiveX) zuweisen

    (In einem späteren Schritt müßte ich auch noch vorher ein Bild aus einer Datei laden und das neu erzeugte über das geladene Einblenden, diese Kombination dann in das Image-Cntrol stecken.)

    Ich habe dafür jetzt etliche GDI32- und GDIplus-Aufrufe (plus einige weitere aus z.B. User32 usw.) deklariert und den ganzen Kladderadatsch in ein Klassen-Modul verpackt. Das funktioniert auch grundsätzlich, denn:

    In einem Userform habe ich einen Button, der über die Klassen-Instanz

    gdip.BindToForm Me.Caption
    Me.Repaint
    gdip.DrawCircle vbBlack, 0, vbRed, 50, 100, 100, 50

    einen Kreis direkt auf das Userform zeichnet.

    Das funktioniert, weil BindToForm über

        Public Function BindToForm(WindowCaption$) As Boolean
            Dim Result As Boolean
            Result = False
            hWnd = 0
            hDC = 0
            hWnd = FindWindow(vbNullString, WindowCaption)
            If (hWnd <> 0) Then
                hDC = GetDC(hWnd)
                If (hDC <> 0) Then
                    Result = True
                End If
            End If
            BindToForm = Result
        End Function
    

    sauber hWnd und hDC in (Objekt-lokalen) LongPtr-Variablen speichert, die dann für die weiteren Zeichen-Operationen benutzt werden.

    Versuche ich einen ähnlichen Ansatz über ein Image-Control (was kein PictureBox-Control ist!):

        Public Function BindToImage(img As Image) As Boolean
            Dim Result As Boolean
            Dim i As Image
            Dim p As StdPicture
            Dim h As Long
            Result = False
            hWnd = 0
            hDC = 0
            If (Not img Is Nothing) Then
                Set i = img
                Debug.Print "Image.Name: " & i.Name
                If (Not i.Picture Is Nothing) Then
                    Set p = i.Picture
                    'Debug.Print "Image.Picture.Name: " & p.Name
                    If (p.handle <> 0) Then
                        h = p.handle
                        Debug.Print "Image.Picture.Handle: " & h
                        hWnd = h
                      Else
                        Debug.Print "Image.Picture.Handle is '0'"
                    End If
                  Else
                    Debug.Print "Image.Picture is 'nothing'"
                End If
              Else
                Debug.Print "Image is 'nothing'"
            End If
            If (hWnd <> 0) Then
                hDC = GetDC(hWnd)
                If (hDC <> 0) Then
                    Result = True
                End If
            End If
            BindToImage = Result
        End Function
    

    kriege ich naturgemäß keinen Handle, weil ja noch gar kein Bild im Control hinterlegt ist. Das will ich ja erst erstellen. Ich bin mir aber auch nicht sicher, ob Image1.Picture.Handle überhaupt der richtige wäre.

    Was ich aber habe ist Breite und Höhe des Controls. Und sehr viel mehr, dachte ich, braucht man nicht, um ein Bild zu erstellen:

    Public Sub Bitmap_to_Image(img As Image)
        Dim desktop_handle As LongPtr
        Dim desktop_context As LongPtr
        Dim newbitmap_context As LongPtr
        Dim newbitmap_handle As LongPtr
        Dim newbitmap_width As Long
        Dim newbitmap_height As Long
        'Dim newbitmap_planes As Long
        'Dim newbitmap_bitcount As Long
        'Dim newbitmap_bits As Long
        Dim oldbitmap_handle As LongPtr
        Dim pic As IPicture
    
        newbitmap_width = img.width
        newbitmap_height = img.height
        'newbitmap_planes = 1
        'newbitmap_bitcount = 32
        'newbitmap_bits = 0
        Debug.Print "w:" & newbitmap_width & " h:" & newbitmap_height
        
        'newbitmap_handle = CreateBitmap(newbitmap_width, newbitmap_height, newbitmap_planes, newbitmap_bitcount, newbitmap_bits)
        
        desktop_handle = 0
        desktop_context = GetDC(desktop_handle)
        Debug.Print "Desktop Handle:" & desktop_handle & " Desktop Context:" & desktop_context
        newbitmap_context = CreateCompatibleDC(desktop_context)
        'newbitmap_handle = CreateCompatibleBitmap(desktop_context, newbitmap_width, newbitmap_height)
        newbitmap_handle = CreateCompatibleBitmap(newbitmap_context, newbitmap_width, newbitmap_height)
        Debug.Print "Bitmap Handle:" & newbitmap_handle & " Bitmap Context:" & newbitmap_context
        
        oldbitmap_handle = SelectObject(newbitmap_context, newbitmap_handle)
        Debug.Print "Old Bitmap Handle:" & oldbitmap_handle
    
        hWnd = newbitmap_handle
        hDC = newbitmap_handle
        DrawCircle vbBlack, 0, vbRed, 50, 100, 100, 50
    
        Set pic = BitmapToPicture(newbitmap_handle)
        Debug.Print "Picture Width:" & pic.width & " Picture Height:" & pic.height
        Set img.Picture = pic
        
        DeleteObject SelectObject(newbitmap_context, oldbitmap_handle)
        DeleteDC newbitmap_context
        ReleaseDC 0, desktop_context
    
    End Sub
    

    Das erzeugt bislang folgenden Output im Direkt-Fenster:

    Image.Name: Image1
    Image.Picture is 'nothing'
    w:360 h:360
    Desktop Handle:0 Desktop Context:402722472
    Bitmap Handle:1610944812 Bitmap Context:352391481
    Old Bitmap Handle:8716303
    Picture Width:9525 Picture Height:9525
    

    Aber... Das ganze läuft nicht wie gewünscht durch.

        lRes = OleCreatePictureIndirect(picdes, iidIPicture, True, IPic)
    

    gibt ein Bild mit 9525x9525 zurück, siehe obige Debug-Ausgabe, statt der erwarteten 360x360. Und das anschließende Zuweisen auf das Control ändert nichts in der Anzeige.


    Die Routine, die mir eigentlich aus dem Speicher-Bitmap ein IPicture machen soll:

        Public Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
            ByRef PicDesc As Any, _
            ByRef RefIID As GUID, _
            ByVal fPictureOwnsHandle As Long, _
            ByRef IPic As IPicture _
            ) As Long
    
        Public Type PICTDESC_BMP
          cbSizeOfStruct As Long
          PicType As Long
          hBitmap As LongPtr
          hPal As LongPtr
        End Type
    
        Public Type GUID
          Data1 As Long
          Data2 As Integer
          Data3 As Integer
          Data4(7) As Byte
        End Type
    
        Function BitmapToPicture(bmp_handle As LongPtr)
    
            Dim IPic As IPicture
            Dim lRes As Long
            Dim picdes As PICTDESC_BMP
            Dim iidIPicture As GUID
    
            picdes.cbSizeOfStruct = Len(picdes)
            picdes.PicType = vbPicTypeBitmap '// = 1
            picdes.hBitmap = bmp_handle
    
            '{00020400-0000-0000-C000-000000000046} = IDispatch
            iidIPicture.Data1 = &H20400
            iidIPicture.Data2 = &H0
            iidIPicture.Data3 = &H0
            iidIPicture.Data4(0) = &H0
            iidIPicture.Data4(1) = &H0
            iidIPicture.Data4(2) = &H0
            iidIPicture.Data4(3) = &H0
            iidIPicture.Data4(4) = &H0
            iidIPicture.Data4(5) = &H0
            iidIPicture.Data4(6) = &H0
            iidIPicture.Data4(7) = &H46
    
            '{7BF80980-BF32-101A-8BBB-00AA00300CAB} = IPicture
            iidIPicture.Data1 = &H7BF80980
            iidIPicture.Data2 = &HBF32
            iidIPicture.Data3 = &H101A
            iidIPicture.Data4(0) = &H8B
            iidIPicture.Data4(1) = &HBB
            iidIPicture.Data4(2) = &H0
            iidIPicture.Data4(3) = &HAA
            iidIPicture.Data4(4) = &H0
            iidIPicture.Data4(5) = &H30
            iidIPicture.Data4(6) = &HC
            iidIPicture.Data4(7) = &HAB
    
            lRes = OleCreatePictureIndirect(picdes, iidIPicture, True, IPic)
            'MsgBox "BitmapToPicture: OleCreatePictureIndirect returned " & lRes
    
            Set BitmapToPicture = IPic
    
        End Function
    

    Bin ich jetzt mit diesem Versuch völlig auf dem Holzweg? Oder ist da irgendwo nur ein kleiner Glitch, den ich nicht sehe?

    Gruß, Michael

    Samstag, 17. August 2019 14:00

Alle Antworten

  • gibt ein Bild mit 9525x9525 zurück, siehe obige Debug-Ausgabe, statt der erwarteten 360x360. Und das anschließende Zuweisen auf das Control ändert nichts in der Anzeige.

    kleiner Nachtrag: Jetzt killt mir die Routine Excel komplett. Nach dem Button-Klick gibt's 2, 3 Sekunden lang "Eieruhr" und dann ist Excel dicht.

    Im Single-Step komme ich noch aus der Function zurück, aber das

    Set pic = BitmapToPicture(newbitmap_handle)

    in der aufrufenden Routine ist dann das tragische Ende. In der folgenden Zeile

    Debug.Print "Picture Width:" & pic.width & " Picture Height:" & pic.height

    killt es Excel dann weg.

    Samstag, 17. August 2019 14:45
  • Hat denn wirklich so gar keiner eine Idee? Ich meine... 80 Aufrufe und nicht mal ein "geht nicht" oder sonst irgend eine Reaktion?
    Donnerstag, 29. August 2019 14:06
  • Hi,

    nuja, wenn niemand weiß, ob oder wie es geht, was soll man dazu dann schreiben?

    Letztendlich ist das wohl schon etwas exotisch. Die Kombination von VBA, P/Invoke, ActiveX, usw. machen wohl nicht allzu viele.

    Ich persönlich würde eher schauen, dass man den größten Teil (also alles, was die Grafikerzeugung, .. angeht) in .NET auslagert und dann nur noch das fertige Bild in VBA lädt und dem Control zuweist.


    Gruß, Stefan
    Microsoft MVP - Visual Developer ASP/ASP.NET (2001-2018)
    https://www.asp-solutions.de/ - IT Beratung, Softwareentwicklung, Remotesupport

    Donnerstag, 29. August 2019 14:57
    Moderator