UserForm Free Drawing

[Jaafar Tribak]

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

 

[Rick Rothstein]

@Rick Rothstein, the code gets shorter, but IMO it's way more cryptic.

A little less cryptic as to intent... perhaps... but more useful if you need a much larger array of contiguous numbers, say 1 through 1000....

First1000 = [TRANSPOSE(ROW(1:1000))]

And, of course, you could offset the range to produce arrays of contiguous set of numbers starting with something other than 1. For example, here is an array of all 3-digit numbers...

ThreeDigits = [TRANSPOSE(ROW(100:999))]

You could do other ranges as well. For example, this creates an array of all the odd numbers from 1 to 99...

OddNums1To99 = [TRANSPOSE(2*ROW(1:50)-1)]

One of my favorite shortcuts using the short form of the Evaluate function (which is what those square brackets represent) is to create an array of the Month names...

MonthNames = [TRANSPOSE(TEXT(28*ROW(1:12),"mmmm"))]

That last one I'll give you... it's definitely cryptic (which is where descriptive variable names comes in useful).

For all of these example, if you do not mind working with a two-dimensional array where the second dimension is always 1 (you would iterate only the first dimension), you can shorten all of them by removing the TRANSPOSE function call. Of course, if you did that you would not be able to use VBA's array functions such as Filter and Join on them.

 

[audeser]

"You learn something new every day". I agree, the MonthNames one is very fancy, it goes directly to my arsenal.

Returning to the main topic, I was merging Jafaar code with this other one I got from Cosmetics PolePole
(with code spread alongside the site on several pages: 粗品いくつか, メモ帳なめんなよ, a small sample of application here http://www5a.biglobe.ne.jp/~kkw_pl2/fingerkkw/sdata0/officebmp.zip, and a set of integer value constants here: http://www5a.biglobe.ne.jp/~kkw_pl2/fingerkkw/sdata0/tstcl.zip)

There, it's shown how to draw text and some geometrical figures, on a picture box, and some of my trials to directly draw on the userform itself. I upload right now a messy code of the things I've been picking from here and there, so do not blame of the spaguetti, I'm still trying to depurate and figure an idea of where I would like to go. Next month I'll have more time to return to this, and will get all completed, and finally merged with yours, so text and geometrical figures could be done, and return with the finally cleaned code.
The code at the end also came from some Planet Source sample on how to manage a 3D wireframe viewer, that is the first intention of this thing.

Download UserForm from here. Import the userform and press buttons to see things appear from anywhere...

So right now is like this, next post here will be your code merged with some of these.

Option Explicit

Private Const PI = 3.14159265358979
Private Const HALF_PI = 1.5707963267949
Private Const ROTATE_INTERVAL = 1

' This program that can draw any 3D wireframe object
' You can rotate the 3D shape around one axis or the program or you can rotate the shape automatically.

' Circles or ovals can be drawn by using the built-in VB Circle function and mapping its
' coordinates to the location of a lines points stored in the AL array.

Dim PicAngle As Single
Dim MDX As Single, MDY As Single
Dim cx As Single, cy As Single
Dim CenterX As Single, CenterY As Single
Dim AL(1 To 1000000) As AngledLine ' seems like 2 segments structure
Dim CurLineID As Long

Private Type AngledLine
    x1 As Single
    y1 As Single
    
    x2 As Single
    y2 As Single
    
    x3 As Single
    y3 As Single
End Type

Public bDontRun As Boolean

'------------------------------------------
Private Const SPI_GETNONCLIENTMETRICS = 41
Private Const SPI_SETNONCLIENTMETRICS = 42
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const MAGICX As Long = 30
Private Const MAGICY As Long = 48
Dim PixelsX As Long
Dim PixelsY As Long

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type RECT
    Left As Long
    TOP As Long
    Right As Long
    Bottom As Long
End Type

Private DPI_MONITOR As Long
Private PixelsPerInchX As Long
Private PixelsPerInchY As Long

Dim startX As Single, startY As Single
#If VBA7 Then
    Private hFrmDC As LongPtr
#Else
    Private hFrmDC As Long
#End If
Private blnDraw As Boolean

Dim p_mb As POINTAPI
Dim p As POINTAPI
'------------------------------------------

' The size of "SCREEN"
Private Const CWIDTH = 320
Private Const CHEIGHT = 240

' https://vbhelponline.com/drawing-functions-15285

'#If VBA7 Then
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As LongPtr

    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As Long
    
    ' to draw a line
    Private Declare PtrSafe Function LineTo Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long) As LongPtr
    Private Declare PtrSafe Function MoveToEx Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As LongPtr
    
    Private Declare PtrSafe Function Polyline Lib "gdi32" (ByVal hDC As LongPtr, lpPoint As POINTAPI, ByVal nCount As Long) As LongPtr
    Private Declare PtrSafe Function PolylineTo Lib "gdi32.dll" (ByVal hDC As LongPtr, lppt As POINTAPI, ByVal cCount As Long) As LongPtr
    Private Declare PtrSafe Function Polygon Lib "gdi32" (ByVal hDC As LongPtr, lpPoint As POINTAPI, ByVal nCount As Long) As LongPtr
    Private Declare PtrSafe Function Rectangle Lib "gdi32" (ByVal hDC As LongPtr, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As LongPtr
    Private Declare PtrSafe Function Ellipse Lib "gdi32" (ByVal hDC As LongPtr, ByVal nLeftRect As Long, ByVal nTopRect As Long, ByVal nRightRect As Long, ByVal nBottomRect As Long) As LongPtr
    Private Declare PtrSafe Function AngleArc Lib "gdi32.dll" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal dwRadius As Long, ByVal eStartAngle As Single, ByVal eSweepAngle As Single) As LongPtr
    
    
    ' for Bitmap file
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
    Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hDC As LongPtr, pbmi As BITMAPINFO, ByVal iUsage As Long, ByVal ppvBits As Long, ByVal hSection As Long, ByVal dwOffset As Long) As Long
    Private Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hgdiobj As Long) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    
    ' to draw lines and shapes
    Private Declare PtrSafe Function CreatePen Lib "gdi32" (ByVal fnPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
    
    ' for filling
    Private Declare PtrSafe Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
    
    ' for character insertion
    Private Declare PtrSafe Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal IfdwItalic As Long, ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As LongPtr
    Private Declare PtrSafe Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function SetBkColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As LongPtr
'#Else
'#End If

' 1st argument of CreatePen
' Line type (only seen based on scaled)
Private Const PS_SOLID = 0
Private Const PS_DASH = 1
Private Const PS_DOT = 2
Private Const PS_DASHDOT = 3
Private Const PS_DASHDOTDOT = 4
Private Const PS_NULL = 5
Private Const PS_INSIDEFRAME = 6

' 5th argument of CreateFont
Private Const FW_DONTCARE = 0
Private Const FW_THIN = 100
Private Const FW_EXTRALIGHT = 200
Private Const FW_LIGHT = 300
Private Const FW_NORMAL = 400
Private Const FW_MEDIUM = 500
Private Const FW_SEMIBOLD = 600
Private Const FW_BOLD = 700
Private Const FW_EXTRABOLD = 800
Private Const FW_HEAVY = 900

' 9th argument of CreateFont
Private Const ANSI_CHARSET = 0
Private Const DEFAULT_CHARSET = 1
Private Const OEM_CHARSET = 255
Private Const SHIFTJIS_CHARSET = 128
Private Const SYMBOL_CHARSET = 2
Private Const BALTIC_CHARSET = 186
Private Const CHINESEBIG5_CHARSET = 136
Private Const EASTEUROPE_CHARSET = 238
Private Const GREEK_CHARSET = 161
Private Const HANGEUL_CHARSET = 129
Private Const MAC_CHARSET = 77
Private Const RUSSIAN_CHARSET = 204
Private Const TURKISH_CHARSET = 162

' 10th argument of CreateFont
Private Const OUT_CHARACTER_PRECIS = 2
Private Const OUT_DEFAULT_PRECIS = 0
Private Const OUT_DEVICE_PRECIS = 5
Private Const OUT_OUTLINE_PRECIS = 8
Private Const OUT_RASTER_PRECIS = 6
Private Const OUT_STRING_PRECIS = 1
Private Const OUT_STROKE_PRECIS = 3
Private Const OUT_TT_ONLY_PRECIS = 7
Private Const OUT_TT_PRECIS = 4

' 11th argument of CreateFont
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const CLIP_EMBEDDED = 128
Private Const CLIP_LH_ANGLES = 16
Private Const CLIP_MASK = &HF
Private Const CLIP_STROKE_PRECIS = 2
Private Const CLIP_TO_PATH = 4097
Private Const CLIP_TT_ALWAYS = 32

' 12th argument of CreateFont
Private Const DEFAULT_QUALITY = 0
Private Const DRAFT_QUALITY = 1
Private Const PROOF_QUALITY = 2

' 13th argument of CreateFont
Private Const DEFAULT_PITCH = 0
Private Const FIXED_PITCH = 1
Private Const VARIABLE_PITCH = 2
Private Const FF_DECORATIVE = 80
Private Const FF_DONTCARE = 0
Private Const FF_MODERN = 48
Private Const FF_ROMAN = 16
Private Const FF_SCRIPT = 64
Private Const FF_SWISS = 32

' 5th argument of DrawText
Private Const DT_BOTTOM = &H8
Private Const DT_CALCRECT = &H400
Private Const DT_CENTER = &H1
Private Const DT_CHARSTREAM = 4
Private Const DT_DISPFILE = 6
Private Const DT_EXPANDTABS = &H40
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_INTERNAL = &H1000
Private Const DT_METAFILE = 5
Private Const DT_LEFT = &H0
Private Const DT_NOCLIP = &H100
Private Const DT_NOPREFIX = &H800
Private Const DT_PLOTTER = 0
Private Const DT_RASCAMERA = 3
Private Const DT_RASDISPLAY = 1
Private Const DT_RASPRINTER = 2
Private Const DT_RIGHT = &H2
Private Const DT_SINGLELINE = &H20
Private Const DT_TABSTOP = &H80
Private Const DT_TOP = &H0
Private Const DT_VCENTER = &H4
Private Const DT_WORDBREAK = &H10

Private Const DIB_RGB_COLORS = 0
Private Const DIB_PAL_COLORS = 1
Private Const DIB_PAL_INDICES = 2

' Used as an argument to GetStockObject for fill
Private Const NULL_BRUSH = 5
Private Const BLACK_BRUSH = 4
Private Const DKGRAY_BRUSH = 3
Private Const GRAY_BRUSH = 2
Private Const HOLLOW_BRUSH = NULL_BRUSH
Private Const LTGRAY_BRUSH = 1
Private Const WHITE_BRUSH = 0
Private Const BLACK_PEN = 7
Private Const WHITE_PEN = 6
Private Const ANSI_FIXED_FONT = 11
Private Const ANSI_VAR_FONT = 12
Private Const DEVICE_DEFAULT_FONT = 14
Private Const DEFAULT_GUI_FONT = 17
Private Const OEM_FIXED_FONT = 10
Private Const SYSTEM_FONT = 13
Private Const SYSTEM_FIXED_FONT = 16
Private Const DEFAULT_PALETTE = 15

#If VBA7 Then
    Private hUsrFrmDC As LongPtr
    
    Private myDC0 As LongPtr, myDC1 As LongPtr
    Private myBMP As LongPtr
    Private myPen As LongPtr
    Private myBrush As LongPtr
    Private myFont As LongPtr
    Private hdlPen As LongPtr
    Private hdlBrush As LongPtr
#Else
    Private hUsrFrmDC As Long
    
    Private myDC0 As Long, myDC1 As Long
    Private myBMP As Long
    Private myPen As Long
    Private myBrush As Long
    Private myFont As Long
    Private hdlPen As Long
    Private hdlBrush As Long
#End If
Private myFntFamily As String
Private myRct As RECT
Private myPnt As POINTAPI

'----------------------------------
' Bitmap structure
Private Type BITMAPFILEHEADER
    bfType As String * 2
    bfSize As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits As Long
End Type

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 BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
End Type

Private myBMPInf As BITMAPINFO, myBMPFLHdr As BITMAPFILEHEADER, myBMPBits() As Byte
Private myStrFile As String, iFileOut As Long
'----------------------------------

Private Sub UserForm_Initialize()
    ' Get graphical parameters
    Call api_GetPPI
    DPI_MONITOR = Application.InchesToPoints(1) ' most of the time = 72 (but could be 96,...)

#If VBA7 Then
    Dim hDC As LongPtr
#Else
    Dim hDC As Long
#End If
    Const LOGPIXELSX = 88
    Const LOGPIXELSY = 90

    hDC = GetDC(0)
    PixelsPerInchX = GetDeviceCaps(hDC, LOGPIXELSX)
    PixelsPerInchY = GetDeviceCaps(hDC, LOGPIXELSY)
    ReleaseDC 0, hDC
        
    ' Show the CANVAS
    Me.Show
    Call fCanvas_Create
End Sub

Private Sub btUserFrm_DrawLines_Click()
' Draw lines in userform
    Dim i As Long
    
    hUsrFrmDC = GetDC(GetActiveWindow) ' this get's the userform handle
    Me.Repaint
    'DoEvents
    For i = 1 To 10
        DrawLine hUsrFrmDC, Rnd() * 15, Rnd() * 15, 300, (Me.InsideHeight * 4 / 3) - 8
    Next i
End Sub

#If VBA7 Then
Private Sub DrawLine(ByVal hDC As LongPtr, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, _
                     Optional ByVal hPen As LongPtr)
#Else
Private Sub DrawLine(ByVal hDC As LongPtr, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, _
                     Optional ByVal hPen As Long)
#End If
' hDC: Device cap handle

    Dim oPtTmp As POINTAPI
    
    MoveToEx hDC, x1, y1, oPtTmp
    LineTo hDC, x2, y2

' ------
' Draw a triangle having corners (100,100), (200, 150), and (0, 150) on window Form1.
' Note how since we want the first and last points to be connected,
' point (100,100) must be given as both the first and last points.
    
    Dim points(0 To 3) As POINTAPI  ' the points to draw to/from
    Dim retval As LongPtr  ' return value
    
    ' Put the points to use into the array.  Four points must be specified to draw the
    ' triangle because the point (100,100) must be entered twice.
    points(0).x = 100: points(0).y = 100  ' point #0: (100,100)
    points(1).x = 200: points(1).y = 150  ' point #1: (200,150)
    points(2).x = 0: points(2).y = 150  ' point #2: (0,150)
    points(3) = points(0)
    
    retval = Polyline(hDC, points(0), 4)  ' draw the lines

'-----
' draw a polyline
    Dim Pts() As POINTAPI
    
    ReDim Pts(0 To 3)
    With Pts(0)
        .x = 10 '* Rnd()
        .y = 10 '* Rnd()
    End With
    With Pts(1)
        .x = 100 '* Rnd()
        .y = 100 '* Rnd()
    End With
    With Pts(2)
        .x = 200 '* Rnd()
        .y = 200 '* Rnd()
    End With
    With Pts(3)
        .x = 1000 '* Rnd()
        .y = 1000 '* Rnd()
    End With
    
    Polyline hDC, Pts(0), UBound(Pts) - LBound(Pts) + 1

'-----
    ' Draw a red triangle with corners (100,100), (200,150), and (0,150)
    ' on window Form1.  The current point must first be set to (100,100), and the last
    ' point must also be given as (100,100) to close the triangle.
    Dim points_(0 To 2) As POINTAPI  ' points given to the function
    Dim curpt As POINTAPI  ' receives current point from MoveToEx
    
    ' Set Form1's current point to (100,100)
    retval = MoveToEx(hDC, 100, 100, curpt)
    
    ' Load the points of the triangle into the array points().  Notice that (100,100)
    ' is given as the last point to close the figure.
    points_(0).x = 330: points_(0).y = 150          ' point #0: (200,150)
    points_(1).x = 28: points_(1).y = 150            ' point #1: (0,150)
    points_(2).x = 170: points_(2).y = 100          ' point #2: (100,100)
    
    retval = PolylineTo(hDC, points_(0), 3)    ' draw the lines
End Sub

#If VBA7 Then
Private Sub DrawRectangle(ByVal hDC As LongPtr, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, _
                          Optional ByVal hPen As LongPtr, Optional ByVal hBrush As LongPtr)
#Else
Private Sub DrawRectangle(ByVal hDC As LongPtr, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, _
                          Optional ByVal hPen As Long, Optional ByVal hBrush As Long)
#End If

End Sub

#If VBA7 Then
Private Sub DrawEllipse(ByVal hDC As LongPtr, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, _
                        Optional ByVal hPen As LongPtr, Optional ByVal hBrush As LongPtr)
#Else
Private Sub DrawEllipse(ByVal hDC As LongPtr, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long, _
                        Optional ByVal hPen As Long, Optional ByVal hBrush As Long)
#End If

End Sub

Private Sub btCanvas_New_Click()
' create a fresh Bitmap (new black)
    
    Call fCanvas_Create
    
    '............................
    'If you want to draw various things, write them here
    '............................

' show the drawing via BMP
    fCanvasToBMP
End Sub

Private Sub btCanvas_WhiteBackground_Click()
    myPen = CreatePen(PS_SOLID, 0, RGB(255, 255, 255)) ' Pick a pen (white)
    Call SelectObject(myDC1, myPen)
    myBrush = GetStockObject(WHITE_BRUSH) 'Decide how to fill (white)
    Call SelectObject(myDC1, myBrush)
    Call Rectangle(myDC1, 0, 0, CWIDTH, CHEIGHT) 'Draw a rectangle the same size as the Bitmap (becomes completely white)
    
    'Discard the old pen and brush
    Call DeleteObject(myPen)
    Call DeleteObject(myBrush)

' show the drawing via BMP
    fCanvasToBMP
End Sub

Private Function fPen(Optional ByVal LineType As Long = PS_SOLID, _
                      Optional ByVal PenWidth As Long = 0, _
                      Optional ByVal Color As Long = vbWhite) As Boolean
    Dim lgRetVal As Long
    
    myPen = CreatePen(LineType, PenWidth, Color)
    lgRetVal = SelectObject(myDC1, myPen)
'    fPen = myPen
End Function
    
Private Function fBrush(Optional ByVal Color As Long = WHITE_BRUSH) As Boolean
    Dim lgRetVal As Long
    
    myBrush = GetStockObject(Color)
    lgRetVal = SelectObject(myDC1, myBrush)
'    fBrush = myBrush
End Function

Private Sub btUserFrm_DrawPolyLine_Click()
    'Call fPen(PS_SOLID, 0, vbWhite)
    'Call fBrush(vbWhite)
    'Call Rectangle(myDC1, 0, 0, CWIDTH, CHEIGHT)
    'Call DeleteObject(myPen)
    'Call DeleteObject(myBrush)
    
    ' Newly prepare a pen and brush
    myPen = CreatePen(PS_SOLID, 6, vbRed)
    Call SelectObject(myDC1, myPen)
    myBrush = GetStockObject(BLACK_BRUSH)
    Call SelectObject(myDC1, myBrush)
    
    ' draw a polyline
    Dim Pts() As POINTAPI
    
    ReDim Pts(0 To 3)
    With Pts(0)
        .x = 10 '* Rnd()
        .y = 10 '* Rnd()
    End With
    With Pts(1)
        .x = 100 '* Rnd()
        .y = 100 '* Rnd()
    End With
    With Pts(2)
        .x = 200 '* Rnd()
        .y = 200 '* Rnd()
    End With
    With Pts(3)
        .x = 1000 '* Rnd()
        .y = 1000 '* Rnd()
    End With
    
    Polyline myDC1, Pts(0), UBound(Pts) - LBound(Pts) + 1

    Call DeleteObject(myPen)
    Call DeleteObject(myBrush)

' show the drawing via BMP
    fCanvasToBMP
End Sub

Private Sub Command1_Click()
    Dim i As Integer
    'For I = 0 To 4
    '    If Option1(I).Value = True Then Exit For
    'Next I
    'Image1.Cls
    
    i = 3
    Call Draw_Shape(Image1, i)
End Sub

Private Sub btCanvas_DrawShapes_Click()
' drawing a shape or line
    Call fPen(PS_SOLID, 0, vbWhite)
    Call fBrush(vbWhite)
    Call Rectangle(myDC1, 0, 0, CWIDTH, CHEIGHT)
    Call DeleteObject(myPen)
    Call DeleteObject(myBrush)
    
    ' Newly prepare a pen and brush
    myPen = CreatePen(PS_SOLID, 6, vbRed)
    Call SelectObject(myDC1, myPen)
    myBrush = GetStockObject(BLACK_BRUSH)
    Call SelectObject(myDC1, myBrush)
    ' draw a circle
    Call Ellipse(myDC1, 100, 110, 200, 210)
    
    Call DeleteObject(myPen)
    Call DeleteObject(myBrush)
    
    ' Newly prepare a pen and brush
    myPen = CreatePen(PS_SOLID, 10, RGB(0, 0, 255))
    Call SelectObject(myDC1, myPen)
    myBrush = GetStockObject(GRAY_BRUSH)
    Call SelectObject(myDC1, myBrush)
    
    ' draw a rectangle
    Call Rectangle(myDC1, 10, 50, 60, 100)
    
    Call DeleteObject(myPen)
    Call DeleteObject(myBrush)
    
    ' Prepare a pen again
    myPen = CreatePen(PS_SOLID, 2, vbBlue)
    Call SelectObject(myDC1, myPen)
    
    ' draw a straight line
    Call MoveToEx(myDC1, 150, 50, myPnt) ' Set a start point
    Call LineTo(myDC1, 300, 50) ' Draw a line here
    
    Call DeleteObject(myPen) 'Destroy the pen

' show the drawing via BMP
    fCanvasToBMP
End Sub

Private Sub btCanvas_InsertText_Click()
' inserting text
    
    ' First, fill it with pure white
    myPen = CreatePen(PS_SOLID, 0, RGB(255, 255, 255))
    Call SelectObject(myDC1, myPen)
    myBrush = GetStockObject(WHITE_BRUSH)
    Call SelectObject(myDC1, myBrush)
    
    ' draw a white rectangle
    Call Rectangle(myDC1, 0, 0, CWIDTH, CHEIGHT)
    
    Call DeleteObject(myPen) ' Destroy pen and brush
    Call DeleteObject(myBrush)
    
    ' Below, put letters.
    ' You don't need a pen if you just want to insert letters.
    ' Prepare the font
    myFont = CreateFont(18, 0, 0, 0, FW_NORMAL, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH Or FF_SCRIPT, myFntFamily)
    Call SelectObject(myDC1, myFont)
    
    ' Set a boundary limit
    With myRct
        .Left = 10
        .TOP = 50
        .Right = 310
        .Bottom = 75
    End With
    
    Call SetTextColor(myDC1, RGB(255, 0, 0)) '
    Call SetBkColor(myDC1, RGB(0, 0, 0))  ' Set background color
    Call DrawText(myDC1, "AIUEOKAKIKUKEKO", -1, myRct, DT_CENTER Or DT_SINGLELINE)
    
    ' Set a boundary limit
    With myRct
        .TOP = 70
        .Bottom = 95
    End With
    
    Call SetTextColor(myDC1, RGB(255, 255, 255))
    Call SetBkColor(myDC1, RGB(0, 255, 0))
    Call DrawText(myDC1, "Sashisuseso Tatsutetsu to Naninune", -1, myRct, DT_CENTER Or DT_SINGLELINE)
    
    ' If new next have different sizes and different designs, discard the font that has been used for the time being
    Call DeleteObject(myFont)
    
    ' A new font is prepared
    myFont = CreateFont(24, 0, 0, 0, FW_BOLD, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH Or FF_SCRIPT, myFntFamily)
    Call SelectObject(myDC1, myFont)
    
    ' Set a boundary limit
    With myRct
        .TOP = 90
        .Bottom = 115
    End With
    
    Call SetTextColor(myDC1, RGB(0, 0, 255))
    Call SetBkColor(myDC1, RGB(255, 0, 0))
    Call DrawText(myDC1, "Hahifuheho", -1, myRct, DT_CENTER Or DT_SINGLELINE)
    
    Call DeleteObject(myFont) 'Destroy font
    
' show the drawing via BMP
    fCanvasToBMP
End Sub

Private Function fCanvas_Create()
    myDC0 = GetDC(0)
    myDC1 = CreateCompatibleDC(myDC0)
    With myBMPInf.bmiHeader
        .biSize = 40
        .biWidth = CWIDTH
        .biHeight = CHEIGHT
        .biPlanes = 1
        .biBitCount = 24 '32 or 24 or 8 or 4 as you like (8 is 256 colors, 4 is 16 colors only)
    End With
    myBMP = CreateDIBSection(myDC1, myBMPInf, 0, 0, 0, 0)
    Call SelectObject(myDC1, myBMP)
End Function

Private Sub DeleteTmpBMP(ByVal strFile As String)
' This may not be necessary (roughly, it is overwritten even if it remains)
    
    Dim MyFSO As Object

    Set MyFSO = CreateObject("Scripting.FileSystemObject")
    If MyFSO.FileExists(strFile) = True Then MyFSO.DeleteFile strFile
    Set MyFSO = Nothing
End Sub

Private Sub btCanvas_ExportToBMP_Click()
    Call fCanvasToBMP
End Sub

Private Function fCanvasToBMP()
' Export canvas to BMP file
    
    myStrFile = ThisWorkbook.Path & "\tmp00.bmp"    'For Excel
    'myStrFile = ActiveDocument.Path & "\tmp00.bmp" 'For Word
    'myStrFile = CurrentProject.Path & "\tmp00.bmp" 'For Access

    Call GetDIBits(myDC1, myBMP, 0, CHEIGHT, ByVal 0&, myBMPInf, 0)
    ReDim myBMPBits(myBMPInf.bmiHeader.biSizeImage - 1)
    Call GetDIBits(myDC1, myBMP, 0, CHEIGHT, myBMPBits(0), myBMPInf, 0)
    iFileOut = FreeFile
    Open myStrFile For Binary As #iFileOut
    With myBMPFLHdr
        .bfType = "BM"
        .bfReserved1 = 0
        .bfReserved2 = 0
        .bfSize = Len(myBMPFLHdr) + Len(myBMPInf) + UBound(myBMPBits) + 1
        .bfOffBits = Len(myBMPFLHdr) + Len(myBMPInf)
    End With
    Put #iFileOut, , myBMPFLHdr
    Put #iFileOut, , myBMPInf
    Put #iFileOut, , myBMPBits
    Close #iFileOut

    Me.Image1.Picture = LoadPicture(myStrFile)  'For Excel, Word
    'Me.Image1.Picture = myStrFile              'For Access
End Function

Private Sub UserForm_Terminate()
    Call DeleteObject(myBMP)
    Call DeleteObject(myDC1)
    Call ReleaseDC(0, myDC0)
End Sub

'-----------------------

Private Function Radians(ByVal Degrees As Single) As Single
    Radians = Degrees * PI / 180
End Function

Private Function Degrees(ByVal Radians As Single) As Single
    Degrees = Radians / PI * 180
End Function


'-------------------------------------------------------
' https://exceloffthegrid.com/vba-convert-centimeters-inches-pixels-to-points/
' https://www.excelforum.com/excel-programming-vba-macros/396779-and-once-again-x-and-y-screen-coordinates-of-a-range.html

' Converting from inches or centimeters into points is reasonably straightforward,
' as there are 72 points to an inch or 28.35 points to a centimeter (rounded to 2 decimal places).
' Microsoft has provided two useful VBA function to make this conversion

Private Function InchesToPoints(valueInches As Single) As Single
'Convert from Inches to Points
    InchesToPoints = Application.InchesToPoints(valueInches)
End Function

Private Function CmToPoints(valueCentimeters As Single) As Single
'Convert from Centimeters to Points
    CmToPoints = Application.CentimetersToPoints(valueCentimeters)
End Function

Private Function PointsToCm(valuePoints As Single) As Single
'Convert from Points to Centimeters
    PointsToCm = valuePoints / Application.CentimetersToPoints(1)
End Function

Private Function PointsToInches(valuePoints As Single) As Single
'Convert from Points to Inches
    PointsToInches = valuePoints / Application.InchesToPoints(1)
End Function

Private Function PointsToPixels(valuePoints As Single, ByVal bHorizontal As Boolean) As Long
' Converting from Points to Pixels
' Whilst Pixels may seem to be an understandable unit of measure for the purposes of controlling positions of objects,
' it’s not as useful as you might expect, as the number of pixels will depend on a variety of factors (such as screen resolution used for each monitor, usually 96ppi).

    If bHorizontal Then
        PointsToPixels = Application.ActiveWindow.PointsToScreenPixelsX(valuePoints)
    Else
        PointsToPixels = Application.ActiveWindow.PointsToScreenPixelsY(valuePoints)
    End If
End Function

Private Sub GetPositionInScreeenPoints(ByVal Left As Double, ByVal TOP As Double, ByRef x As Double, ByRef y As Double)
' on Excel...
    Dim CurrentZoomRatio As Long
    
    CurrentZoomRatio = ActiveWindow.Zoom / 100
    
    x = ActiveWindow.PointsToScreenPixelsX(0) + Left * CurrentZoomRatio * PixelsPerInchX / DPI_MONITOR
    x = VBA.Round(x, 0) * DPI_MONITOR / PixelsPerInchX
    
    y = ActiveWindow.PointsToScreenPixelsY(0) + TOP * CurrentZoomRatio * PixelsPerInchY / DPI_MONITOR
    y = VBA.Round(y, 0) * DPI_MONITOR / PixelsPerInchY
End Sub

Private Function api_GetPPI(Optional pbHorizontal As Boolean = True) As Long
' get pixels per inch. my monitor is 96 ppi.

   'PARAMETER
   '  pbHorizontal=True to return horizontal ppi, else vertical ppi

   Const LOGPIXELSX = 88 'pixels/inch in X, logical monitor
   Const LOGPIXELSY = 90 'pixels/inch in Y

   'dimension Handle
   #If VBA7 And Win64 Then
      Dim hDC As LongPtr
   #Else
      Dim hDC As Long
   #End If

   'set handle
   hDC = GetDC(0) ' The active window

   If pbHorizontal <> True Then
      'Vertical ppi
      api_GetPPI = GetDeviceCaps(hDC, LOGPIXELSY)   'LOGPIXELSY=90
   Else
      'Horizontal ppi
      api_GetPPI = GetDeviceCaps(hDC, LOGPIXELSX)   'LOGPIXELSX=88
   End If

   'release handle
   hDC = ReleaseDC(0, hDC)
End Function

'Private Sub UserForm_Initialize()
'    If bDontRun Then
'        bDontRun = False
'        Exit Sub
'    End If
'
'    'retrieve the UserForm Window handle and use that to return its Device Context
'    hFrmDC = GetDC(GetActiveWindow)
'
'    Me.Show
''Stop
'    Call Initialize
'End Sub
'
'Sub AnimatePic()
'' RotatePic is a timer control
'
'' Alternative https://stackoverflow.com/questions/1562913/timer-on-user-form-in-excel-vba
''    If RotatePic.Enabled = False Then
''        RotatePic.Enabled = True
''    Else
''        RotatePic.Enabled = False
''    End If
'End Sub
'
'Private Sub btReset_Click()
'    'Unload Me
'    bDontRun = True
'    Me.Repaint
'End Sub
'
''Private Sub clearForm()
''    Dim ctrl As Control
''    For Each ctrl In Me.Controls
''        If ctrl.Name <> "TextBox1" Then
''            Range(ctrl.Tag).Value = vbNullString
''        End If
''    Next ctrl
''End Sub
'
'Private Sub DrawPic()
'    CurLineID = 1 ' index to store in AL()
'    Me.Repaint 'VB6: Me.Cls
'    DrawCuboid CX, CY, 150, 100, 50
'End Sub
'
'Private Sub Initialize()
'    CX = Me.Width / 2
'    CY = Me.Height / 2
'    CenterX = CX
'    CenterY = CY
'    PicAngle = 60
'    RotateAngle.Caption = PicAngle
'    DrawPic
'End Sub
'
'Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'    'store the mouse pointer starting positions
'    If Button = 1 Then 'If Button = vbLeftButton And RotatePic.Enabled = False Then
'        MDX = X
'        MDY = Y
'
'        startX = X
'        startY = Y
'        startX = X
'        startY = Y
'    End If
'
'    'permit continuous drawing
'    blnDraw = True
'End Sub
'
'Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'    'only draw continuously if the user wants to draw freehand
''!    If Not Me.optFreehand Then Exit Sub
'
'    'only draw if the mouse button is held down
''!    If Not blnDraw Then Exit Sub
'
'    'make sure it's the left mouse button
'    If Button = 1 Then 'Button = vbLeftButton
'        Dim XD As Single
'        Dim YD As Single
'
'        XD = X - MDX
'        YD = Y - MDY
'
'        If XD > 1 Then
'            PicAngle = PicAngle + ROTATE_INTERVAL
'            If PicAngle = 360 Then PicAngle = 0
'        ElseIf XD < 1 Then
'            PicAngle = PicAngle - ROTATE_INTERVAL
'            If PicAngle = -360 Then PicAngle = 0
'        End If
'
'        RotateAngle.Caption = PicAngle
'
'        DrawPic
'
''--------------------------------------------------------------------------
'        'supply the UDT mouse position values as pixels
'        p.X = startX
'        p.Y = startY
'
'        'pass the UDT to the API to specify where the drawing begins
'        MoveToEx hFrmDC, p.X, p.Y, p
'
'        'pass the current mouse position to the API to draw the line
'        LineTo hFrmDC, Get_PixelsFromPoints(X, True), Get_PixelsFromPoints(Y, False)
'
'        're-assign the drawing start position
'        startX = Get_PixelsFromPoints(X, True)
'        startY = Get_PixelsFromPoints(Y, False)
'    End If
'End Sub

'Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
'    blnDraw = False
'
'    'only draw direct if the user wants to draw straight lines only
'    'If Me.optFreehand Then Exit Sub
'
'    'draw lines direct to the current mouse position and terminate the drawing process
'    'same-same but different
'    If Button = 1 Then
'        sDrawLine startX, startY, Get_PixelsFromPoints(X, True), Get_PixelsFromPoints(Y, False)
'    End If
'End Sub
'
'Private Function Get_PixelsFromPoints(Position As Single, bHorizontal As Boolean) As Single
''???? any
'' Maybe use LOGPIXEL
'End Function
''
''Private Sub UserForm_Resize()
''    Call Initialize
''End Sub
'
'Private Sub RotatePic_Timer()
'    PicAngle = PicAngle + ROTATE_INTERVAL
'    If PicAngle = 360 Then PicAngle = 0
'    DrawPic
'    RotateAngle.Caption = PicAngle
'End Sub
'
'Private Sub ToggleAnimation_Click()
'    AnimatePic
'End Sub
'
Private Sub sDrawLine(ByVal x1 As Single, ByVal y1 As Single, _
                      ByVal x2 As Single, ByVal y2 As Single)
    Dim oPoint As POINTAPI

    'supply the UDT mouse position values as pixels
    oPoint.x = x1
    oPoint.y = y1

    'pass the UDT to the API to specify where to the drawing began
    MoveToEx hFrmDC, x1, y1, p

    'pass the current mouse position to the API for drawing the line
    LineTo hFrmDC, x2, y2
End Sub

Private Sub DrawCuboid(ByVal x As Single, _
                       ByVal y As Single, _
                       ByVal Width As Single, _
                       ByVal Depth As Single, _
                       ByVal Height As Single)
'ie: DrawCuboid CX, CY, 150, 100, 50
    
    CenterX = x
    CenterY = y
    AngleLine (Depth / 2), Width, HALF_PI, CurLineID
    AngleLine (Width / 2), Depth, PI, CurLineID, HALF_PI
    AngleLine -(Depth / 2), Width, HALF_PI, CurLineID
    AngleLine -(Width / 2), Depth, PI, CurLineID, HALF_PI
    CenterY = y + Height
    AngleLine (Depth / 2), Width, HALF_PI, CurLineID
    AngleLine (Width / 2), Depth, PI, CurLineID, HALF_PI
    AngleLine -(Depth / 2), Width, HALF_PI, CurLineID
    AngleLine -(Width / 2), Depth, PI, CurLineID, HALF_PI
    CenterY = y
    AngleLineXY AL(1).x2, AL(1).y2, Height, PI, CurLineID
    AngleLineXY AL(1).x3, AL(1).y3, Height, PI, CurLineID
    AngleLineXY AL(2).x3, AL(2).y3, Height, PI, CurLineID
    AngleLineXY AL(4).x3, AL(4).y3, Height, PI, CurLineID
End Sub

Private Sub AngleLineXY(x As Single, _
                        y As Single, _
                        LineLength As Single, _
                        AngleRAD As Single, _
                        LineID As Long, _
                        Optional Color As Long = vbBlack)
    Dim x1 As Single
    Dim y1 As Single
    Dim x2 As Single
    Dim y2 As Single

    x1 = CenterX + x
    y1 = CenterY + y
    x2 = x1 + (Cos(AngleRAD - HALF_PI) * LineLength)
    y2 = y1 + (Sin(AngleRAD - HALF_PI) * LineLength)

Stop
'!    sDrawLine X1, Y1, X2, Y2 'Me.Line (X1, Y1)-(X2, Y2)

    AL(LineID).x1 = x1 - CenterX
    AL(LineID).y1 = y1 - CenterY
    AL(LineID).x2 = x2 - CenterX
    AL(LineID).y2 = y2 - CenterY

    CurLineID = CurLineID + 1
End Sub

Private Sub AngleLine(ByVal RadiusLength As Single, _
                      ByVal LineLength As Single, _
                      ByVal AngleRAD As Single, _
                      ByRef LineID As Long, _
                      Optional ByVal ExtraPicAngle As Single)
    Dim RPicAngle As Single
    Dim x1 As Single
    Dim y1 As Single
    Dim x2 As Single
    Dim y2 As Single
    Dim x3 As Single
    Dim y3 As Single

    RPicAngle = Radians(PicAngle)

    x1 = CenterX + (Cos(ExtraPicAngle + RPicAngle - HALF_PI) * RadiusLength)
    y1 = CenterY + (Sin(ExtraPicAngle + RPicAngle - HALF_PI) * RadiusLength)
    x2 = x1 + (Cos((RPicAngle) + AngleRAD - HALF_PI + PI) * (LineLength / 2))
    y2 = y1 + (Sin((RPicAngle) + AngleRAD - HALF_PI + PI) * (LineLength / 2))
    x3 = x1 + (Cos((RPicAngle) + AngleRAD - HALF_PI) * (LineLength / 2))
    y3 = y1 + (Sin((RPicAngle) + AngleRAD - HALF_PI) * (LineLength / 2))
Stop
'!    sDrawLine X1, Y1, X2, Y2 'Me.Line (X1, Y1)-(X2, Y2)
'!    sDrawLine X1, Y1, X3, Y3 'Me.Line (X1, Y1)-(X3, Y3)

    AL(LineID).x1 = x1 - CenterX
    AL(LineID).y1 = y1 - CenterY
    AL(LineID).x2 = x2 - CenterX
    AL(LineID).y2 = y2 - CenterY
    AL(LineID).x3 = x3 - CenterX
    AL(LineID).y3 = y3 - CenterY

    CurLineID = CurLineID + 1
End Sub

Private Sub Draw_Shape(PBox As Control, PNum As Integer)
'Set up a general procedure to draw a particular shape number (PNum) in a general control (PBox). This procedure can draw one of five shapes (0-Square, 1-Rectangle, 2-Triangle, 3-Hexagon, 4-Octagon). For each shape, it establishes some margin area (DeltaX and DeltaY) and then defines the vertices of the shape using the V array (a POINTAPI type variable).
    Dim v(1 To 8) As POINTAPI, Rtn As Long
    Dim DeltaX As Integer, DeltaY As Integer
    
    'PBox.ScaleWidth = 55
    'PBox.ScaleHeight = 56
    Select Case PNum
        Case 0
            'Square
            DeltaX = 0.05 * 55
            DeltaY = 0.05 * 56
            v(1).x = DeltaX: v(1).y = DeltaY
            v(2).x = 55 - DeltaX: v(2).y = v(1).y
            v(3).x = v(2).x: v(3).y = 56 - DeltaY
            v(4).x = v(1).x: v(4).y = v(3).y
            Rtn = Polygon(myDC1, v(1), 4)
            
        Case 1
            'Rectangle
            DeltaX = 0.3 * 55
            DeltaY = 0.05 * 56
            v(1).x = DeltaX: v(1).y = DeltaY
            v(2).x = 55 - DeltaX: v(2).y = v(1).y
            v(3).x = v(2).x: v(3).y = 56 - DeltaY
            v(4).x = v(1).x: v(4).y = v(3).y
            Rtn = Polygon(myDC1, v(1), 4)
            
        Case 2
            ' Triangle
            DeltaX = 0.05 * 55
            DeltaY = 0.05 * 56
            v(1).x = DeltaX: v(1).y = 56 - DeltaY
            v(2).x = 0.5 * 55: v(2).y = DeltaY
            v(3).x = 55 - DeltaX: v(3).y = v(1).y
            Rtn = Polygon(myDC1, v(1), 3)
            
        Case 3
            'Hexagon
            DeltaX = 0.05 * 55
            DeltaY = 0.05 * 56
            v(1).x = DeltaX: v(1).y = 0.5 * 56
            v(2).x = 0.25 * 55: v(2).y = DeltaY
            v(3).x = 0.75 * 55: v(3).y = v(2).y
            v(4).x = 55 - DeltaX: v(4).y = v(1).y
            v(5).x = v(3).x: v(5).y = 56 - DeltaY
            v(6).x = v(2).x: v(6).y = v(5).y
            Rtn = Polygon(myDC1, v(1), 6)
            
        Case 4
            'Octagon
            DeltaX = 0.05 * 55
            DeltaY = 0.05 * 56
            v(1).x = DeltaX: v(1).y = 0.3 * 56
            v(2).x = 0.3 * 55: v(2).y = DeltaY
            v(3).x = 0.7 * 55: v(3).y = v(2).y
            v(4).x = 55 - DeltaX: v(4).y = v(1).y
            v(5).x = v(4).x: v(5).y = 0.7 * 56
            v(6).x = v(3).x: v(6).y = 56 - DeltaY
            v(7).x = v(2).x: v(7).y = v(6).y
            v(8).x = v(1).x: v(8).y = v(5).y
            Rtn = Polygon(myDC1, v(1), 8)
    End Select
End Sub

Private Sub sCubeSpinner3D()
' Spin a cube in 3D...
    Dim radi As Double
    Dim box() As POINTAPI
    
    radi = radi + 0.01

    Dim i As Integer

'    For i = 0 To 3
'        box(i).x1 = 5500 + Sin(radi + (0.4 * (i * 4))) * 2000
'        box(i).y1 = 3000 + Cos(radi + (0.4 * (i * 4))) * Sin(radi) * 1000
'        box(i).x2 = box(i).x1
'        box(i).y2 = box(i).y1 + 2500
'    Next i
'
'    box(4).x1 = box(0).x1
'    box(4).y1 = box(0).y1
'    box(4).x2 = box(1).x1
'    box(4).y2 = box(1).y1
'
'    box(5).x1 = box(3).x1
'    box(5).y1 = box(3).y1
'    box(5).x2 = box(4).x1
'    box(5).y2 = box(4).y1
'
'    box(6).x1 = box(0).x2
'    box(6).y1 = box(0).y2
'    box(6).x2 = box(1).x2
'    box(6).y2 = box(1).y2
'
'    box(7).x2 = box(2).x2
'    box(7).y2 = box(2).y2
'    box(7).x1 = box(3).x2
'    box(7).y1 = box(3).y2
'
'    box(8).x1 = box(1).x2
'    box(8).y1 = box(1).y2
'    box(8).x2 = box(2).x2
'    box(8).y2 = box(2).y2
'
'    box(9).x1 = box(1).x1
'    box(9).y1 = box(1).y1
'    box(9).x2 = box(2).x1
'    box(9).y2 = box(2).y1
'
'    box(10).x1 = box(2).x1
'    box(10).y1 = box(2).y1
'    box(10).x2 = box(3).x1
'    box(10).y2 = box(3).y1
'
'    box(11).x1 = box(0).x2
'    box(11).y1 = box(0).y2
'    box(11).x2 = box(3).x2
'    box(11).y2 = box(3).y2

End Sub

 

[Jaafar Tribak]

@audeser

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

Not quite ... If you comment out InstallSubclassing, the canvas gets cleared if you move the userform... Try moving the userform and you will see (specially if the userform is moved partially off-screen)

Anyway, I have found an alternative to avoid subclassing and still be able to freely move the userform around without inadvertently clearing the canvas.

Give this 3rd version a test and let me know: XLCanvasUpdate_V3.xls

I would love a cross-like cursor (CAD soft typical one)

Sorry I am not sure what CAD means... If you want to change the mouse icon to a cross like cursor , you can easily adapt the code and set the canvas fram mouse pointer to fmMousePointerCross .

If I have spare time, I will try to experiment with some code to give the user the ability to create mouse cursors dynamically from shapes and images .


@Rick Rothstein

A little less cryptic as to intent... perhaps... but more useful if you need a much larger array of contiguous numbers, say 1 trough 1000....

I agree. This can be very useful with larger arrays

 

[audeser]

Oh, now I understand the purpose!... the clearing screen was a thing that has been driving me crazy from when I started with this, in 2016, because if userform gets cleared I cannot use it on Computer Aided Design (CAD, like AutoCAD). I nearly abandoned it until I fall in your code, taking a snapshot and replacing the image whenever the userform changes position was my idea of solving this issue. And it was this that point that halted me with your code, I was trying to move the userform to see how it behaves... and in my office 2019 x86 (win10pro x64) configuration, when I moved the userform, Excel hungs.

But... version v3 is PERFECT!. Thank you Jaafar.

As per the cursor icon, here is an screenshot of a CAD software with the usual cross used there as a cursor (the leftmost one). In the past I was able to draw a cross, but it crosses all the userform (both horizontally and vertically, so was less practical). The fmMousePointerCross is a bit different one.

I have managed to use the MouseIcon and MousePointer properties to render a transparent ICO, and plays ok (unless it reaches the borders, then the magic dissapears, and the icon get outside the box for a while). Cross cursor2.jpg shows this problem. I'll be expecting your investigation on how to draw the cursors.
The userform I uploaded, although it compiles with no errors, is not working properly, I ripped from my file and did not check the code running. Seems it's not drawing anything that is suppossed to draw on the picture box (picture 2 is showing what it should be doing when Insert text button is pressed). Anyway, when I return here, code will be amended.

King regards

 

[Rick Rothstein]

"You learn something new every day". I agree, the MonthNames one is very fancy, it goes directly to my arsenal.

Actually, in thinking about it some more, we can create the month name array even more compactly by using COLUMN instead of ROW...

MonthNames = [TEXT(28*COLUMN(A:L),"mmmm")]

This is a normal, one-based, one-dimensional VBA array (TRANSPOSE is not needed since the range is across a row instead of down a column) so array functions like Join and Filter can be used on it.