none
Using GDI+ in Excel VBA RRS feed

  • Question

  • I adapted some VB6 code to test if I can get GDI+ working in VBA (I got 64-bit installed, so had to rewrite the API calls to PtrSafe functions). The code runs fine, yet nothing shows when I'm trying to draw on the form. Does anybody have any idea if it can be made to work?

    Option Explicit
    
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWndForm As LongPtr, ByVal hDCForm As LongPtr) As Long
    
    Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (ByRef token As LongPtr, ByRef lpInput As GDIPlusStartupInput, Optional ByRef lpOutput As Any) As Long
    Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
    
    Private Declare PtrSafe Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As LongPtr, ByRef graphics As LongPtr) As Long
    Private Declare PtrSafe Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As LongPtr) As Long
    Private Declare PtrSafe Function GdipSetSmoothingMode Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mSmoothingMode As Long) As Long
    
    'Private Declare PtrSafe Function GdipCreatePen1 Lib "GdiPlus.dll" (ByVal mColor As Long, ByVal mWidth As Single, ByRef mUnit As GpUnit, ByRef mPen As LongPtr) As Long
    Private Declare PtrSafe Function GdipDeletePen Lib "GdiPlus.dll" (ByVal mPen As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateSolidFill Lib "GdiPlus.dll" (ByVal mColor As Long, ByRef mBrush As LongPtr) As Long
    Private Declare PtrSafe Function GdipDeleteBrush Lib "GdiPlus.dll" (ByVal mBrush As LongPtr) As Long
    
    Private Declare PtrSafe Function GdipFillEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mBrush As LongPtr, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    Private Declare PtrSafe Function GdipFillRectangleI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mBrush As LongPtr, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    
    Private Declare PtrSafe Function GdipDrawRectangleI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mPen As LongPtr, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    Private Declare PtrSafe Function GdipDrawEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mPen As LongPtr, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    
    Private Type GDIPlusStartupInput
        GdiPlusVersion                      As Long
        DebugEventCallback                  As Long
        SuppressBackgroundThread            As Long
        SuppressExternalCodecs              As Long
    End Type
    
    Private Const SmoothingModeAntiAlias    As Long = &H4
    
    Private hWndForm As LongPtr
    Private hDCForm As LongPtr
    Private GdipToken As LongPtr
    
    
    
    '##################################################################################################################
    
    Private Sub UserForm_Initialize()
      ' Get hWndForm
      hWndForm = FindWindow(vbNullString, Me.Caption)
      hDCForm = GetDC(hWndForm)
    
      ' Initiate GDI+
      Call InitGDI
      
      FillRectangle hDCForm, vbRed, 50, 20, 20, 100, 100
      FillRectangle hDCForm, vbGreen, 50, 70, 20, 100, 100
      FillRectangle hDCForm, vbBlue, 50, 50, 70, 100, 100
    '  Me.Repaint
    End Sub
    
    Private Sub UserForm_Terminate()
      Call TerminateGDI
      ReleaseDC hWndForm, hDCForm
    End Sub
    
    
    '##################################################################################################################
    
    Private Sub InitGDI()
      Dim GdipStartupInput As GDIPlusStartupInput
    
      GdipStartupInput.GdiPlusVersion = 1&
      Call GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0)
    End Sub
    
    Private Sub TerminateGDI()
      Call GdiplusShutdown(GdipToken)
    End Sub
    
    
    '##################################################################################################################
    
    Public Function FillRectangle(ByVal hdc As LongPtr, ByVal lColor As Long, ByVal Alpha As Long, ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long) As Boolean
      Dim hGraphics As LongPtr, hBrush As LongPtr
    
      If GdipCreateFromHDC(hdc, hGraphics) = 0 Then
        If GdipCreateSolidFill(ConvertColor(lColor, Alpha), hBrush) = 0 Then
          Call GdipSetSmoothingMode(hGraphics, SmoothingModeAntiAlias)
          FillRectangle = (GdipFillRectangleI(hGraphics, hBrush, X, Y, Width, Height) = 0)
          Call GdipDeleteBrush(hBrush)
        End If
        
        Call GdipDeleteGraphics(hGraphics)
      End If
    End Function
    
    Private Function ConvertColor(Color As Long, Opacity As Long) As Long
       Dim BGRA(0 To 3) As Byte
    
       BGRA(3) = CByte((Abs(Opacity) / 100) * 255)
       BGRA(0) = ((Color \ &H10000) And &HFF)
       BGRA(1) = ((Color \ &H100) And &HFF)
       BGRA(2) = (Color And &HFF)
       CopyMemory ConvertColor, BGRA(0), 4&
    End Function
    

    Monday, May 14, 2018 2:22 PM

All replies

  • Any 'drawing' type stuff you do on a userform with GDI or say 'SetPixel' will not persist if the window is repainted, with your own code or in other ways, say moving the form off and back onto the screen or covering it with another window.

    Your code is called in the form's initialize event, your GDI might have existed for a micro tad but by the time the form appears it will have been erased. You could try calling it in the Activate event but as it's more of a 'before activate' event probably the same problem. 

    Try calling your code from a button click on the form after it's laoded. If that works and you want it to appear as your form loads you'll probably need some sort of timer to call it only when the form has fully appeared.

    Once you've got it to appear, be prepared for it to get wiped!

    Thursday, May 17, 2018 3:47 PM
    Moderator
  • Heck, I should have thought of that! It works beautifully!

    Thanks!

    Andy

    Friday, May 18, 2018 1:40 PM
  • Got it all worked out now. It doesn't look like many people want to use GDI+ in VBA, let alone 64-bit VBA, but I hope I can save somebody at some time a bunch of work.

    I got a spreadsheet with a button (Button1) which can be clicked as follows:

    Option Explicit
    
    Sub Button1_Click()
      ActiveWorkbook.Save
      frmDraw.Show
    End Sub

    Then I have a frmDraw  with a button (cmdTest), that starts the test in the following form. Enjoy! Andy

    VERSION 5.00
    Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmDraw 
       Caption         =   "GDI+ Test"
       ClientHeight    =   5280
       ClientLeft      =   120
       ClientTop       =   465
       ClientWidth     =   6780
       OleObjectBlob   =   "frmDraw.frx":0000
       StartUpPosition =   1  'CenterOwner
    End
    Attribute VB_Name = "frmDraw"
    Attribute VB_GlobalNameSpace = False
    Attribute VB_Creatable = False
    Attribute VB_PredeclaredId = True
    Attribute VB_Exposed = False
    Option Explicit
    
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWndForm As LongPtr, ByVal hDCForm As LongPtr) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDCForm As LongPtr) As LongPtr
    
    Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (ByRef token As LongPtr, ByRef lpInput As GDIPlusStartupInput, Optional ByVal lpOutputBuf As LongPtr = 0) As Long
    Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
    
    Private Declare PtrSafe Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As LongPtr, ByRef graphics As LongPtr) As Long
    Private Declare PtrSafe Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As LongPtr) As Long
    Private Declare PtrSafe Function GdipSetSmoothingMode Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mSmoothingMode As Long) As Long
    
    Private Declare PtrSafe Function GdipCreatePen1 Lib "GdiPlus.dll" (ByVal mColor As Long, ByVal mWidth As Single, ByVal mUnit As GpUnit, ByRef mPen As LongPtr) As Long
    Private Declare PtrSafe Function GdipDeletePen Lib "GdiPlus.dll" (ByVal mPen As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateSolidFill Lib "GdiPlus.dll" (ByVal mColor As Long, ByRef mBrush As LongPtr) As Long
    Private Declare PtrSafe Function GdipDeleteBrush Lib "GdiPlus.dll" (ByVal mBrush As LongPtr) As Long
    
    Private Declare PtrSafe Function GdipFillRectangleI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mBrush As LongPtr, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    Private Declare PtrSafe Function GdipFillEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mBrush As LongPtr, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    
    Private Declare PtrSafe Function GdipDrawRectangleI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mPen As LongPtr, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    Private Declare PtrSafe Function GdipDrawEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mPen As LongPtr, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    Private Declare PtrSafe Function GdipDrawLineI Lib "gdiplus" (ByVal mGraphics As LongPtr, ByVal mPen As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function GdipDrawBezierI Lib "gdiplus" (ByVal mGraphics As LongPtr, ByVal mPen As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long
    
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    
    Private Type GDIPlusStartupInput
      GdiPlusVersion                      As Long
      DebugEventCallback                  As LongPtr
      SuppressBackgroundThread            As Boolean
      SuppressExternalCodecs              As Boolean
    End Type
    
    Public Enum GpUnit
      UnitWorld = 0&
      UnitDisplay = 1&
      UnitPixel = 2&
      UnitPoint = 3&
      UnitInch = 4&
      UnitDocument = 5&
      UnitMillimeter = 6&
    End Enum
    
    Private Const SmoothingModeAntiAlias    As Long = &H4
    
    Private hWndForm As LongPtr
    Private hDCForm As LongPtr
    Private GdipToken As LongPtr
    
    
    
    '##################################################################################################################
    
    Private Sub UserForm_Initialize()
      ' Get hWndForm
      hWndForm = FindWindow(vbNullString, Me.Caption)
      hDCForm = GetDC(hWndForm)
    
      ' Initiate GDI+
      Call InitGDI
    End Sub
    
    Private Sub UserForm_Terminate()
      Call TerminateGDI
      ReleaseDC hWndForm, hDCForm
    End Sub
    
    Private Sub cmdTest_Click()
      ' Dont draw on top of previous test
      Me.Repaint
      
      ' Tests - note that the order of the circles impacts the final overlap area color
      gCircle hDCForm, vbBlack, 0, vbRed, 50, 100, 100, 50
      gCircle hDCForm, vbBlack, 0, vbBlue, 50, 150, 100, 50
      gCircle hDCForm, vbBlack, 0, vbGreen, 50, 125, 150, 50
      
      gRectangle hDCForm, vbBlack, 50, vbYellow, 50, 50, 20, 150, 20            ' yellow box
      gRectangle hDCForm, vbBlack, 50, vbBlack, 0, 50, 50, 150, 150             ' transparent box
      gEllipse hDCForm, vbBlack, 25, vbBlue, 100, 50, 230, 150, 100             ' ellipse
      
      gLine hDCForm, vbBlack, 50, 2, 50, 220, 200, 230                          ' slanting line
      gSpline hDCForm, vbBlack, 100, 4, 250, 20, 250, 120, 300, 80, 300, 200    ' Bezier
    End Sub
    
    
    '##################################################################################################################
    
    Private Sub InitGDI()
      Dim GdipStartupInput As GDIPlusStartupInput
    
      GdipStartupInput.GdiPlusVersion = 1&
      Call GdiplusStartup(GdipToken, GdipStartupInput)
    End Sub
    
    Private Sub TerminateGDI()
      If GdipToken <> 0 Then Call GdiplusShutdown(GdipToken)
      GdipToken = 0
    End Sub
    
    
    '##################################################################################################################
    
    Public Sub gLine(ByVal hdc As LongPtr, ByVal penColor As Long, ByVal penAlpha As Long, thickness As Long, _
                     ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long)
      Dim hGraphics As LongPtr, hPen As LongPtr, lRes As Long
      
      If GdipToken <> 0 And GdipCreateFromHDC(hdc, hGraphics) = 0 Then
        If penAlpha < 0 Then penAlpha = 0
        If penAlpha > 100 Then penAlpha = 100
        lRes = GdipCreatePen1(ConvertColor(penColor, penAlpha), thickness, &H2&, hPen)
        If hPen <> 0 Then
          lRes = GdipSetSmoothingMode(hGraphics, SmoothingModeAntiAlias)
          lRes = GdipDrawLineI(hGraphics, hPen, X1, Y1, X2, Y2)
          GdipDeletePen (hPen)
        End If
        
        Call GdipDeleteGraphics(hGraphics)
      End If
    End Sub
    
    Public Sub gSpline(ByVal hdc As LongPtr, ByVal penColor As Long, ByVal penAlpha As Long, thickness As Long, _
                       ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, _
                       ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long)
    
      Dim hGraphics As LongPtr, hPen As LongPtr, lRes As Long
      
      If GdipToken <> 0 And GdipCreateFromHDC(hdc, hGraphics) = 0 Then
        If penAlpha < 0 Then penAlpha = 0
        If penAlpha > 100 Then penAlpha = 100
        lRes = GdipCreatePen1(ConvertColor(penColor, penAlpha), thickness, &H2&, hPen)
        If hPen <> 0 Then
          lRes = GdipSetSmoothingMode(hGraphics, SmoothingModeAntiAlias)
          lRes = GdipDrawBezierI(hGraphics, hPen, X1, Y1, X2, Y2, X3, Y3, X4, Y4)
          GdipDeletePen (hPen)
        End If
        
        Call GdipDeleteGraphics(hGraphics)
      End If
    End Sub
    
    Public Sub gRectangle(ByVal hdc As LongPtr, ByVal penColor As Long, ByVal penAlpha As Long, _
                          ByVal brushColor As Long, ByVal brushAlpha As Long, _
                          ByVal x As Long, ByVal y As Long, ByVal width As Long, ByVal height As Long)
      Dim hGraphics As LongPtr, hBrush As LongPtr, hPen As LongPtr, lRes As Long
    
      If GdipToken <> 0 And GdipCreateFromHDC(hdc, hGraphics) = 0 Then
        If penAlpha < 0 Then penAlpha = 0
        If penAlpha > 100 Then penAlpha = 100
        If brushAlpha < 0 Then brushAlpha = 0
        If brushAlpha > 100 Then brushAlpha = 100
        ' Fill
        lRes = GdipCreateSolidFill(ConvertColor(brushColor, brushAlpha), hBrush)
        If hBrush <> 0 Then
          lRes = GdipSetSmoothingMode(hGraphics, SmoothingModeAntiAlias)
          lRes = GdipFillRectangleI(hGraphics, hBrush, x, y, width, height)
          GdipDeleteBrush (hBrush)
        End If
        ' Outline
        lRes = GdipCreatePen1(ConvertColor(penColor, penAlpha), 2, UnitPixel, hPen)
        If hPen <> 0 Then
          lRes = GdipDrawRectangleI(hGraphics, hPen, x, y, width, height)
          GdipDeletePen (hPen)
        End If
        
        Call GdipDeleteGraphics(hGraphics)
      End If
    End Sub
    
    Public Sub gEllipse(ByVal hdc As LongPtr, ByVal penColor As Long, ByVal penAlpha As Long, _
                          ByVal brushColor As Long, ByVal brushAlpha As Long, _
                          ByVal x As Long, ByVal y As Long, ByVal width As Long, ByVal height As Long)
      Dim hGraphics As LongPtr, hBrush As LongPtr, hPen As LongPtr, lRes As Long
    
      If GdipToken <> 0 And GdipCreateFromHDC(hdc, hGraphics) = 0 Then
        If penAlpha < 0 Then penAlpha = 0
        If penAlpha > 100 Then penAlpha = 100
        If brushAlpha < 0 Then brushAlpha = 0
        If brushAlpha > 100 Then brushAlpha = 100
        ' Fill
        lRes = GdipCreateSolidFill(ConvertColor(brushColor, brushAlpha), hBrush)
        If hBrush <> 0 Then
          lRes = GdipSetSmoothingMode(hGraphics, SmoothingModeAntiAlias)
          lRes = GdipFillEllipseI(hGraphics, hBrush, x, y, width, height)
          GdipDeleteBrush (hBrush)
        End If
        ' Outline
        lRes = GdipCreatePen1(ConvertColor(penColor, penAlpha), 2, UnitPixel, hPen)
        If hPen <> 0 Then
          lRes = GdipDrawEllipseI(hGraphics, hPen, x, y, width, height)
          GdipDeletePen (hPen)
        End If
        
        Call GdipDeleteGraphics(hGraphics)
      End If
    End Sub
    
    Public Sub gCircle(ByVal hdc As LongPtr, ByVal penColor As Long, ByVal penAlpha As Long, _
                          ByVal brushColor As Long, ByVal brushAlpha As Long, _
                          ByVal xCenter As Long, ByVal yCenter As Long, ByVal radius As Long)
      Dim x As Long, y As Long, width As Long, height As Long
      
      x = xCenter - radius
      width = 2 * radius
      y = yCenter - radius
      height = width
      
      gEllipse hdc, penColor, penAlpha, brushColor, brushAlpha, x, y, width, height
    End Sub
    
    Private Function ConvertColor(Color As Long, Alpha As Long) As Long
       Dim BGRA(0 To 3) As Byte
    
       BGRA(3) = CByte((Abs(Alpha) / 100) * 255)
       BGRA(0) = ((Color \ &H10000) And &HFF)
       BGRA(1) = ((Color \ &H100) And &HFF)
       BGRA(2) = (Color And &HFF)
       CopyMemory ConvertColor, BGRA(0), 4&
    End Function
    

    Sunday, May 27, 2018 9:54 AM