UserForm Free Drawing

Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,615
Office Version
  1. 2016
Platform
  1. Windows
Hi all,

Inspired by a question asked by a forum member, I wrote this code which should allow the user to draw freely (like a pencil using the cursor) on an userform

The code also allows to copy the drawn picture to a newly created worksheet shape as well as to save the drawing to disk if desired

For some strange reason, the board errors out for me when trying to post the code here


Download Workbook demo


 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Sort by date Sort by votes
Ok, finally I have managed to post the code here

1- Code in the UserForm Module :

Code: 
Option Explicit

#If VBA7 Then
    Private hFrmHwnd As LongPtr, hCanvasLbxHwnd As LongPtr, hLbxDC As LongPtr, hDCMem As LongPtr
    Private arLastAction(2) As LongPtr
#Else
    Private hFrmHwnd As Long, hCanvasLbxHwnd As Long, hLbxDC As Long, hDCMem As Long
    Private arLastAction(2) As Long
#End If
Private lCanvasBackColor As Long, lWidth As Long, lHeight As Long, lPenColor As Long
Private iPenWidth As Integer, iPenStyle As Integer
Private IsSubClassed As Boolean, bErasing As Boolean, bClosing As Boolean
Private tCanvasRect As RECT

'Form events routines
'=====================
Private Sub UserForm_Activate()
    PenWidthCb.List = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 30)
    PenWidthCb.ListIndex = 0
    PenStyleCB.List = Array("SOLID", "DASH", "DOT", "DASHDOT", "DASHDOTDOT")
    PenStyleCB.ListIndex = 0
    PenColorCB.List = Array("BLACK", "WHITE", "RED", "GREEN", "BLUE", "MAGENTA", "CYAN", "YELLOW", "SILVER", "BROWN", "PURPLE", "MAROON")
    PenColorCB.ListIndex = 0
    CanvasColorCB.List = Array("WHITE", "BLACK", "RED", "GREEN", "BLUE", "MAGENTA", "CYAN", "YELLOW", "SILVER", "BROWN", "PURPLE", "MAROON")
    CanvasColorCB.ListIndex = 0
    ActionLbl.Caption = "Painting"
    hFrmHwnd = GetActiveWindow
    hCanvasLbxHwnd = GetNextWindow(GetNextWindow(GetActiveWindow, GW_CHILD), GW_CHILD)
    hLbxDC = GetDC(hCanvasLbxHwnd)
    arLastAction(0) = TakeSnapShot
    UndoBtn.Enabled = False
    UpdateLbl False
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    ReleaseDC hCanvasLbxHwnd, hLbxDC
    Call DestroyCursor
    DeleteObject hDCMem
    Call InstallSubclassing(hFrmHwnd, False)
    IsSubClassed = False
    bClosing = True
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call DestroyCursor
    If Not IsSubClassed Then
        Call InstallSubclassing(hFrmHwnd, True)
        IsSubClassed = True
    End If
End Sub

'Controls events routines
'=====================
Private Sub CanvasLBX_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
#If VBA7 Then
    Dim hPen As LongPtr
#Else
    Dim hPen As Long
#End If
    Dim tPen As LOGPEN
    Dim tPt As POINTAPI
    
    Call ChangeCursor(hLbxDC, iPenWidth + 4, iPenWidth + 4, IIf(bErasing, False, True))
    lCanvasBackColor = CanvasLBX.BackColor
    With tPen
        .lopnColor = IIf(bErasing, lCanvasBackColor, lPenColor)
        .lopnStyle = iPenStyle
        .lopnWidth.X = iPenWidth
        .lopnWidth.Y = iPenWidth
    End With
    hPen = CreatePenIndirect(tPen)
    DeleteObject SelectObject(hLbxDC, hPen)
    GetCursorPos tPt
    ScreenToClient hCanvasLbxHwnd, tPt
    If Button Then
        LineTo hLbxDC, tPt.X, tPt.Y
    End If
    DeleteObject hPen
End Sub

Private Sub CanvasLBX_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim tPt As POINTAPI
    
    Call OnCanvasClick(hCanvasLbxHwnd, hLbxDC, iPenStyle, iPenWidth, lPenColor, lCanvasBackColor, bErasing)
    GetCursorPos tPt
    ScreenToClient hCanvasLbxHwnd, tPt
    MoveToEx hLbxDC, tPt.X, tPt.Y, 0
End Sub

Private Sub CanvasLBX_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If arLastAction(1) <> 0 Then
        arLastAction(0) = arLastAction(1)
    End If
    arLastAction(1) = TakeSnapShot
    UndoBtn.Enabled = True
End Sub

Private Sub UndoBtn_Click()
    Call BitBlt(hLbxDC, 0, 0, lWidth, lHeight, arLastAction(0), tCanvasRect.Left, tCanvasRect.Top, SRCCOPY)
    arLastAction(1) = TakeSnapShot
    UndoBtn.Enabled = False
End Sub

Private Sub PenWidthCb_Change()
    On Error Resume Next
    iPenWidth = PenWidthCb.Value
End Sub

Private Sub PenStyleCB_Change()
    iPenStyle = GetStyle(PenStyleCB.Value)
End Sub

Private Sub PenColorCB_Change()
    lPenColor = GetColor(PenColorCB.Value)
End Sub

Private Sub CanvasColorCB_Change()
    CanvasLBX.BackColor = GetColor(CanvasColorCB.Value)
    lCanvasBackColor = CanvasLBX.BackColor
    UndoBtn.Enabled = True
    Me.Repaint
End Sub

Private Sub SavePicBtn_Click()
    Dim vFileName As Variant
    vFileName = Application.GetSaveAsFilename(InitialFileName:="", fileFilter:="Image Files (*.bmp), *.bmp")
    If vFileName <> False Then
        Call ExtractPictureTo(hCanvasLbxHwnd, vFileName)
    End If
End Sub

Private Sub ClearBtn_Click()
    arLastAction(0) = TakeSnapShot
    InvalidateRect hCanvasLbxHwnd, 0, 1
    DoEvents
End Sub

Private Sub EraserTgl_Click()
    bErasing = Not bErasing
    bClosing = True
    UpdateLbl False
End Sub

Private Sub CloseBtn_Click()
    Unload Me
End Sub

'Supporting routines
'=====================
Private Sub AddPicToSheetBtn_Click()
    Dim oRange As Range
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Set oRange = Application.InputBox(prompt:="Select the range that will house the image shape.", Title:="Adding image shape", Type:=8)
    If Not oRange Is Nothing Then
        Call ExtractPictureTo(hCanvasLbxHwnd, oRange)
    End If
    Application.DisplayAlerts = True
End Sub

#If VBA7 Then
    Private Sub InstallSubclassing(ByVal hwnd As LongPtr, ByVal Enable As Boolean)
#Else
    Private Sub InstallSubclassing(ByVal hwnd As Long, ByVal Enable As Boolean)
#End If
    If Enable Then
        lPrevFrmProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf FrmCallBack)
    Else
        Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevFrmProc)
    End If
End Sub

Private Function GetColor(ByVal sColor As String) As Long
    Select Case sColor
        Case Is = "BLACK"
            GetColor = vbBlack
        Case Is = "WHITE"
            GetColor = vbWhite
        Case Is = "RED"
            GetColor = vbRed
        Case Is = "GREEN"
            GetColor = vbGreen
        Case Is = "BLUE"
            GetColor = vbBlue
        Case Is = "MAGENTA"
            GetColor = vbMagenta
        Case Is = "CYAN"
            GetColor = vbCyan
        Case Is = "YELLOW"
            GetColor = vbYellow
        Case Is = "SILVER"
            GetColor = RGB(192, 192, 192)
        Case Is = "BROWN"
            GetColor = RGB(139, 69, 19)
        Case Is = "PURPLE"
            GetColor = RGB(128, 0, 128)
        Case Is = "MAROON"
            GetColor = RGB(128, 0, 0)
    End Select
End Function

Private Function GetStyle(ByVal sStyle As String) As Long
    Select Case sStyle
        Case Is = "SOLID"
            GetStyle = PS_SOLID
        Case Is = "DASH"
            GetStyle = PS_DASH
        Case Is = "DOT"
            GetStyle = PS_DOT
        Case Is = "DASHDOT"
            GetStyle = PS_DASHDOT
        Case Is = "DASHDOTDOT"
            GetStyle = PS_DASHDOTDOT
    End Select
End Function

#If VBA7 Then
    Private Function TakeSnapShot() As LongPtr
    Dim hBitmap As LongPtr
#Else
    Private Function TakeSnapShot() As Long
    Dim hBitmap As Long
#End If
    Dim tPt As POINTAPI

    GetWindowRect hCanvasLbxHwnd, tCanvasRect
    With tCanvasRect
        lWidth = .Right - .Left
        lHeight = .Bottom - .Top
        tPt.X = .Left
        tPt.Y = .Top
        ScreenToClient hCanvasLbxHwnd, tPt
        .Left = tPt.X
        .Top = tPt.Y
    End With
    hDCMem = CreateCompatibleDC(hLbxDC)
    hBitmap = CreateCompatibleBitmap(hLbxDC, lWidth, lHeight)
    If hBitmap <> 0 Then
        DeleteObject SelectObject(hDCMem, hBitmap)
        DeleteObject hBitmap
        Call BitBlt(hDCMem, 0, 0, lWidth, lHeight, hLbxDC, tCanvasRect.Left, tCanvasRect.Top, SRCCOPY)
        TakeSnapShot = hDCMem
    End If
End Function

Private Sub UpdateLbl(ByVal Erasing As Boolean)
    Dim sCaption As String
    Dim i As Integer
    
    bClosing = False
    sCaption = IIf(bErasing, "Erasing", "Painting")
    Do
        sCaption = sCaption & " " & String(i, ".")
        ActionLbl.Caption = sCaption
        i = i + 1
        If i = 4 Then i = 0
        Delay 1
        If Right(sCaption, 3) = "..." Then
         ActionLbl.ForeColor = IIf(ActionLbl.ForeColor = vbRed, vbBlue, vbRed)
        End If
        sCaption = IIf(bErasing, "Erasing", "Painting")
        DoEvents
    Loop Until bClosing
End Sub

Private Sub Delay(ByVal Wait As Long)
    Dim t As Single
    t = Timer
    Do
        DoEvents
    Loop Until Timer - t >= 1
End Sub

2- Code in a Standard Module :

Code: 
Option Explicit

Type POINTAPI
    X As Long
    Y As Long
End Type

Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Type LOGPEN
    lopnStyle As Long
    lopnWidth As POINTAPI
    lopnColor As Long
End Type

Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    #If VBA7 Then
        hbmMask As LongPtr
        hbmColor As LongPtr
    #Else
        hbmMask As Long
        hbmColor As Long
    #End If
End Type

Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    #If VBA7 Then
        bmBits As LongPtr
    #Else
        bmBits As Long
    #End If
End Type

Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
 
Type uPicDesc
    Size As Long
    Type As Long
    #If VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    #Else
        hPic As Long
        hPal As Long
    #End If
End Type

#If VBA7 Then
    Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Declare PtrSafe Function LineTo Lib "gdi32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Declare PtrSafe Function MoveToEx Lib "gdi32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long, lpPoint As Any) As Long
    Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Declare PtrSafe Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Declare PtrSafe Function FillRgn Lib "gdi32" (ByVal hdc As LongPtr, ByVal hRgn As LongPtr, ByVal hBrush As LongPtr) As Long
    Declare PtrSafe Function CreatePenIndirect Lib "gdi32" (lpLogPen As LOGPEN) As LongPtr
    Declare PtrSafe Function CreateIconIndirect Lib "user32" (piconinfo As ICONINFO) As LongPtr
    Declare PtrSafe Function SetCursor Lib "user32" (ByVal hCursor As LongPtr) As LongPtr
    Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Declare PtrSafe Function SetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
    Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Declare PtrSafe Function FloodFill Lib "gdi32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
    Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Declare PtrSafe Function DestroyIcon Lib "user32" (ByVal hIcon As LongPtr) As Long
    Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Declare PtrSafe Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As LongPtr
    Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long

    Public lPrevFrmProc As LongPtr
    Private hCursor As LongPtr
#Else
    Declare  Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare  Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Declare  Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Declare  Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Declare  Function GetActiveWindow Lib "user32" () As Long
    Declare  Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Declare  Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Declare  Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Declare  Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
    Declare  Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As Any) As Long
    Declare  Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Declare  Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Declare  Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Declare  Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Declare  Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
    Declare  Function CreatePenIndirect Lib "gdi32" (lpLogPen As LOGPEN) As Long
    Declare  Function CreateIconIndirect Lib "user32" (piconinfo As ICONINFO) As Long
    Declare  Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
    Declare  Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
    Declare  Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
    Declare  Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Declare  Function CloseClipboard Lib "user32" () As Long
    Declare  Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Declare  Function EmptyClipboard Lib "user32" () As Long
    Declare  Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Declare  Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Declare  Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Declare  Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Declare  Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Declare  Function FloodFill Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
    Declare  Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Declare  Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Declare  Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
    Declare  Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Declare  Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Declare  Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Declare  Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Declare  Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long

    Public lPrevFrmProc As Long
    Private hCursor As Long
#End If
 
Public Const PS_SOLID = 0
Public Const PS_DASH = 1
Public Const PS_DOT = 2
Public Const PS_DASHDOT = 3
Public Const PS_DASHDOTDOT = 4
Public Const GWL_WNDPROC = (-4)
Public Const GW_CHILD = 5
Public Const SRCCOPY = &HCC0020


Private Const WM_EXITSIZEMOVE = &H232
Private Const WM_MOVING = &H216
Private Const WM_SETREDRAW = &HB
Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Const S_OK = &H0


#If VBA7 Then
    Public Function FrmCallBack(ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
    Public Function FrmCallBack(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If


    Select Case Msg
        Case WM_MOVING
            SendMessage hwnd, WM_SETREDRAW, ByVal 0, 0
        Case WM_EXITSIZEMOVE
            SendMessage hwnd, WM_SETREDRAW, ByVal 1, 0
    End Select
    FrmCallBack = CallWindowProc(lPrevFrmProc, hwnd, Msg, wParam, ByVal lParam)
End Function


#If VBA7 Then
    Sub ExtractPictureTo(ByVal hwnd As LongPtr, ByVal ToRangeOrFile As Variant)
    Dim hPtr As LongPtr
    Dim hdc As LongPtr
    Dim hDCMem As LongPtr
    Dim hBitmap As LongPtr
#Else
    Sub ExtractPictureTo(ByVal hwnd As Long, ByVal ToRangeOrFile As Variant)
    Dim hPtr As Long
    Dim hdc As Long
    Dim hDCMem As Long
    Dim hBitmap As Long
#End If


    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim IPic As IPicture
    Dim tWndRect As RECT
    Dim tPt As POINTAPI
    Dim oShp As Shape
    Dim lWidth As Long
    Dim lHeight As Long
    
    On Error GoTo Xit
    GetWindowRect hwnd, tWndRect
    With tWndRect
        lWidth = .Right - .Left
        lHeight = .Bottom - .Top
        tPt.X = .Left
        tPt.Y = .Top
        ScreenToClient hwnd, tPt
        .Left = tPt.X
        .Top = tPt.Y
    End With
    hdc = GetDC(hwnd)
    hDCMem = CreateCompatibleDC(hdc)
    hBitmap = CreateCompatibleBitmap(hdc, lWidth, lHeight)
    If hBitmap <> 0 Then
        Call SelectObject(hDCMem, hBitmap)
        Call BitBlt(hDCMem, 0, 0, lWidth, lHeight, hdc, tWndRect.Left, tWndRect.Top, SRCCOPY)
        Call OpenClipboard(0)
        Call EmptyClipboard
        Call SetClipboardData(CF_BITMAP, hBitmap)
        Call DeleteDC(hDCMem)
        Call ReleaseDC(hwnd, hdc)
        If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
            hPtr = GetClipboardData(CF_BITMAP)
            CloseClipboard
            If hPtr <> 0 Then
                With IID_IDispatch
                    .Data1 = &H7BF80980
                    .Data2 = &HBF32
                    .Data3 = &H101A
                    .Data4(0) = &H8B
                    .Data4(1) = &HBB
                    .Data4(2) = &H0
                    .Data4(3) = &HAA
                    .Data4(4) = &H0
                    .Data4(5) = &H30
                    .Data4(6) = &HC
                    .Data4(7) = &HAB
                End With
                With uPicinfo
                    .Size = Len(uPicinfo)
                    .Type = PICTYPE_BITMAP
                    .hPic = hPtr
                    .hPal = 0
                End With
                If OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, IPic) = S_OK Then
                    If TypeName(ToRangeOrFile) = "Range" Then
                        stdole.SavePicture IPic, Environ("temp") & "\IMG.bmp"
                        Set oShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
                        CallByName(ToRangeOrFile, "Left", VbGet), CallByName(ToRangeOrFile, "Top", VbGet), 100, 50)
                        With oShp.Fill
                            .Visible = msoTrue
                            .UserPicture Environ("temp") & "\IMG.bmp"
                        End With
                        Kill Environ("temp") & "\IMG.bmp"
                    Else
                        stdole.SavePicture IPic, ToRangeOrFile
                    End If
                End If
            End If
        End If
    End If
Xit:
    CloseClipboard
End Sub


#If VBA7 Then
    Public Sub ChangeCursor(ByVal DC As LongPtr, ByVal W As Integer, ByVal h As Integer, ByVal Rubbing As Boolean)
    Dim hDCMem As LongPtr
    Dim hFillBrush As LongPtr
    Dim hPrevCursor As LongPtr
    Dim hBitmap As LongPtr
    Dim hRgn As LongPtr
    Dim hAndMaskBitmap  As LongPtr
    Dim hXORMaskBitmap  As LongPtr
    Dim hAndMaskDC As LongPtr
    Dim hXorMaskDC As LongPtr
    Dim lOldAndMaskBmp As LongPtr
    Dim lOldXorMaskBmp As LongPtr
#Else
    Public Sub ChangeCursor(ByVal DC As Long, ByVal W As Integer, ByVal h As Integer, ByVal Rubbing As Boolean)
    Dim hDCMem As Long
    Dim hFillBrush As Long
    Dim hPrevCursor As Long
    Dim hBitmap As Long
    Dim hRgn As Long
    Dim hAndMaskBitmap As Long
    Dim hXORMaskBitmap As Long
    Dim hAndMaskDC As Long
    Dim hXorMaskDC As Long
    Dim lOldAndMaskBmp As Long
    Dim lOldXorMaskBmp As Long
#End If


    Dim lColor As Long
    Dim X As Long, Y As Long
    Dim tBMP As BITMAP
    Dim tIcoInfo As ICONINFO
    Static bRubbing As Boolean
    
    If hCursor <> 0 And bRubbing = Rubbing Then hPrevCursor = SetCursor(hCursor): bRubbing = Rubbing: Exit Sub
    bRubbing = Rubbing
    Call DestroyCursor
    hDCMem = CreateCompatibleDC(DC)
    hBitmap = CreateCompatibleBitmap(DC, W, h)
    If hBitmap <> 0 Then
        GetObjectAPI hBitmap, LenB(tBMP), tBMP
        DeleteObject SelectObject(hDCMem, hBitmap)
        DeleteObject hBitmap
        If Rubbing Then
            hFillBrush = CreateSolidBrush(vbRed)
            DeleteObject SelectObject(hDCMem, hFillBrush)
            hRgn = CreateEllipticRgn(0, 0, tBMP.bmWidth, tBMP.bmHeight)
            FillRgn hDCMem, hRgn, hFillBrush
            DeleteObject hRgn
            lColor = vbRed
        Else
            hFillBrush = CreateSolidBrush(RGB(176, 196, 222))
            DeleteObject SelectObject(hDCMem, hFillBrush)
            FloodFill hDCMem, 0, 0, RGB(176, 196, 222)
            lColor = RGB(176, 196, 222)
        End If
        DeleteObject hFillBrush
        hAndMaskDC = CreateCompatibleDC(hDCMem)
        hXorMaskDC = CreateCompatibleDC(hDCMem)
        hAndMaskBitmap = CreateCompatibleBitmap(hDCMem, tBMP.bmWidth, tBMP.bmHeight)
        hXORMaskBitmap = CreateCompatibleBitmap(hDCMem, tBMP.bmWidth, tBMP.bmHeight)
        lOldAndMaskBmp = SelectObject(hAndMaskDC, hAndMaskBitmap)
        lOldXorMaskBmp = SelectObject(hXorMaskDC, hXORMaskBitmap)
        For X = 0 To tBMP.bmWidth
            For Y = 0 To tBMP.bmHeight
                If GetPixel(hDCMem, X, Y) <> lColor Then
                    SetPixel hAndMaskDC, X, Y, RGB(255, 255, 255)
                    SetPixel hXorMaskDC, X, Y, RGB(0, 0, 0)
                Else
                    SetPixel hAndMaskDC, X, Y, RGB(0, 0, 0)
                    SetPixel hXorMaskDC, X, Y, lColor
                End If
            Next Y
        Next X
        SelectObject hAndMaskDC, lOldAndMaskBmp
        SelectObject hXorMaskDC, lOldXorMaskBmp
        With tIcoInfo
            .fIcon = False
            .xHotspot = tBMP.bmWidth / 2
            .yHotspot = tBMP.bmWidth / 2
            .hbmMask = hAndMaskBitmap
            .hbmColor = hXORMaskBitmap
        End With
        hCursor = CreateIconIndirect(tIcoInfo)
        hPrevCursor = SetCursor(hCursor)
        DeleteObject hAndMaskBitmap
        DeleteObject hXORMaskBitmap
        DeleteObject lOldAndMaskBmp
        DeleteObject lOldXorMaskBmp
        DeleteDC hAndMaskDC
        DeleteDC hXorMaskDC
    End If
    DeleteDC hDCMem
End Sub


#If VBA7 Then
    Public Sub OnCanvasClick(ByVal hwnd As LongPtr, ByVal DC As LongPtr, ByVal PenStyle As Integer, ByVal PenWidth As Integer, ByVal PenColor As Long, ByVal CanvasColor As Long, ByVal Erasing As Boolean)
    Dim hRgn As LongPtr
    Dim hBrush As LongPtr
    Dim hPen As LongPtr
#Else
    Public Sub OnCanvasClick(ByVal hwnd As Long, ByVal DC As Long, ByVal PenStyle As Integer, ByVal PenWidth As Integer, ByVal PenColor As Long, ByVal CanvasColor As Long, ByVal Erasing As Boolean)
    Dim hRgn As Long
    Dim hBrush As Long
    Dim hPen As Long
#End If


    Dim tPt As POINTAPI
    Dim tPen As LOGPEN
    
    With tPen
        .lopnColor = IIf(Erasing, CanvasColor, PenColor)
        .lopnStyle = PenStyle
        .lopnWidth.X = PenWidth
        .lopnWidth.Y = PenWidth
    End With
    hPen = CreatePenIndirect(tPen)
    SelectObject DC, hPen
    GetCursorPos tPt
    ScreenToClient hwnd, tPt
    With tPen
        hRgn = CreateEllipticRgn(tPt.X - (.lopnWidth.X / 2), tPt.Y - (.lopnWidth.Y / 2), tPt.X + (.lopnWidth.X / 2), tPt.Y + (.lopnWidth.Y / 2))
        hBrush = CreateSolidBrush(.lopnColor)
    End With
    FillRgn DC, hRgn, hBrush
    DeleteObject hBrush
    DeleteObject hRgn
    DeleteObject hPen
End Sub


Public Sub DestroyCursor(Optional ByVal Dummy As Boolean)
    DestroyIcon hCursor
    hCursor = 0
End Sub
 
Last edited:
Upvote 0
Hi,

The code I posted above failes to cater for users that have Windows 32-Bits and Office 2010 to 2016 32-Bits

Here is an update that should work with all versions

Workbook sample

1- Code in the UserForm module:

Code: 
Option Explicit

#If VBA7 Then
    Private hFrmHwnd As LongPtr, hCanvasLbxHwnd As LongPtr, hLbxDC As LongPtr, hDCMem As LongPtr
    Private arLastAction(2) As LongPtr
#Else
    Private hFrmHwnd As Long, hCanvasLbxHwnd As Long, hLbxDC As Long, hDCMem As Long
    Private arLastAction(2) As Long
#End If
Private lCanvasBackColor As Long, lWidth As Long, lHeight As Long, lPenColor As Long
Private iPenWidth As Integer, iPenStyle As Integer
Private IsSubClassed As Boolean, bErasing As Boolean, bClosing As Boolean
Private tCanvasRect As RECT




'Form events routines
'=====================
Private Sub UserForm_Activate()
    PenWidthCb.List = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 30)
    PenWidthCb.ListIndex = 0
    PenStyleCB.List = Array("SOLID", "DASH", "DOT", "DASHDOT", "DASHDOTDOT")
    PenStyleCB.ListIndex = 0
    PenColorCB.List = Array("BLACK", "WHITE", "RED", "GREEN", "BLUE", "MAGENTA", "CYAN", "YELLOW", "SILVER", "BROWN", "PURPLE", "MAROON")
    PenColorCB.ListIndex = 0
    CanvasColorCB.List = Array("WHITE", "BLACK", "RED", "GREEN", "BLUE", "MAGENTA", "CYAN", "YELLOW", "SILVER", "BROWN", "PURPLE", "MAROON")
    CanvasColorCB.ListIndex = 0
    ActionLbl.Caption = "Painting"
    hFrmHwnd = GetActiveWindow
    hCanvasLbxHwnd = Me.CanvasLBX.[_GethWnd] ' GetNextWindow(GetNextWindow(GetActiveWindow, GW_CHILD), GW_CHILD)
    hLbxDC = GetDC(hCanvasLbxHwnd)
    arLastAction(0) = TakeSnapShot
    UndoBtn.Enabled = False
    UpdateLbl False
End Sub


Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    ReleaseDC hCanvasLbxHwnd, hLbxDC
    Call DestroyCursor
    DeleteObject hDCMem
    Call InstallSubclassing(hFrmHwnd, False)
    IsSubClassed = False
    bClosing = True
End Sub


Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call DestroyCursor
    If Not IsSubClassed Then
        Call InstallSubclassing(hFrmHwnd, True)
        IsSubClassed = True
    End If
End Sub


'Controls events routines
'=====================
Private Sub CanvasLBX_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
#If VBA7 Then
    Dim hPen As LongPtr
#Else
    Dim hPen As Long
#End If
    Dim tPen As LOGPEN
    Dim tPt As POINTAPI
    
    Call ChangeCursor(hLbxDC, iPenWidth + 4, iPenWidth + 4, IIf(bErasing, False, True))
    lCanvasBackColor = CanvasLBX.BackColor
    With tPen
        .lopnColor = IIf(bErasing, lCanvasBackColor, lPenColor)
        .lopnStyle = iPenStyle
        .lopnWidth.X = iPenWidth
        .lopnWidth.Y = iPenWidth
    End With
    hPen = CreatePenIndirect(tPen)
    DeleteObject SelectObject(hLbxDC, hPen)
    GetCursorPos tPt
    ScreenToClient hCanvasLbxHwnd, tPt
    If Button Then
        LineTo hLbxDC, tPt.X, tPt.Y
    End If
    DeleteObject hPen
End Sub


Private Sub CanvasLBX_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Dim tPt As POINTAPI
    
    Call OnCanvasClick(hCanvasLbxHwnd, hLbxDC, iPenStyle, iPenWidth, lPenColor, lCanvasBackColor, bErasing)
    GetCursorPos tPt
    ScreenToClient hCanvasLbxHwnd, tPt
    MoveToEx hLbxDC, tPt.X, tPt.Y, 0
End Sub


Private Sub CanvasLBX_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If arLastAction(1) <> 0 Then
        arLastAction(0) = arLastAction(1)
    End If
    arLastAction(1) = TakeSnapShot
    UndoBtn.Enabled = True
End Sub


Private Sub UndoBtn_Click()
    Call BitBlt(hLbxDC, 0, 0, lWidth, lHeight, arLastAction(0), tCanvasRect.Left, tCanvasRect.Top, SRCCOPY)
    arLastAction(1) = TakeSnapShot
    UndoBtn.Enabled = False
End Sub


Private Sub PenWidthCb_Change()
    On Error Resume Next
    iPenWidth = PenWidthCb.Value
End Sub


Private Sub PenStyleCB_Change()
    iPenStyle = GetStyle(PenStyleCB.Value)
End Sub


Private Sub PenColorCB_Change()
    lPenColor = GetColor(PenColorCB.Value)
End Sub


Private Sub CanvasColorCB_Change()
    CanvasLBX.BackColor = GetColor(CanvasColorCB.Value)
    lCanvasBackColor = CanvasLBX.BackColor
    UndoBtn.Enabled = True
    Me.Repaint
End Sub


Private Sub SavePicBtn_Click()
    Dim vFileName As Variant
    vFileName = Application.GetSaveAsFilename(InitialFileName:="", fileFilter:="Image Files (*.bmp), *.bmp")
    If vFileName <> False Then
        Call ExtractPictureTo(hCanvasLbxHwnd, vFileName)
    End If
End Sub


Private Sub ClearBtn_Click()
    arLastAction(0) = TakeSnapShot
    InvalidateRect hCanvasLbxHwnd, 0, 1
    DoEvents
End Sub


Private Sub EraserTgl_Click()
    bErasing = Not bErasing
    bClosing = True
    UpdateLbl False
End Sub


Private Sub CloseBtn_Click()
    Unload Me
End Sub


'Supporting routines
'=====================
Private Sub AddPicToSheetBtn_Click()
    Dim oRange As Range
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Set oRange = Application.InputBox(prompt:="Select the range that will house the image shape.", Title:="Adding image shape", Type:=8)
    If Not oRange Is Nothing Then
        Call ExtractPictureTo(hCanvasLbxHwnd, oRange)
    End If
    Application.DisplayAlerts = True
End Sub


#If VBA7 Then
    Private Sub InstallSubclassing(ByVal hWnd As LongPtr, ByVal Enable As Boolean)
#Else
    Private Sub InstallSubclassing(ByVal hWnd As Long, ByVal Enable As Boolean)
#End If
    If Enable Then
        lPrevFrmProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf FrmCallBack)
    Else
        Call SetWindowLong(hWnd, GWL_WNDPROC, lPrevFrmProc)
    End If
End Sub


Private Function GetColor(ByVal sColor As String) As Long
    Select Case sColor
        Case Is = "BLACK"
            GetColor = vbBlack
        Case Is = "WHITE"
            GetColor = vbWhite
        Case Is = "RED"
            GetColor = vbRed
        Case Is = "GREEN"
            GetColor = vbGreen
        Case Is = "BLUE"
            GetColor = vbBlue
        Case Is = "MAGENTA"
            GetColor = vbMagenta
        Case Is = "CYAN"
            GetColor = vbCyan
        Case Is = "YELLOW"
            GetColor = vbYellow
        Case Is = "SILVER"
            GetColor = RGB(192, 192, 192)
        Case Is = "BROWN"
            GetColor = RGB(139, 69, 19)
        Case Is = "PURPLE"
            GetColor = RGB(128, 0, 128)
        Case Is = "MAROON"
            GetColor = RGB(128, 0, 0)
    End Select
End Function


Private Function GetStyle(ByVal sStyle As String) As Long
    Select Case sStyle
        Case Is = "SOLID"
            GetStyle = PS_SOLID
        Case Is = "DASH"
            GetStyle = PS_DASH
        Case Is = "DOT"
            GetStyle = PS_DOT
        Case Is = "DASHDOT"
            GetStyle = PS_DASHDOT
        Case Is = "DASHDOTDOT"
            GetStyle = PS_DASHDOTDOT
    End Select
End Function


#If VBA7 Then
    Private Function TakeSnapShot() As LongPtr
    Dim hBitmap As LongPtr
#Else
    Private Function TakeSnapShot() As Long
    Dim hBitmap As Long
#End If
    Dim tPt As POINTAPI


    GetWindowRect hCanvasLbxHwnd, tCanvasRect
    With tCanvasRect
        lWidth = .Right - .Left
        lHeight = .Bottom - .Top
        tPt.X = .Left
        tPt.Y = .Top
        ScreenToClient hCanvasLbxHwnd, tPt
        .Left = tPt.X
        .Top = tPt.Y
    End With
    hDCMem = CreateCompatibleDC(hLbxDC)
    hBitmap = CreateCompatibleBitmap(hLbxDC, lWidth, lHeight)
    If hBitmap <> 0 Then
        DeleteObject SelectObject(hDCMem, hBitmap)
        DeleteObject hBitmap
        Call BitBlt(hDCMem, 0, 0, lWidth, lHeight, hLbxDC, tCanvasRect.Left, tCanvasRect.Top, SRCCOPY)
        TakeSnapShot = hDCMem
    End If
End Function


Private Sub UpdateLbl(ByVal Erasing As Boolean)
    Dim sCaption As String
    Dim i As Integer
    
    bClosing = False
    sCaption = IIf(bErasing, "Erasing", "Painting")
    Do
        sCaption = sCaption & " " & String(i, ".")
        ActionLbl.Caption = sCaption
        i = i + 1
        If i = 4 Then i = 0
        Delay 1
        If Right(sCaption, 3) = "..." Then
         ActionLbl.ForeColor = IIf(ActionLbl.ForeColor = vbRed, vbBlue, vbRed)
        End If
        sCaption = IIf(bErasing, "Erasing", "Painting")
        DoEvents
    Loop Until bClosing
End Sub


Private Sub Delay(ByVal Wait As Long)
    Dim t As Single
    t = Timer
    Do
        DoEvents
    Loop Until Timer - t >= 1
End Sub

2- Code in a Standard Module :

Code: 
Option Explicit


Type POINTAPI
    X As Long
    Y As Long
End Type


Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type


Type LOGPEN
    lopnStyle As Long
    lopnWidth As POINTAPI
    lopnColor As Long
End Type


Type ICONINFO
    fIcon As Long
    xHotspot As Long
    yHotspot As Long
    #If VBA7 Then
        hbmMask As LongPtr
        hbmColor As LongPtr
    #Else
        hbmMask As Long
        hbmColor As Long
    #End If
End Type


Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    #If VBA7 Then
        bmBits As LongPtr
    #Else
        bmBits As Long
    #End If
End Type


Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
 
Type uPicDesc
    Size As Long
    Type As Long
    #If VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    #Else
        hPic As Long
        hPal As Long
    #End If
End Type
    
#If VBA7 Then
    #If Win64 Then
        Declare PtrSafe Function SetWindowLong Lib "USER32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Declare PtrSafe Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    #End If
#Else
    Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#End If


#If VBA7 Then
    Declare PtrSafe Function GetDC Lib "USER32" (ByVal hWnd As LongPtr) As LongPtr
    Declare PtrSafe Function GetNextWindow Lib "USER32" Alias "GetWindow" (ByVal hWnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Declare PtrSafe Function ReleaseDC Lib "USER32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long
    Declare PtrSafe Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Declare PtrSafe Function GetActiveWindow Lib "USER32" () As LongPtr
    Declare PtrSafe Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long
    Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Declare PtrSafe Function LineTo Lib "gdi32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Declare PtrSafe Function MoveToEx Lib "gdi32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long, lpPoint As Any) As Long
    Declare PtrSafe Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
    Declare PtrSafe Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Declare PtrSafe Function FillRgn Lib "gdi32" (ByVal hdc As LongPtr, ByVal hRgn As LongPtr, ByVal hBrush As LongPtr) As Long
    Declare PtrSafe Function CreatePenIndirect Lib "gdi32" (lpLogPen As LOGPEN) As LongPtr
    Declare PtrSafe Function CreateIconIndirect Lib "USER32" (piconinfo As ICONINFO) As LongPtr
    Declare PtrSafe Function SetCursor Lib "USER32" (ByVal hCursor As LongPtr) As LongPtr
    Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Declare PtrSafe Function SetPixel Lib "gdi32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
    Declare PtrSafe Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As LongPtr, ByVal nCount As Long, lpObject As Any) As Long
    Declare PtrSafe Function CloseClipboard Lib "USER32" () As Long
    Declare PtrSafe Function OpenClipboard Lib "USER32" (ByVal hWnd As LongPtr) As Long
    Declare PtrSafe Function EmptyClipboard Lib "USER32" () As Long
    Declare PtrSafe Function SetClipboardData Lib "USER32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GetClipboardData Lib "USER32" (ByVal wFormat As Long) As LongPtr
    Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
    Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Declare PtrSafe Function FloodFill Lib "gdi32" (ByVal hdc As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
    Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Declare PtrSafe Function CallWindowProc Lib "USER32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Declare PtrSafe Function DestroyIcon Lib "USER32" (ByVal hIcon As LongPtr) As Long
    Declare PtrSafe Function ScreenToClient Lib "USER32" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long
    Declare PtrSafe Function InvalidateRect Lib "USER32" (ByVal hWnd As LongPtr, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Declare PtrSafe Function GetWindowRect Lib "USER32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Declare PtrSafe Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As LongPtr
    Declare PtrSafe Function IsClipboardFormatAvailable Lib "USER32" (ByVal wFormat As Integer) As Long


    Public lPrevFrmProc As LongPtr
    Private hCursor As LongPtr
#Else
    Declare  Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare  Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Declare  Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Declare  Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Declare  Function GetActiveWindow Lib "user32" () As Long
    Declare  Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Declare  Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
    Declare  Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Declare  Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
    Declare  Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As Any) As Long
    Declare  Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Declare  Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Declare  Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Declare  Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
    Declare  Function CreatePenIndirect Lib "gdi32" (lpLogPen As LOGPEN) As Long
    Declare  Function CreateIconIndirect Lib "user32" (piconinfo As ICONINFO) As Long
    Declare  Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
    Declare  Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
    Declare  Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
    Declare  Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
    Declare  Function CloseClipboard Lib "user32" () As Long
    Declare  Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Declare  Function EmptyClipboard Lib "user32" () As Long
    Declare  Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Declare  Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Declare  Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
    Declare  Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Declare  Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Declare  Function FloodFill Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
    Declare  Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
    Declare  Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Declare  Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
    Declare  Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Declare  Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
    Declare  Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Declare  Function OleCreatePictureIndirect Lib "oleAut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
    Declare  Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long


    Public lPrevFrmProc As Long
    Private hCursor As Long
#End If
 
Public Const PS_SOLID = 0
Public Const PS_DASH = 1
Public Const PS_DOT = 2
Public Const PS_DASHDOT = 3
Public Const PS_DASHDOTDOT = 4
Public Const GWL_WNDPROC = (-4)
Public Const GW_CHILD = 5
Public Const SRCCOPY = &HCC0020


Private Const WM_EXITSIZEMOVE = &H232
Private Const WM_MOVING = &H216
Private Const WM_SETREDRAW = &HB
Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Const S_OK = &H0




#If VBA7 Then
    Public Function FrmCallBack(ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#Else
    Public Function FrmCallBack(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#End If


    Select Case Msg
        Case WM_MOVING
            SendMessage hWnd, WM_SETREDRAW, ByVal 0, 0
        Case WM_EXITSIZEMOVE
            SendMessage hWnd, WM_SETREDRAW, ByVal 1, 0
    End Select
    FrmCallBack = CallWindowProc(lPrevFrmProc, hWnd, Msg, wParam, ByVal lParam)
End Function


#If VBA7 Then
    Sub ExtractPictureTo(ByVal hWnd As LongPtr, ByVal ToRangeOrFile As Variant)
    Dim hPtr As LongPtr
    Dim hdc As LongPtr
    Dim hDCMem As LongPtr
    Dim hBitmap As LongPtr
#Else
    Sub ExtractPictureTo(ByVal hWnd As Long, ByVal ToRangeOrFile As Variant)
    Dim hPtr As Long
    Dim hdc As Long
    Dim hDCMem As Long
    Dim hBitmap As Long
#End If


    Dim IID_IDispatch As GUID
    Dim uPicinfo As uPicDesc
    Dim IPic As IPicture
    Dim tWndRect As RECT
    Dim tPt As POINTAPI
    Dim oShp As Shape
    Dim lWidth As Long
    Dim lHeight As Long
    
    On Error GoTo Xit
    GetWindowRect hWnd, tWndRect
    With tWndRect
        lWidth = .Right - .Left
        lHeight = .Bottom - .Top
        tPt.X = .Left
        tPt.Y = .Top
        ScreenToClient hWnd, tPt
        .Left = tPt.X
        .Top = tPt.Y
    End With
    hdc = GetDC(hWnd)
    hDCMem = CreateCompatibleDC(hdc)
    hBitmap = CreateCompatibleBitmap(hdc, lWidth, lHeight)
    If hBitmap <> 0 Then
        Call SelectObject(hDCMem, hBitmap)
        Call BitBlt(hDCMem, 0, 0, lWidth, lHeight, hdc, tWndRect.Left, tWndRect.Top, SRCCOPY)
        Call OpenClipboard(0)
        Call EmptyClipboard
        Call SetClipboardData(CF_BITMAP, hBitmap)
        Call DeleteDC(hDCMem)
        Call ReleaseDC(hWnd, hdc)
        If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
            hPtr = GetClipboardData(CF_BITMAP)
            CloseClipboard
            If hPtr <> 0 Then
                With IID_IDispatch
                    .Data1 = &H7BF80980
                    .Data2 = &HBF32
                    .Data3 = &H101A
                    .Data4(0) = &H8B
                    .Data4(1) = &HBB
                    .Data4(2) = &H0
                    .Data4(3) = &HAA
                    .Data4(4) = &H0
                    .Data4(5) = &H30
                    .Data4(6) = &HC
                    .Data4(7) = &HAB
                End With
                With uPicinfo
                    .Size = Len(uPicinfo)
                    .Type = PICTYPE_BITMAP
                    .hPic = hPtr
                    .hPal = 0
                End With
                If OleCreatePictureIndirect(uPicinfo, IID_IDispatch, True, IPic) = S_OK Then
                    If TypeName(ToRangeOrFile) = "Range" Then
                        stdole.SavePicture IPic, Environ("temp") & "\IMG.bmp"
                        Set oShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
                        CallByName(ToRangeOrFile, "Left", VbGet), CallByName(ToRangeOrFile, "Top", VbGet), 100, 50)
                        With oShp.Fill
                            .Visible = msoTrue
                            .UserPicture Environ("temp") & "\IMG.bmp"
                        End With
                        Kill Environ("temp") & "\IMG.bmp"
                    Else
                        stdole.SavePicture IPic, ToRangeOrFile
                    End If
                End If
            End If
        End If
    End If
Xit:
    CloseClipboard
End Sub


#If VBA7 Then
    Public Sub ChangeCursor(ByVal DC As LongPtr, ByVal W As Integer, ByVal h As Integer, ByVal Rubbing As Boolean)
    Dim hDCMem As LongPtr
    Dim hFillBrush As LongPtr
    Dim hPrevCursor As LongPtr
    Dim hBitmap As LongPtr
    Dim hRgn As LongPtr
    Dim hAndMaskBitmap  As LongPtr
    Dim hXORMaskBitmap  As LongPtr
    Dim hAndMaskDC As LongPtr
    Dim hXorMaskDC As LongPtr
    Dim lOldAndMaskBmp As LongPtr
    Dim lOldXorMaskBmp As LongPtr
#Else
    Public Sub ChangeCursor(ByVal DC As Long, ByVal W As Integer, ByVal h As Integer, ByVal Rubbing As Boolean)
    Dim hDCMem As Long
    Dim hFillBrush As Long
    Dim hPrevCursor As Long
    Dim hBitmap As Long
    Dim hRgn As Long
    Dim hAndMaskBitmap As Long
    Dim hXORMaskBitmap As Long
    Dim hAndMaskDC As Long
    Dim hXorMaskDC As Long
    Dim lOldAndMaskBmp As Long
    Dim lOldXorMaskBmp As Long
#End If


    Dim lColor As Long
    Dim X As Long, Y As Long
    Dim tBMP As BITMAP
    Dim tIcoInfo As ICONINFO
    Static bRubbing As Boolean
    
    If hCursor <> 0 And bRubbing = Rubbing Then hPrevCursor = SetCursor(hCursor): bRubbing = Rubbing: Exit Sub
    bRubbing = Rubbing
    Call DestroyCursor
    hDCMem = CreateCompatibleDC(DC)
    hBitmap = CreateCompatibleBitmap(DC, W, h)
    If hBitmap <> 0 Then
        GetObjectAPI hBitmap, LenB(tBMP), tBMP
        DeleteObject SelectObject(hDCMem, hBitmap)
        DeleteObject hBitmap
        If Rubbing Then
            hFillBrush = CreateSolidBrush(vbRed)
            DeleteObject SelectObject(hDCMem, hFillBrush)
            hRgn = CreateEllipticRgn(0, 0, tBMP.bmWidth, tBMP.bmHeight)
            FillRgn hDCMem, hRgn, hFillBrush
            DeleteObject hRgn
            lColor = vbRed
        Else
            hFillBrush = CreateSolidBrush(RGB(176, 196, 222))
            DeleteObject SelectObject(hDCMem, hFillBrush)
            FloodFill hDCMem, 0, 0, RGB(176, 196, 222)
            lColor = RGB(176, 196, 222)
        End If
        DeleteObject hFillBrush
        hAndMaskDC = CreateCompatibleDC(hDCMem)
        hXorMaskDC = CreateCompatibleDC(hDCMem)
        hAndMaskBitmap = CreateCompatibleBitmap(hDCMem, tBMP.bmWidth, tBMP.bmHeight)
        hXORMaskBitmap = CreateCompatibleBitmap(hDCMem, tBMP.bmWidth, tBMP.bmHeight)
        lOldAndMaskBmp = SelectObject(hAndMaskDC, hAndMaskBitmap)
        lOldXorMaskBmp = SelectObject(hXorMaskDC, hXORMaskBitmap)
        For X = 0 To tBMP.bmWidth
            For Y = 0 To tBMP.bmHeight
                If GetPixel(hDCMem, X, Y) <> lColor Then
                    SetPixel hAndMaskDC, X, Y, RGB(255, 255, 255)
                    SetPixel hXorMaskDC, X, Y, RGB(0, 0, 0)
                Else
                    SetPixel hAndMaskDC, X, Y, RGB(0, 0, 0)
                    SetPixel hXorMaskDC, X, Y, lColor
                End If
            Next Y
        Next X
        SelectObject hAndMaskDC, lOldAndMaskBmp
        SelectObject hXorMaskDC, lOldXorMaskBmp
        With tIcoInfo
            .fIcon = False
            .xHotspot = tBMP.bmWidth / 2
            .yHotspot = tBMP.bmWidth / 2
            .hbmMask = hAndMaskBitmap
            .hbmColor = hXORMaskBitmap
        End With
        hCursor = CreateIconIndirect(tIcoInfo)
        hPrevCursor = SetCursor(hCursor)
        DeleteObject hAndMaskBitmap
        DeleteObject hXORMaskBitmap
        DeleteObject lOldAndMaskBmp
        DeleteObject lOldXorMaskBmp
        DeleteDC hAndMaskDC
        DeleteDC hXorMaskDC
    End If
    DeleteDC hDCMem
End Sub


#If VBA7 Then
    Public Sub OnCanvasClick(ByVal hWnd As LongPtr, ByVal DC As LongPtr, ByVal PenStyle As Integer, ByVal PenWidth As Integer, ByVal PenColor As Long, ByVal CanvasColor As Long, ByVal Erasing As Boolean)
    Dim hRgn As LongPtr
    Dim hBrush As LongPtr
    Dim hPen As LongPtr
#Else
    Public Sub OnCanvasClick(ByVal hWnd As Long, ByVal DC As Long, ByVal PenStyle As Integer, ByVal PenWidth As Integer, ByVal PenColor As Long, ByVal CanvasColor As Long, ByVal Erasing As Boolean)
    Dim hRgn As Long
    Dim hBrush As Long
    Dim hPen As Long
#End If


    Dim tPt As POINTAPI
    Dim tPen As LOGPEN
    
    With tPen
        .lopnColor = IIf(Erasing, CanvasColor, PenColor)
        .lopnStyle = PenStyle
        .lopnWidth.X = PenWidth
        .lopnWidth.Y = PenWidth
    End With
    hPen = CreatePenIndirect(tPen)
    SelectObject DC, hPen
    GetCursorPos tPt
    ScreenToClient hWnd, tPt
    With tPen
        hRgn = CreateEllipticRgn(tPt.X - (.lopnWidth.X / 2), tPt.Y - (.lopnWidth.Y / 2), tPt.X + (.lopnWidth.X / 2), tPt.Y + (.lopnWidth.Y / 2))
        hBrush = CreateSolidBrush(.lopnColor)
    End With
    FillRgn DC, hRgn, hBrush
    DeleteObject hBrush
    DeleteObject hRgn
    DeleteObject hPen
End Sub


Public Sub DestroyCursor(Optional ByVal Dummy As Boolean)
    DestroyIcon hCursor
    hCursor = 0
End Sub
 
Last edited:
Upvote 0
Hi Jaafar,
and for anyone that could be having troubles running this on Office 2019 x86 (over Win10 x64). The original file worked flawlessly on Win7+Office 2016.
So, I commented in the Win64 clause of the SetWindowLong API call, as it was returning value with a lot of lag. Once done it returned to work as it does on my Win7 machine.

Last but not least, I really enjoy all your findings on the Userform Drawing topic. You're the one from whom I have learned most on this. Hope I can finish (for 2nd time) my XLCAD app.
 
Upvote 0
Jaafar Tribak said:
PenWidthCb.List = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 30)
Click to expand...

I find it amazing how much perseverance you possess in order to be able to develop a "monster" like that. Kudos. While it is immaterial and pales in comparison to the masterpiece you wrote, I thought I would point out for the readers that the above line of code could be replaced with this shorter one (in case they might want to experiment with the idea behind it)...
VBA Code: 
PenWidthCb.List = Split(Join([COLUMN(A:T)]) & " 30")
Just to point out that if your number range was contiguous, say 1 thru 20 only, then the code line would be shorter still (although this array would be one-based instead of zero-based like the array formed above)...
VBA Code: 
PenWidthCb.List = [COLUMN(A:T)]
 
Upvote 0
audeser said:
Hi Jaafar,
and for anyone that could be having troubles running this on Office 2019 x86 (over Win10 x64). The original file worked flawlessly on Win7+Office 2016.
So, I commented in the Win64 clause of the SetWindowLong API call, as it was returning value with a lot of lag. Once done it returned to work as it does on my Win7 machine.

Last but not least, I really enjoy all your findings on the Userform Drawing topic. You're the one from whom I have learned most on this. Hope I can finish (for 2nd time) my XLCAD app.
Click to expand...
Fast and dirt amendment: finally discarded the inside content of the InstallSubclassing procedure so there is no need for the SetWindowLong API call. Not sure where the problem really is (at it seems well declared), but this call gives lag and userform renders awfully bad. Also I don't fully understand the use of this API... ?, I'll need to learn a bit more about it.

Regards
 
Upvote 0
I had completely forgotten about this little project (meant as a learning exercise) and I had to reread it a couple of times to actually see how it works (I have this lazy habbit of not properly commenting the codes)

@audeser
Try this update which hopefully, should be compatible with all office versions bitwise:
XLCanvasUpdate_V2.xls
If it works for you, I will post the update code here later for future reference.

Thank you for your feedback and interest.


@Rick Rothstein
Thanks for the tip Rick (sweeter and shorter) ... I have incorporated your sugestion into the code.
 
Upvote 0
You should not abandon this one, as I'm evolving my app as I follow your posts ;) . And I'm not a VBA newbie, so I really appreciate the info I gather from what you share here.

FYI, the V2 version works fine for the first mouse down, but then becomes unstable, and Excel crashes. As I said before, if you just comment the InstallSubclassing interior code app it will run ok, not even crash Excel and for what I have seen, all the functionallity is still there. That API call is what I could not yet clearly see the purpose for. As for what I'm concerned in, I'm ok with my dirt version (without that procedure).

Kind regards Jaafar.

@Rick Rothstein, the code gets shorter, but IMO it's way more cryptic. I not expected, at first glance, Excel manipulating ranges to feed an array like this. Nice to know for future.
 
Upvote 0
Given we are reviving about this post XD, the cursor pointer modification was a really nice surprise for me. I would love a cross-like cursor (CAD soft typical one), but I suppose I will only get that feature with something like an image control. If I'm wrong I would appreciate some tip to go further.

Kind regards
 
Upvote 0
I mean via the MousePointer(fmMousePointerCustom) and MouseIcon properties.
 
Upvote 0
You must log in or register to reply here.

Similar threads

Jaafar Tribak
  • Question
VBA Class to Make Mouse Cursors from Worksheet Shapes
Replies
2
Views
2K
audeser
A
Jaafar Tribak
  • Question
Zooming on Images (Drawing with GDIPlus + Subclassing with comctl32.dll)
Replies
1
Views
3K
Jaafar Tribak
Jaafar Tribak
Jaafar Tribak
  • Question
Drawing on UserForm Title-Bar and adding some cool formatting
2
Replies
15
Views
7K
Jaafar Tribak
Jaafar Tribak
H
  • Question
Calendar userform-text selection
Replies
1
Views
6K
hissonrr
H
C
  • Question
Best coding practices in VBA (specifically, code structure, readability, compactness, and the TEBV & TBTO rules)
Replies
1
Views
4K
Marc L
Marc L

Forum statistics

Threads
1,214,912
Messages
6,122,200
Members
449,072
Latest member
DW Draft

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top