xlCAD (II)

In the previous post we had detailed how to get a basic CAD support inside Excel. Shapes can get drawn in the worksheet, or there is even the possibility to draw them inside a UserForm using calls to API functions -it would gain “a lot” in perfomance if done this way-.
In this post I will show how to convert a worksheet shape (even a FreeForm) to a macro procedure, so it can be replicated elsewhere.
I experienced some problems replicating the exact location, as Excel refuses “negative” coordinates, but finally got it to work.
Another thing that was left was to get the Type of shape, AutoShapeType (if a primitive one -not freeform-, one of those in msoShapeType enumeration).

Option Explicit

Private Sub sShpToMacro()
' Procedure that replicates a shape as macro code
    Dim oShp As Excel.Shape
    Dim oShpSrc As Excel.FreeformBuilder
    Dim oNode As Excel.ShapeNode
    Dim lgNode As Long
    Dim lgRefresh As Long
    Dim PtArray() As Single
    Dim PtArrayF() As Single
    Dim PtArrayB() As Single
    Dim strNode As String
    Dim strSegment As String
    Dim strEditing As String
    Dim bMove As Boolean
    Dim IncrementTop As Single
    Dim IncrementLeft As Single

    Set oShp = ActiveSheet.Shapes(Selection.ShapeRange.Name)
    'Set oShpSrc = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, PtArray(1,1), PtArray(1,2))
    'With oShpSrc
    '    .AddNodes msoSegmentLine, msoEditingAuto, PtArray(1,1), PtArray(1,2)
    '    Set oShp = oShpSrc.ConvertToShape
    'End With
    
    'With oShp.Fill
    '    .Visible = msoTrue
    '    .PresetTextured msoTexturePapyrus
    '    .TextureTile = msoTrue
    '    .TextureOffsetX = 0
    '    .TextureOffsetY = 0
    '    .TextureHorizontalScale = 1
    '    .TextureVerticalScale = 1
    '    .TextureAlignment = msoTextureTopLeft
    '
    '    '.UserPicture "...\file.jpg"
    '    '.TextureTile = msoFalse
    'End With

    With oShp
        'Application.ScreenUpdating = False
        'For lgRefresh = 1 To 1
            'If .AutoShapeType <> msoShapeNotPrimitive Then
            '    ' If shape is a primitive Shape Type, first convert to a NotPrimitive (add a node and remove it)
            '    .Nodes.Insert .Nodes.Count, msoSegmentLine, msoEditingCorner, 100, 100
            '    .Nodes.Delete .Nodes.Count + 1
            'End If
                
            'Set oNode = .Nodes(2)
            '.Nodes.SetPosition 2, oNode.Points(1, 1) + Int(Rnd() * 10), oNode.Points(1, 2) + Int(Rnd() * 10)
            'Set oNode = .Nodes(4)
            '.Nodes.SetPosition 4, oNode.Points(1, 1) + Int(Rnd() * 10), oNode.Points(1, 2) + Int(Rnd() * 10)
        'Next lgRefresh
        'Application.ScreenUpdating = True
        
        ' For first node
        With .Nodes(1)
            Debug.Print "Private Sub sShp_" & oShp.Name & "_ToMacro()"
            Debug.Print vbTab & "Dim oShp as Excel.shape"
            PtArray() = oShp.Nodes(1).Points
            Debug.Print vbTab & "With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, " & VBA.Replace(VBA.Round(PtArray(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArray(1, 2), 1), ",", ".") & ")"
        End With
        
        For lgNode = 2 To .Nodes.Count - 1
        ' via SegmentType property:
        ' • If it is msoSegmentLine(0), actual nodes = x;
        ' • if it is msoSegmentCurve, actual nodes = 2 + 2 + (x-2)*3
        ' X is the nodes we can see directly.
            
            Set oNode = .Nodes(lgNode)
            With .Nodes(lgNode)
                On Local Error Resume Next
                Select Case .EditingType
                    Case 0: strEditing = "msoEditingAuto"
                    Case 1: strEditing = "msoEditingCorner"
                    Case 2: strEditing = "msoEditingSmooth"
                    Case 3: strEditing = "msoEditingSymmetric"
                End Select
                On Local Error GoTo 0
                
                Select Case .SegmentType
                    Case 1: strSegment = "msoSegmentCurve"
                        PtArrayB() = oShp.Nodes(lgNode + 0).Points
                        PtArray() = oShp.Nodes(lgNode + 1).Points
                        PtArrayF() = oShp.Nodes(lgNode + 2).Points
                        Debug.Print VBA.String(2, vbTab) & _
                                    ".AddNodes " & strSegment & ", " & strEditing _
                                                              & ", " & VBA.Replace(VBA.Round(PtArrayB(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArrayB(1, 2), 1), ",", ".") _
                                                              & ", " & VBA.Replace(VBA.Round(PtArray(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArray(1, 2), 1), ",", ".") _
                                                              & ", " & VBA.Replace(VBA.Round(PtArrayF(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArrayF(1, 2), 1), ",", ".") '& vbCrLf
                        lgNode = lgNode + 2
                    Case 0: strSegment = "msoSegmentLine"
                        PtArray() = .Points
                        Debug.Print VBA.String(2, vbTab) & _
                                    ".AddNodes " & strSegment & ", " & strEditing & ", " & VBA.Replace(VBA.Round(PtArray(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArray(1, 2), 1), ",", ".") '& vbCrLf
                End Select
            End With
        Next lgNode
        
        ' For last node
        Select Case oShp.Nodes(oShp.Nodes.Count).SegmentType
            Case 1: strSegment = "msoSegmentCurve"
                If fDistance2DNode(oShp.Nodes(oShp.Nodes.Count - 1), oShp.Nodes(1)) = 0 Then
                    PtArrayB() = oShp.Nodes(oShp.Nodes.Count - 2).Points
                    PtArray() = oShp.Nodes(oShp.Nodes.Count - 1).Points
                    PtArrayF() = oShp.Nodes(1).Points
                    Debug.Print VBA.String(2, vbTab) & _
                                ".AddNodes " & strSegment & ", " & strEditing _
                                                          & ", " & VBA.Replace(VBA.Round(PtArrayB(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArrayB(1, 2), 1), ",", ".") _
                                                          & ", " & VBA.Replace(VBA.Round(PtArray(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArray(1, 2), 1), ",", ".") _
                                                          & ", " & VBA.Replace(VBA.Round(PtArrayF(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArrayF(1, 2), 1), ",", ".") '& vbCrLf
                End If
            Case 0: strSegment = "msoSegmentLine"
                PtArray() = oShp.Nodes(oShp.Nodes.Count).Points
                Debug.Print VBA.String(2, vbTab) & _
                            ".AddNodes " & strSegment & ", " & strEditing & ", " & VBA.Replace(VBA.Round(PtArray(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArray(1, 2), 1), ",", ".") '& vbCrLf
        End Select
        Debug.Print VBA.String(2, vbTab) & "Set oShp = .ConvertToShape"
    
        For Each oNode In .Nodes
            If oNode.Points(1, 1) < 0 Then bMove = True If IncrementLeft > oNode.Points(1, 1) Then IncrementLeft = oNode.Points(1, 1)
            End If
            If oNode.Points(1, 2) < 0 Then bMove = True If IncrementTop > oNode.Points(1, 2) Then IncrementTop = oNode.Points(1, 2)
            End If
        Next oNode
        If bMove Then
            Debug.Print VBA.String(1, vbTab) & "With oShp"
            Debug.Print VBA.String(2, vbTab) & ".IncrementLeft " & VBA.Replace(VBA.Round(IncrementLeft, 1), ",", ".")
            Debug.Print VBA.String(2, vbTab) & ".IncrementTop " & VBA.Replace(VBA.Round(IncrementTop, 1), ",", ".")
            Debug.Print VBA.String(1, vbTab) & "End With"
        End If
        Debug.Print VBA.String(1, vbTab) & "End With"
        Debug.Print "End Sub"
    End With
End Sub

Private Function fDistance2DNode(ByVal oNode1 As Excel.ShapeNode, ByVal oNode2 As Excel.ShapeNode) As Double
    fDistance2DNode = VBA.Sqr((oNode1.Points(1, 1) - oNode2.Points(1, 1)) ^ 2 + (oNode1.Points(1, 2) - oNode2.Points(1, 2)) ^ 2)
End Function

With this basic structure done, we can modify code to get the fill and contour of the shape, and any other property as Comments,…

Excel VBA print screen

Following code is a screen capturer, not relaying on the PrintScreen button. It can handle both the full screen (did not try with several monitors connected -only the principal-), or a portion of the screen selected by a range or a shape. This last point is really interesting, could not found nothing similar on the net, and kept me struggling for a whole day how to achieve it, but finally got it working.
The performance of the code is not that great compared to commercial software for this task, but at least, you have not to install anything.

Option Explicit

Private g_ShpID As Long

Private Const VK_SNAPSHOT = &H2C

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (ByRef PicDesc As PicBmp, ByRef RefIID As GUID, ByVal fPictureOwnsHandle As Long, ByRef IPic As IPicture) As Long
Private Declare Function CreateCompatibleDC Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "GDI32.dll" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "GDI32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "GDI32.dll" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "GDI32.dll" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, ByRef lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "GDI32.dll" (ByRef lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "GDI32.dll" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function BitBlt Lib "GDI32.dll" (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
Private Declare Function DeleteDC Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRECT As RECT) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long ' pixels
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long

Private Type DEVMODE
    DeviceName As String * 32
    SpecVersion As Integer
    DriverVersion As Integer
    Size As Integer
    DriverExtra As Integer
    Fields As Long
    Orientation As Integer
    PaperSize As Integer
    PaperLength As Integer
    PaperWidth As Integer
    Scale As Integer
    Copies As Integer
    DefaultSource As Integer
    PrintQuality As Integer
    Color As Integer
    Duplex As Integer
    YResolution As Integer
    TTOption As Integer
    Collate As Integer
    FormName As String * 32
    UnusedPadding As Integer
    BitsPerPixel As Integer
    PixsWidth As Long
    PixsHeight As Long
    DisplayFlags As Long
    DisplayFrequency As Long
    ' The following only appear in Windows 95, 98, 2000
    ICMMethod As Long
    ICMIntent As Long
    MediaType As Long
    DitherType As Long
    Reserved1 As Long
    Reserved2 As Long
    ' The following only appear in Windows 2000
    PanningWidth As Long
    PanningHeight As Long
End Type

Private Declare Function EnumDisplaySettings Lib "user32.dll" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As DEVMODE) As Long
Private Const ENUM_CURRENT_SETTINGS = -1
Private Const ENUM_REGISTRY_SETTINGS = -2

'Private Const SM_CXSCREEN = 0&
'Private Const SM_CYSCREEN = 1&
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
Private Const RASTERCAPS As Long = 38

Private Const SM_CXFULLSCREEN As Long = 16
Private Const SM_CYFULLSCREEN As Long = 17
Private Const HORZRES As Long = 8&
Private Const VERTRES As Long = 10&

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

Private Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type

Private Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type

Private Const TIFF_LZW As String = "LZW"
Private Const TIFF_RLE As String = "RLE"       'Pixel Depth must be 1.
Private Const TIFF_CCITT3 As String = "CCITT3" 'Pixel Depth must be 1.
Private Const TIFF_CCITT4 As String = "CCITT4" 'Pixel Depth must be 1.
Private Const TIFF_Uncompressed As String = "Uncompressed"

' --------------------------------
'        Screen capture
' --------------------------------
Private Sub sPrntWnd()
    Dim oShp As Excel.Shape
    Dim oXlRng As Excel.Range
    Dim oRect As RECT
    Dim strFullPathFile As String
    Dim Seconds As Double
    Dim lgShp As Long
    Dim hDC As Long
    'Dim hWnd As Long
    Dim lgPixelsPeriInch As Long

    lgShp = 0
    hDC = GetDC(0&)
    
    With ThisWorkbook.Application
        'hWnd = FindWindowEx(.Windows(1).hWnd, 0&, vbNullString, vbNullString)
        'GetWindowRect .Windows(1).hWnd, oRect '--> Have to convert oRect to pixels...?
        
        Set oXlRng = ActiveWindow.VisibleRange
        oRect.Left = GetRectForExcel(oXlRng, 1) * 4 / 3
        oRect.Top = GetRectForExcel(oXlRng, 2) * 4 / 3
        oRect.Bottom = oRect.Top + (oXlRng.Height * 4 / 3)
        oRect.Right = oRect.Left + (oXlRng.Width * 4 / 3)
        
        lgShp = lgShp + 1
        strFullPathFile = ThisWorkbook.Path & "\@" & lgShp & ".bmp"
        Call fPrntSrc(oRect, strFullPathFile, 1)
    End With
    
    hDC = ReleaseDC(0, hDC)
End Sub

Public Sub sPrntSrc()
    Dim oShp As Excel.Shape
    Dim oXlCell As Excel.Range
    Dim oRect As RECT
    Dim strFullPathFile As String
    Dim Seconds As Double
    Dim lgShp As Long
    Dim hDC As Long
    Dim lgPixelsPeriInch As Long

    lgShp = 0
    hDC = GetDC(0&)
    For Each oShp In ActiveSheet.Shapes
        'If oShp.Name <> "•" Then
        If oShp.Name = "x" Then
Stop
            Set oXlCell = oShp.TopLeftCell
            oRect.Left = GetRectForShp(oShp, 1) * 4 / 3 + (1) ' 1 pixel to avoid border
            oRect.Top = GetRectForShp(oShp, 2) * 4 / 3 + (2 + 1) 'excel shape has not a good precision, 2 pixels are wrong + 1 for the border
            'oRect.Left = GetRectForExcel(oXlCell, 1) * 4 / 3
            'oRect.Top = GetRectForExcel(oXlCell, 3) * 4 / 3
            oRect.Bottom = oRect.Top + (oShp.Height * 4 / 3) - (1 + 1) ' 1 pixel to avoid each border
            oRect.Right = oRect.Left + (oShp.Width * 4 / 3) - (1 + 1) ' 1 pixel to avoid each border
            lgShp = lgShp + 1
            strFullPathFile = ThisWorkbook.Path & "\@" & lgShp & ".bmp"
            Call fPrntSrc(oRect, strFullPathFile, 1)
Exit Sub
        End If
    Next oShp
    hDC = ReleaseDC(0, hDC)
End Sub

Private Function fPrntSrc(ByRef oRect As RECT, _
                          Optional ByVal strFullPathFile As String = vbNullString, _
                          Optional ByVal Seconds As Double = 1) As Boolean
' Screenshots of an active window / rectangle can be captured, with/without delay
    Dim oDevMode As DEVMODE   ' info about the display device
    Dim lgRetVal As Long  ' return value
    
    'If Seconds > 0 Then Sleep (VBA.Fix(Seconds * 1000))
    With oRect
        If .Bottom = .Top _
        Or .Left = .Right Then
            ' Full screen
            ' Initialize the structure.
            oDevMode.Size = Len(oDevMode)
            
            ' Get the display settings for the current monitor and mode.
            lgRetVal = EnumDisplaySettings(vbNullString, ENUM_CURRENT_SETTINGS, oDevMode)
            
            stdole.SavePicture hDCToPicture(GetDC(0&), 0&, 0&, oDevMode.PixsWidth, oDevMode.PixsHeight), _
                               strFullPathFile ' ThisWorkbook.Path & "\Screenshot.bmp"
        Else
            'AppActivate ThisWorkbook.Application   ' bring to front Excel
            'GetWindowRect GetForegroundWindow, oRect
            GetWindowRect GetDC(0&), oRect
            With oRect
                stdole.SavePicture hDCToPicture(GetDC(0&), .Left, .Top, .Right - .Left, .Bottom - .Top), _
                                   strFullPathFile ' ThisWorkbook.Path & "\Screenshot.bmp"
            End With
        End If
    End With
End Function

Private Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Object
    Dim Pic As PicBmp
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID

    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With Pic
        .Size = Len(Pic)
        .Type = 1
        .hBmp = hBmp
        .hPal = hPal
    End With
    Call OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
    Set CreateBitmapPicture = IPic
End Function

Private Function hDCToPicture(ByVal hDCSrc As Long, _
                              ByVal LeftSrc As Long, _
                              ByVal TopSrc As Long, _
                              ByVal WidthSrc As Long, _
                              ByVal HeightSrc As Long) As Object
    Dim hDCMemory As Long
    Dim hBmp As Long, hBmpPrev As Long
    Dim hPal As Long, hPalPrev As Long
    Dim RasterCapsScrn As Long
    Dim HasPaletteScrn As Long
    Dim PaletteSizeScrn As Long
    Dim LogPal As LOGPALETTE

    hDCMemory = CreateCompatibleDC(hDCSrc)
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        With LogPal
            .palVersion = &H300
            .palNumEntries = 256
        End With
        Call GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
        hPal = CreatePalette(LogPal)
        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        Call RealizePalette(hDCMemory)
    End If

    Call BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, 13369376)
    hBmp = SelectObject(hDCMemory, hBmpPrev)
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If
    Call DeleteDC(hDCMemory)
    Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function

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

Private Sub fPrntSrc_2()
' if using multiple monitors, it will only capture the active monitor...
    Dim oShp As Excel.Shape
    Dim lgShps As Long

    'AppActivate Application.caption        ' select application to be captured...
    
    AppActivate ThisWorkbook.Application   ' to activate Excel
    keybd_event VK_SNAPSHOT, 1, 0, 0
    'Application.Wait
Application.WindowState = xlMaximized
    With wsSheet1
        Application.Wait (Now + TimeValue("0:00:5"))
        lgShps = .Shapes.Count + 1
        DoEvents
        .Paste
        Do Until .Shapes.Count = lgShps
            DoEvents
        Loop
        Set oShp = .Shapes(lgShps)
        With oShp
            '.TopLeftCell = ActiveCell
            
            'To Resize: once you have a handle on the shape, just assign its Height and Width properties as needed:
            .Height = 600
            .Width = 800
    
            'To Position It: use the shape's TopLeftCell property.
            
            'To Crop It: use the ".PictureFormat.Crop"
            '(and/or CropLeft, CropTop, CropBottom, CropRight if you need to fine-tune what part of the screenshot is needed.
            'For instance, this crops the pasted screenshot to 800x600:
            .LockAspectRatio = False
            .PictureFormat.CropRight = -(800 - .Width)
            .PictureFormat.CropBottom = -(600 - .Height)
        End With
    End With
End Sub

These are other needing procedures to get the position of the range or the Excel shape.

Option Explicit

Public Type POINTAPI
    x As Long
    y As Long
End Type

Private Type RECT
    Left As Double
    Top As Double
    Right As Double
    Bottom As Double
End Type

Private Enum eRectBorder
    eBorderLeft = 1
    eBorderTop = 2
    eBorderRight = 3
    eBorderBottom = 4
End Enum

Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Public Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

#If Win64 Then
    Public Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Public Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Public Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
#Else
    Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
#End If

Public Const LOGPIXELSX = 88&
Public Const LOGPIXELSY = 90&

'Private Sub SetUpProc()
'    With Application
'        .OnKey "z", "TestMoveShapeToMouse"
'        '.Cursor = xlNorthwestArrow
'    End With
'End Sub
'
'Private Sub ResetUpProc()
'    With Application
'        .OnKey "z"
'        '.Cursor = xlDefault
'    End With
'End Sub
'
'Private Sub TestMoveShapeToMouse()
''Change shape to suit
'    Dim oShpRng As Excel.ShapeRange
'    'Dim oShp As Excel.Shape
'
'    Set oShpRng = Selection.ShapeRange
'    'Set oShp = ActiveSheet.Shapes(oShpRng.ID - 1)
'    MoveShapeToMouse ActiveSheet.Shapes(oShpRng.ID - 1)
'End Sub
'
'Private Sub MoveShapeToMouse(ByRef oShp As Excel.Shape)
'    Dim oPoint As POINTAPI
'    Dim xpos_0 As Double, ypos_0 As Double
'    Dim z As Double
'
'    On Error Resume Next
'    GetCursorPos oPoint
'    With ActiveWindow
'        z = CorrectZoomFactor(.Zoom / 100)
'        xpos_0 = .PointsToScreenPixelsX(0)
'        ypos_0 = .PointsToScreenPixelsY(0)
'    End With
'    Application.Cursor = xlNorthwestArrow
'    oShp.Left = (oPoint.x - xpos_0) / z * PointsPerPixel(LOGPIXELSX)
'    oShp.Top = (oPoint.y - ypos_0) / z * PointsPerPixel(LOGPIXELSY)
'    'Application.Cursor = xlDefault
'    On Error GoTo 0
'End Sub
'
'Private Function CorrectZoomFactor(ByVal z As Single) As Single
'    Select Case z
'        Case 2:     z = 2
'        Case 1.75:  z = 1.765
'        Case 1.5:   z = 1.529
'        Case 1.25:  z = 1.235
'        Case 1:     z = 1
'        Case 0.9:   z = 0.882
'        Case 0.85:  z = 0.825
'        Case 0.8:   z = 0.82
'        Case 0.75:  z = 0.74
'        Case 0.7:   z = 0.705
'        Case 0.65:  z = 0.645
'        Case 0.6:   z = 0.588
'        Case 0.55:  z = 0.53
'        Case 0.5:   z = 0.5296
'        Case Else
'            z = 1.0069 * z + 0.0055
'    End Select
'    CorrectZoomFactor = z
'End Function

Public Sub Add_Shape_At_Cursor_Position()
' adds an AutoShape to the active sheet centered over the mouse position, accounting for the Excel window position and zoom.
' Currently it adds a circle (actually an oval with width 100 and height 100) but should work with any MsoAutoShapeType.

    Dim PointsPerPixelX As Double, PointsPerPixelY As Double
    Dim CursorPos As POINTAPI
    Dim ExcelPos As POINTAPI
    Dim ShapePos As POINTAPI

    'Size of shape's bounding box in points
    Const SHAPE_WIDTH = 100
    Const SHAPE_HEIGHT = 100
    
    'Get number of points per screen pixel, depending on screen device size
    PointsPerPixelX = PointsPerScreenPixel(LOGPIXELSX)
    PointsPerPixelY = PointsPerScreenPixel(LOGPIXELSY)
    
    'Scale points per pixel according to current window zoom. The smaller the zoom, the higher the number of points per pixel
    With ActiveWindow
        PointsPerPixelX = PointsPerPixelX * 100 / .Zoom
        PointsPerPixelY = PointsPerPixelY * 100 / .Zoom
        
        'Get position of Excel window in screen pixels
        ExcelPos.x = .PointsToScreenPixelsX(0)
        ExcelPos.y = .PointsToScreenPixelsY(0)
    End With

    'Get mouse cursor position in screen pixels
    GetCursorPos CursorPos
    
    'Set shape position according to mouse position relative to Excel window position, scaled to the
    'number of points per pixel.  Since the AutoShape's position is defined by the top left corner
    'of its bounding box, subtract half the shape's size to centre it over the mouse
    ShapePos.x = (CursorPos.x - ExcelPos.x) * PointsPerPixelX - (SHAPE_WIDTH / 2)
    ShapePos.y = (CursorPos.y - ExcelPos.y) * PointsPerPixelY - (SHAPE_HEIGHT / 2)
       
    ActiveSheet.Shapes.AddShape msoShapeOval, ShapePos.x, ShapePos.y, SHAPE_WIDTH, SHAPE_HEIGHT

End Sub

Public Function GetRectForExcel(ByVal Target As Excel.Range, _
                                Optional ByVal RectBorder As Long = eRectBorder.eBorderLeft) As Double
' ----------------------------------------
' Returns the cell coordinates in points relative to the screen
'
' @param {Object} Target the cell
' @return {Rect} the cell coordinates
' ----------------------------------------
    Dim Index As Integer
    Dim RECT As RECT
    
    With ActiveWindow
        Set Target = Target.MergeArea
    
        For Index = 1 To .Panes.Count
            If Not Intersect(Target, .Panes(Index).VisibleRange) Is Nothing Then
                With .Panes(Index)
                    RECT.Left = PixelsToPoints(.PointsToScreenPixelsX(Target.Left))
                    RECT.Top = PixelsToPoints(.PointsToScreenPixelsY(Target.Top))
                End With
                
                RECT.Right = (Target.Width * .Zoom / 100) + RECT.Left
                RECT.Bottom = (Target.Height * .Zoom / 100) + RECT.Top
                
                If RectBorder = eRectBorder.eBorderLeft Then
                    GetRectForExcel = RECT.Left
                ElseIf RectBorder = eRectBorder.eBorderTop Then
                    GetRectForExcel = RECT.Top
                ElseIf RectBorder = eRectBorder.eBorderRight Then
                    GetRectForExcel = RECT.Right
                ElseIf RectBorder = eRectBorder.eBorderBottom Then
                    GetRectForExcel = RECT.Bottom
                End If
                Exit Function
            End If
        Next
    End With
End Function

Public Function ShpRngToShp(ByVal oShpRng As Excel.ShapeRange) As Excel.Shape
    Set ShpRngToShp = oShpRng.Parent.Shapes(oShpRng.Name)
End Function

Public Function GetRectForShp(ByVal oShp As Excel.Shape, _
                              Optional ByVal RectBorder As Long = eRectBorder.eBorderLeft) As Double
' ----------------------------------------
' Returns the cell coordinates in points relative to the screen
'
' @param {Object} Target the cell
' @return {Rect} the cell coordinates
' ----------------------------------------
    Dim oXlCell As Excel.Range
    Dim Index As Integer
    Dim RECT As RECT
    
    With ActiveWindow
        Set oXlCell = oShp.TopLeftCell.MergeArea
    
        For Index = 1 To .Panes.Count
            If Not Intersect(oXlCell, .Panes(Index).VisibleRange) Is Nothing Then
                With .Panes(Index)
                    RECT.Left = PixelsToPoints(.PointsToScreenPixelsX(oShp.Left))
                    RECT.Top = PixelsToPoints(.PointsToScreenPixelsY(oShp.Top))
                End With
                
                RECT.Right = (oShp.Width * .Zoom / 100) + RECT.Left
                RECT.Bottom = (oShp.Height * .Zoom / 100) + RECT.Top
                
                If RectBorder = eRectBorder.eBorderLeft Then
                    GetRectForShp = RECT.Left
                ElseIf RectBorder = eRectBorder.eBorderTop Then
                    GetRectForShp = RECT.Top
                ElseIf RectBorder = eRectBorder.eBorderRight Then
                    GetRectForShp = RECT.Right
                ElseIf RectBorder = eRectBorder.eBorderBottom Then
                    GetRectForShp = RECT.Bottom
                End If
                Exit Function
            End If
        Next
    End With
End Function

Public Function PointsPerScreenPixel(ByVal LOGPIXELS As Long) As Double
'Get number of points per screen pixel, depending on screen device size
    Dim hDC As Long
    
    hDC = GetDC(0)
    PointsPerScreenPixel = 72 / GetDeviceCaps(hDC, LOGPIXELS)
    ReleaseDC 0, hDC
End Function

Public Function TwipsToPixels(ByVal lngTwips As Long, _
                              ByVal blnHorizontal As Boolean) As Long
' Twip is a distance measurement - 1/1440th of an inch.
' twips = Device.TwipsPerPixelX (or Y) * pixels
' pixels = twips / Device.TwipsPerPixelX (or Y)
    Const TWIPSPERINCH As Long = 1440

    If blnHorizontal Then
        TwipsToPixels = CLng(lngTwips / TWIPSPERINCH * DotsPerInch(True))
    Else
        TwipsToPixels = CLng(lngTwips / TWIPSPERINCH * DotsPerInch(False))
    End If
End Function

Public Function DotsPerInch(Optional ByVal blnHorizontal As Boolean = True) As Long
    Dim hDC As Long

    hDC = GetDC(0)
    If blnHorizontal Then
        DotsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
    Else
        DotsPerInch = GetDeviceCaps(hDC, LOGPIXELSY)
    End If
    ReleaseDC 0, hDC
End Function

Public Function PixelsToPoints(ByVal Pixels As Double, _
                               Optional ByVal blnHorizontal As Boolean = True) As Double
' ----------------------------------------
' Converts pixels to points
' More info http://office.microsoft.com/en-us/excel-help/measurement-units-and-rulers-in-excel-HP001151724.aspx
' Measurement units and rulers in Excel
' Unlike Microsoft Word, Excel does not provide a horizontal or vertical ruler, and there is no quick way to measure the width or height of a worksheet in inches.
' Excel uses characters, points, and pixels as units of measurement.
' The width of cells is displayed in characters and pixels rather than in inches.
'  • When you drag the boundary of a column heading to adjust the width of a column on the worksheet, a ScreenTip displays the width in characters and shows pixels in parentheses.
' The height of cells is displayed in points and pixels rather than in inches.
'  • When you drag the boundary of a row heading to adjust the height of a row on the worksheet, a ScreenTip displays the height in points and shows pixels in parentheses.
'
' An approximate conversion of points and pixels to inches is shown in the following table.
'  Points  Pixels  Inches
'   18      24      .25
'   36      48      .5
'   72      96      1
'   108     144     1.5
'   144     192     2
 
'
' @param {Double} Pixels
' @return {Double} Points
' ----------------------------------------
    Dim hDC As Long
    Dim iDPI As Long

    hDC = GetDC(0)
    If blnHorizontal Then
        iDPI = GetDeviceCaps(hDC, LOGPIXELSX)
    Else
        iDPI = GetDeviceCaps(hDC, LOGPIXELSY)
    End If
    PixelsToPoints = Pixels / iDPI * 72
    ReleaseDC 0, hDC
End Function

Public Function PointsToPixels(ByVal Points As Double, _
                               Optional ByVal blnHorizontal As Boolean = True) As Double
' ----------------------------------------
' Converts points to pixels
' More info http://office.microsoft.com/en-us/excel-help/measurement-units-and-rulers-in-excel-HP001151724.aspx
'
' @param {Double} Points
' @return {Double} Pixels
' ----------------------------------------
    Dim hDC As Long
    Dim iDPI As Long

    hDC = GetDC(0)
    If blnHorizontal Then
        iDPI = GetDeviceCaps(hDC, LOGPIXELSX)
    Else
        iDPI = GetDeviceCaps(hDC, LOGPIXELSY)
    End If
    PointsToPixels = (Points / 72) * iDPI
    ReleaseDC 0, hDC
End Function

Public Function PointsPerPixel(ByVal LOGPIXELS As Long) As Double
'LOGPIXELSX: The WIDTH of a pixel in Excel's userform coordinates
'LOGPIXELSY: The HEIGHT of a pixel in Excel's userform coordinates
    Dim hDC As Long
    
    hDC = GetDC(0)
    'A point is defined as 1/72 of an inch and LOGPIXELS returns
    'the number of pixels per logical inch, so divide them to give
    'the width of a pixel in Excel's userform coordinates
    PointsPerPixel = 72 / GetDeviceCaps(hDC, LOGPIXELS)
    ReleaseDC 0, hDC
End Function

Following is also the code for a BMP/JPG/TIF/GIF/PNG conversion, that comes very handy with this, as the BMP format is a disk eating beast.


' --------------------------------
'        Image conversion
' --------------------------------

' Option 1
Private Sub ImgConv(ByVal InFileName As String, _
                    ByVal OutFileName As String, _
                    ByVal OutFormat As String, _
                    Optional ByVal Quality As Integer = 100, _
                    Optional ByVal Compression As String = TIFF_LZW)
' Reference to: Microsoft Windows Image Acquisition Library v2.0
' XP SP1 and later
' For XP you'll need to deploy it: Windows® Image Acquisition Automation Library v2.0 Tool (http://www.microsoft.com/downloads/en/details.aspx?FamilyID=a332a77a-01b8-4de6-91c2-b7ea32537e29)
    
    Dim Img As WIA.ImageFile
    Dim ImgProc As WIA.ImageProcess

    Set Img = New WIA.ImageFile
    Img.LoadFile InFileName
    Set ImgProc = New WIA.ImageProcess
    With ImgProc.Filters
        .Add ImgProc.FilterInfos("Convert").FilterID
        .Item(1).Properties("FormatID").Value = OutFormat
        If OutFormat = wiaFormatJPEG Then
            .Item(1).Properties("Quality").Value = Quality
        ElseIf OutFormat = wiaFormatTIFF Then
            .Item(1).Properties("Compression").Value = Compression
        End If
    End With
    Set Img = ImgProc.Apply(Img)

    On Local Error Resume Next
    'If fFileExists(OutFileName) Then
    'End If
    'Kill OutFileName
    On Local Error GoTo 0
    Img.SaveFile OutFileName
End Sub

Private Sub sImageConv_Main()
    Dim strPath As String
    
    strPath = "C:\Users\CASA\Documents\"
    ImgConv strPath & "a.bmp", strPath & "a.jpg", wiaFormatJPEG, 70
    ImgConv strPath & "a.bmp", strPath & "a.gif", wiaFormatGIF
    ImgConv strPath & "a.bmp", strPath & "a.png", wiaFormatPNG
    ImgConv strPath & "a.bmp", strPath & "a.tif", wiaFormatTIFF, , TIFF_Uncompressed
'    MsgBox "Complete"
End Sub

' Option 2
Private Sub PrintToPDFCreator_Early()
'' Print to Output file using PDFCreator: http://sourceforge.net/projects/pdfcreator/
'' Designed for early bind, set reference to PDFCreator
'' http://www.vbaexpress.com/forum/archive/index.php/t-8488.html
'    Dim OutputJob As PDFCreator.clsPDFCreator
'    Dim sOutputName As String
'    Dim sOutputPath As String
'    Dim lOutputType As Long
'    Dim i As Integer
'    Dim lgRetVal As Long
'
'    '/// Change the output file name and type here! ///
'    sOutputName = "test"
'
'    '0=PDF, 1=Png, 2=jpg, 3=bmp, 4=pcx, 5=tif, 6=ps, 7=eps, 8=txt
'    lOutputType = 2
'
'    sOutputPath = ActiveDocument.Path & Application.PathSeparator
'    Set OutputJob = New PDFCreator.clsPDFCreator
'
'    'Set correct filename extension
'    Select Case lOutputType
'        Case Is = 0: sOutputName = sOutputName & ".pdf"
'        Case Is = 1: sOutputName = sOutputName & ".png"
'        Case Is = 2: sOutputName = sOutputName & ".jpg"
'        Case Is = 3: sOutputName = sOutputName & ".bmp"
'        Case Is = 4: sOutputName = sOutputName & ".pcx"
'        Case Is = 5: sOutputName = sOutputName & ".tif"
'        Case Is = 6: sOutputName = sOutputName & ".ps"
'        Case Is = 7: sOutputName = sOutputName & ".eps"
'        Case Is = 8: sOutputName = sOutputName & ".txt"
'    End Select
'
'    'Set job defaults
'    With OutputJob
'        If .cStart("/NoProcessingAtStartup") = False Then
'            lgRetVal = MsgBox("Can't initialize PDFCreator.", _
'                              vbCritical + vbOKOnly, "PrtPDFCreator")
'            Exit Sub
'        End If
'        .cOption("UseAutosave") = 1
'        .cOption("UseAutosaveDirectory") = 1
'        .cOption("AutosaveDirectory") = sOutputPath
'        .cOption("AutosaveFilename") = sOutputName
'        .cOption("AutosaveFormat") = lOutputType
'        .cClearCache
'    End With
'
'    'Print the document to PDF
'    With ThisDocument
'        .ActivePrinter = "PDFCreator"
'        .PrintOut
'    End With
'
'    'Wait until the print job has entered the print queue
'    Do Until OutputJob.cCountOfPrintjobs = 1
'        DoEvents
'    Loop
'    OutputJob.cPrinterStop = False
'
'    'Wait until the PDF file shows up then release the objects
'    Do Until Dir(sOutputPath & sOutputName) <> ""
'        DoEvents
'    Loop
'    OutputJob.cClose
'    Set OutputJob = Nothing
End Sub

' Option 3
Private Sub ImgFFMpedConv(ByVal InFileName As String)
' Convert to any format (with/without compression) via FFMpeg http://ffmpeg.zeranoe.com/builds.

    Shell ("ffmpeg.exe -i YourFile.bmp -q <qualityNumber*> ConverTo.Any")  ' *write ffmpeg /? in cmd to know usage
End Sub

' Option 4
' A pure VB6 JPG class development
'http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=50065&lngWId=1

Block Excel shape selection

In Excel, every shape is selectable via click button. This is sometimes a pain when you do not want an specific shape to be ever selected.

Assinning an empty macro to the onAction method will help (although it will fail when trying multiselection):

Public Sub sShp_UnselectMe()
End Sub

There is the option to unselect a shape beeing clicked, but I not yet sure how I can implement it…

Public Sub sShp_UnselectMe()
    Dim oShp As Excel.Shape
    Dim oShpRng As Excel.ShapeRange
    Dim oShpGrp As Excel.Shape
    Dim vShpSelection() As Variant
    Dim lgShp As Long
    Dim lgItem As Long
    
    If TypeName(Application.Selection) = "Range" Then
    ' Shape will not be selected until the oShp.OnAction had run,
    ' so if not prior shape was selected, the selection only comprises range elements
        Exit Sub
    ElseIf TypeName(Application.Selection) = "DrawingObjects" Then
    'composed of: --> "Line" "Arc" "Drawing" "Rectangle" "Oval" "Picture" "TextBox"
        lgItem = -1
        For lgShp = 1 To Application.Selection.ShapeRange.Count
            Set oShp = Application.Selection.ShapeRange.Item(lgShp)
            'If oShp.ID <> g_ShpID Then 'oXlWsh.Shapes(Application.Caller).ID
                lgItem = lgItem + 1
                ReDim Preserve vShpSelection(0 To lgItem)
                vShpSelection(lgItem) = oShp.Name
            'End If
        Next lgShp
        Set oShpRng = ActiveSheet.Shapes.Range(vShpSelection)
        With oShpRng
            .Select
            '.Group
            '.Name = ...
        End With
    
    ElseIf TypeName(Application.Selection) = "GroupObject" Then
        Set oShpGrp = Application.Selection
        'Give name: oShpGrp.Name
    Else
        Exit Sub
    End If
End Sub

But there is a little problem you should solve first. Shape names should be unique so the Application.Caller event does not point to a different shape to the one you’re looking for.
This code from StackOverflow will help prevent the issue:

Private Sub TestShpProblem()
    Dim ws As Worksheet
    Dim shp As Shape

    ' reset shapes
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    For Each shp In ws.Shapes
        shp.Delete
    Next shp

    ' add shape
    With ws.Shapes.AddShape(msoShapeRectangle, 10, 10, 100, 100)
        .Name = "Foo1"
        .OnAction = "ShapeAction"
    End With

    ' add another shape
    With ws.Shapes.AddShape(msoShapeRectangle, 160, 10, 100, 100)
        .Name = "Foo2"
        .OnAction = "ShapeAction"
    End With

    ' add another shape with duplicate name
    With ws.Shapes.AddShape(msoShapeRectangle, 310, 10, 100, 100)
        .Name = "Foo1"
        .OnAction = "ShapeAction"
    End With

    ' add another shape with duplicate name
    With ws.Shapes.AddShape(msoShapeRectangle, 10, 160, 100, 100)
        .Name = "Foo2"
        .OnAction = "ShapeAction"
    End With

    ' add another shape with duplicate name
    With ws.Shapes.AddShape(msoShapeRectangle, 160, 160, 100, 100)
        .Name = "Foo1"
        .OnAction = "ShapeAction"
    End With

    ' add another shape
    With ws.Shapes.AddShape(msoShapeRectangle, 310, 160, 100, 100)
        .Name = "Foo3"
        .OnAction = "ShapeAction"
    End With

    ' uniqueify shape names - comment out to replicate OP problem
    MakeShapeNamesUnique ws

End Sub

Sub ShapeAction()
    Dim shp As Excel.Shape

    Set shp = Sheet1.Shapes(Application.Caller)
    MsgBox " My name is: " & shp.Name & " and my ID is: " & shp.ID

End Sub

Private Sub MakeShapeNamesUnique(Optional oXlWsh As Excel.Worksheet = Nothing)
    Dim oShp As Excel.Shape
    Dim oDictionay As Object

    Set oDictionay = CreateObject("Scripting.Dictionary")

    'iterate shapes
    If oXlWsh Is Nothing Then Set oXlWsh = ActiveSheet
    For Each oShp In oXlWsh.Shapes
        With oShp
            ' does shape name exist ?
            If Not oDictionay.Exists(.Name) Then
                ' add name to dictionary if not exists with counter of 0
                oDictionay.Add .Name, 0
            Else
                ' found a duplicate --> increment counter
                oDictionay(.Name) = oDictionay(.Name) + 1
                
                ' rename shape with suffix indicating dupe index
                .Name = .Name & "_" & oDictionay(.Name)
            End If
        End With
    Next oShp

    ' Clean up the dictionary
    Set oDictionay = Nothing
End Sub

VBA range variables declaration

When using the VBA Formula method, I like to get all the info at first glance. Is really annoying for me to find .cells(lR, #) where the # does not give any hint about the column meaning. I better prefer the .cells(lR, lC_worksheetName_infoColumn) notation.

For this, you need the lC_worksheetName_infoColumn to be declared before use, and having so much of this variables is a burden I would prefer to not do manually. Here it comes handy a little macro that can generate the declaration block, via “Const” or via “Dim”. There is also some code for indention purposes.

Private Function fVariableNamer()
    Dim bIndent As Boolean: bIndent = False
    Dim bConst As Boolean: bConst = False
    
    Dim oXlCell As Excel.Range
    Dim strWshName As String
    Dim strVar As String
    Dim strText As String
    Dim strOut As String
    Dim strChr As String
    Dim strPrev As String
    Dim iChr As Integer
    Dim lgChr As Long
    
    strWshName = Selection.Parent.Name
    For Each oXlCell In Selection.Cells
        strText = oXlCell.Value2
        strOut = vbNullString
        
        ' Avoid spaces
        strText = VBA.Trim$(strText)
        Do While VBA.InStr(1, strText, "  ")
            strText = VBA.Replace(strText, "  ", " ")
        Loop
        
        ' For ending character
        lgChr = VBA.Len(strText)
        strChr = VBA.Mid$(strText, lgChr, 1)    'iChr = VBA.Asc()
        strPrev = VBA.Mid$(strText, lgChr - 1, 1)
        If strPrev = "." Or strPrev = "-" Then
            strOut = VBA.UCase$(strChr)
        Else
            strOut = strChr
        End If
        
        ' For other characters
        For lgChr = VBA.Len(strText) - 1 To 2 Step -1 ' from back to front
            strChr = VBA.Mid$(strText, lgChr, 1) 'iChr = VBA.Asc()
            strPrev = VBA.Mid$(strText, lgChr - 1, 1)
            If strChr = "." Or strChr = "-" Or strChr = " " Then
            Else
                If strPrev = "." Then
                    strOut = VBA.UCase$(strChr) & strOut
                    lgChr = lgChr - 1
                ElseIf strPrev = "-" Then
                    strOut = VBA.UCase$(strChr) & strOut
                    lgChr = lgChr - 1
                ElseIf strPrev = " " Then
                    strOut = VBA.UCase$(strChr) & strOut
                    lgChr = lgChr - 1
                Else
                    strOut = strChr & strOut
                End If
            End If
        Next lgChr
        
        ' For starting character
        strChr = VBA.Mid$(strText, 1, 1)  'iChr = VBA.Asc()
        If strChr = "." Or strChr = "-" Then
        Else
            strOut = VBA.UCase$(strChr) & strOut
        End If
        
        strVar = "lC_" & strWshName & "_" & strOut
        If bIndent Then
            strIndent = VBA.Space(25 - VBA.Len(strVar))
        End If
        
        If bConst Then
            Debug.Print "Private Const lC_" & strWshName & "_" & strOut & strIndent & " As Long = " & oXlCell.Column
        Else
            Debug.Print "Dim " & strVar & " As Long:" & strIndent & strVar & " = " & oXlCell.Column
        End If
    Next oXlCell
End Function

Enjoy it!