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!

Book library

I have plenty of books, both digital and physical. The problem is with the the digital ones. They come from several sources, but as a lot they are, I can hardly know where all are stored, or if I’m in the need of some specific topic, even get to them (I use to name by ISBN, not very helpful in this point).

A library will be an excelent solution. But I have to code that library, and even get the descriptions, the cover images,… want it on Excel format, and in HTML.

Following is the main procedure to create HTML files with release info, and a description for them, with link to some web store (Amazon I suppose, to get more information and even get them on physical form). If possible I would also link to the source where they came from (with a basic cyphering code, just to not expose sensible content).

Option Explicit

Private Type tLibraryItem
    Title As String
    Date As Date
    Image As String
    Info As String
    ISBN As String
    Pages As Long
    Size As Long
    Format_ As String
    Link() As String
End Type

Private Sub sIndexGenerator()
' Given an index, generate HTML
    Dim strURL As String
    Dim strPath As String
    Dim iFile As Integer
    Dim strFile As String
    Dim strDoc As String
    
    Dim bRaw As Boolean
    Dim s As String
    Dim strHTML As String
    Dim hDoc As MSHTML.HTMLDocument
    Dim hHead As MSHTML.HTMLHeadElement
    Dim hBody As MSHTML.HTMLBody
    Dim hCollection As MSHTML.IHTMLElementCollection
    Dim hElementItem As MSHTML.IHTMLElement
    Dim hElement As MSHTML.IHTMLElement
    Dim hChildrenElement As MSHTML.IHTMLElement
    Dim hChildrenCollection As MSHTML.IHTMLElementCollection 'Object
    Dim hNode As MSHTML.IHTMLDOMNode

    Dim lgItem As Long
    Dim iFileOut As Integer
    Dim lgItemStart As Long:    lgItemStart = 1
    Dim lgItemEnd As Long:      lgItemEnd = 1
    Dim lgItemsPerPage As Long: lgItemsPerPage = 20
    Dim lgLink As Long

    Dim lC_X As Long:       lC_X = 1
    Dim lC_Title As Long:   lC_Title = lC_X + 1
    Dim lC_Link As Long:    lC_Link = lC_Title + 1
    Dim lC_PC As Long:      lC_PC = lC_Link + 1
    Dim lC_Amazon As Long:  lC_Amazon = lC_PC + 1
    Dim lC_Cat As Long:     lC_Cat = lC_Amazon + 1
    Dim lC_Image As Long:   lC_Image = lC_Cat + 1
    Dim lC_Info As Long:    lC_Info = lC_Image + 1
    Dim lC_ISBN As Long:    lC_ISBN = lC_Info + 1
    Dim lC_Size As Long:    lC_Size = lC_ISBN + 1
    Dim lC_Description As Long: lC_Description = lC_Size + 1
    Dim lC_Hosted As Long:  lC_Hosted = lC_Description + 1
    Dim lr As Long
    Dim lR_Start As Long
    Dim lR_End As Long
    
    Dim oItem() As tLibraryItem
    
    strPath = VBA.Environ$("UserProfile") & "\Documents\"
    For lgItem = 1 To 1 Step lgItemsPerPage
        iFileOut = VBA.FreeFile()
        'strFile = "test" & ".html"
        'Open strPath & "Page_" & VBA.Format(lgItem, "000") & ".html" For Output Shared As #iFileOut
        
        If bRaw Then

' Here was code to generate raw HTML, but the beautifier in wp, kills it!!
        
        Else
            ' Set hDOMDoc = oIE.Document.DOMDocument
            Set hDoc = New MSHTML.HTMLDocument
            Set hHead = hDoc.head 'or: hDoc.createElement("head")
            Set hBody = hDoc.body 'or: hDoc.createElement("body")
            
            ' Create title
            hDoc.Title = "Test"
        
            ' Create meta tags
            Set hElement = hDoc.createElement("xxx.com"">")
            hHead.appendChild hElement
            Set hElement = hDoc.createElement("")
            hHead.appendChild hElement
            Set hElement = hDoc.createElement("")
            hHead.appendChild hElement
            
            ' Link to icon
            Set hElement = hDoc.createElement("")
            hHead.appendChild hElement
            
            ' Link to CSS styles definition
            Set hElement = hDoc.createElement("")
            hHead.appendChild hElement
            
            ' Link to script code
            Set hElement = hDoc.createElement("")
            hHead.appendChild hElement
            
            '----------------------------
            ' Beautify...
            Set hElement = hDoc.createElement("div")
            hElement.setAttribute "id", "ActiveItem"
            hElement.setAttribute "class", "item"
            hBody.appendChild hElementItem

            ' Title
            Set hChildrenElement = hDoc.createElement("div")
            hChildrenElement.setAttribute "class", "title"
            hDoc.getElementById("ActiveItem").appendChild hChildrenElement
            Set hElement = hChildrenElement
            
                Set hChildrenElement = hDoc.createElement("h2")
                hElement.appendChild hChildrenElement
                Set hElement = hChildrenElement
                
                    Set hChildrenElement = hDoc.createElement("b")
                    hChildrenElement.innerText = 1 ' oItem(lgItem).Title
                    hElement.appendChild hChildrenElement
            
            Set hChildrenElement = hDoc.createElement("br"): hElementItem.appendChild hChildrenElement
            
            ' DateUpload
            Set hChildrenElement = hDoc.createElement("div")
            hChildrenElement.setAttribute "class", "date_upload"
            hChildrenElement.innerText = 1 ' oItem(lgItem).Date
            hDoc.getElementById("ActiveItem").appendChild hChildrenElement
            
            Set hChildrenElement = hDoc.createElement("br"): hElementItem.appendChild hChildrenElement
            
            ' Image
            Set hChildrenElement = hDoc.createElement("div")
            hChildrenElement.setAttribute "class", "image"
            hChildrenElement.innerText = 1 ' oItem(lgItem).Image
            hDoc.getElementById("ActiveItem").appendChild hChildrenElement
            
            Set hChildrenElement = hDoc.createElement("br"): hElementItem.appendChild hChildrenElement
            
            ' Release-info
            Set hChildrenElement = hDoc.createElement("div")
            hChildrenElement.setAttribute "class", "release_info"
            hDoc.getElementById("ActiveItem").appendChild hChildrenElement
            Set hElement = hChildrenElement
                Set hChildrenElement = hDoc.createElement("div")
                hChildrenElement.setAttribute "class", "year"
                hChildrenElement.innerText = 1 ' oItem(lgItem).Image
                hElement.appendChild hChildrenElement
            
                Set hChildrenElement = hDoc.createElement("div")
                hChildrenElement.setAttribute "class", "isbn"
                hChildrenElement.innerText = 1 ' oItem(lgItem).Image
                hElement.appendChild hChildrenElement
            
                Set hChildrenElement = hDoc.createElement("div")
                hChildrenElement.setAttribute "class", "pages"
                hChildrenElement.innerText = 1 ' oItem(lgItem).Image
                hElement.appendChild hChildrenElement
            
                Set hChildrenElement = hDoc.createElement("div")
                hChildrenElement.setAttribute "class", "size"
                hChildrenElement.innerText = 1 ' oItem(lgItem).Image
                hElement.appendChild hChildrenElement
            
                Set hChildrenElement = hDoc.createElement("div")
                hChildrenElement.setAttribute "class", "format"
                hChildrenElement.innerText = 1 ' oItem(lgItem).Image
                hElement.appendChild hChildrenElement
            
                Set hChildrenElement = hDoc.createElement("div")
                hChildrenElement.setAttribute "class", "other"
                hChildrenElement.innerText = 1 ' oItem(lgItem).Image
                hElement.appendChild hChildrenElement
            
            ' More block...
            'Set hChildrenElement = hDoc.createElement("more")
            'hChildrenElement.setAttribute "class", "???"
            'hElementItem.appendChild hChildrenElement
            'Set hElement = hChildrenElement
            
            ' Description
            'Set hElement = hDoc.createElement("div")
            hElement.setAttribute "class", "text_description"
            hElement.innerText = oItem(lgItem).Description
            hBody.appendChild hElement
            
            ' Links

' Password any?

            Set hElement = hDoc.createElement("div"): hElement.setAttribute "id", "ActiveUL"
            hElement.setAttribute "class", "download_links"
            hDoc.getElementById("ActiveItem").appendChild hElement
            
            Set hElement = hDoc.createElement("ul"): hElement.setAttribute "id", "ActiveUL"
            hDoc.getElementById("ActiveItem").appendChild hElement
            'For lgLink = 1 to 1
                Set hChildrenElement = hDoc.createElement("li")                 ' Create a node
                Set hElement = hChildrenElement
                Set hChildrenElement = hDoc.createElement("a")
                hChildrenElement.setAttribute "class", "download-btn"
                hChildrenElement.setAttribute "target", "_blank"
                hChildrenElement.setAttribute "href", oItem(lgItem).Link(lgLink)
                hChildrenElement.innerText = "Download"
                hElement.appendChild hChildrenElement
                'Set hNode = hDoc.createTextNode("TEXT")    ' Create a text node
                '.AppendChildNode

                hDoc.getElementById("ActiveUL").appendChild hElement
                hDoc.getElementById("ActiveUL").appendChild hDoc.createElement("br")
            'Next lgLink
            'Set hElement = hDoc.getElementById("ActiveUL")
            hDoc.getElementById("ActiveUL").removeAttribute ("id")

            hDoc.getElementById("ActiveItem").removeAttribute ("id")
        End If

        ' If we want to deploy the index local/web, maybe try worth considering the following code:
        'Set hCollection = hDoc.getElementsByTagName("img")
        'If hCollection.Length = 0 Then Stop
        'For Each hElement In hCollection
        '    strSrc = hElement.getAttribute("src")
        '    'hElement.removeAttribute ("src")
        '
        '    strSrc = VBA.Replace(strSrc, "\", "/") 'from local to Web
        '    strSrc = VBA.Replace(strSrc, "/", "\") 'from Web to local
        '
        '    If strSrc <> vbNullString Then
        '        hElement.setAttribute "src", strSrc
        '    End If
        '
        '    On Error Resume Next
        '    strSrc = ""
        'Next hElement
        '
        'Set hCollection = hDoc.getElementsByTagName("a")
        'If hCollection.Length = 0 Then Stop
        'For Each hElement In hCollection
        '    strSrc = hElement.getAttribute("href")
        '    strSrc = VBA.Mid$(strSrc, 1, VBA.InStr(1, strSrc, "&name", vbTextCompare) - 1)
        '
        '    If VBA.InStr(1, strSrc, "#") > 0 Then
        '        strBookmark = VBA.Mid$(strSrc, VBA.InStr(1, strSrc, "#"))
        '        strSrc = VBA.Mid$(strSrc, 1, VBA.Len(strSrc) - VBA.Len(strBookmark))
        '    End If
        '
        '    strSrc = VBA.Replace(strSrc, "\", "/") 'from local to Web
        '    strSrc = VBA.Replace(strSrc, "/", "\") 'from Web to local
        '    On Error GoTo 0
        'Next hElement

        'Print #iFileOut, hDoc.DocumentElement.innerHTML
        'Close #iFileOut

    Next lgItem

Stop

ExitProc:
    Set hElement = Nothing
    Set hElementItem = Nothing
    Set hChildrenElement = Nothing
    Set hDoc = Nothing
    'Call fIE_Terminate
    Exit Sub

ErrControl:
    'Handle Error
    Resume ExitProc
End Sub

And there should come here some downloader code, but I suspect wp will kill also, as it’s full with < and > symbols

Engineering blogs

Following is a list of spanish civil engineering blogs:

    • http://ingenieriaenlared.wordpress.com/
    • http://estructurando.net/
    • http://www.fierasdelaingenieria.com/
    • http://geojuanjo.blogspot.com.es/
    • http://enriquemontalar.com/
    • http://www.carreteros.org/
    • http://infocivil.es/
    • http://treneando.com/
    • http://manologallegos.blogspot.com.es/
    • https://unblogdeingenieria.wordpress.com/otras-web-sobre-ingenieria/

 

Dealing with coordinates, datums and reference systems

I have a lot of DXF files that came from the old standard spanish Datum (ED50), but now is imperative to use the ETRS89 (same as WGS84).

To get one drawing transformed into the other one, there are some equations that should be used.

A short block of equations are expresed next, that came from here:

The following formulae can be used to transform geographic coordinates between geodetic datums using three and seven parameter similarity transformations.

These formulas are formally defined in the LINZ standard LINZS25000 (Standard for New Zealand Geodetic Datum 2000), and are summarised in the associated NZGD2000 fact sheet (LINZG25700) and LINZG25703 (Fact Sheet – Datum and Projection Transformations).

This conversion is a three-step process:

    • Convert geographic coordinates to their Cartesian equivalents
    • Apply similarity transformation to Cartesian coordinates
    • Convert Cartesian coordinates back to geographic values

Geographic coordinates to Cartesian coordinates

These formulae can be used to convert geographic coordinates, latitude ( Φ ), longitude ( λ ), and height ( h), into Cartesian coordinates (X, Y, Z ):

Equation to convert geographic coodinates into cartesian coordinates

Where a and f are obtained from the reference ellipsoid used for the respective geodetic datum and the h is the height of the computation point or approximated as zero
Equation to convert geographic coodinates into cartesian coordinates

Three parameter transformation

The three parameter transformation is implemented using:
Three parameter transformation equation

Seven parameter transformation

The Helmert seven parameter similarity transformation is implemented using:
Seven parameter transformation equation
Note: the rotation parameters ( R ) must be converted from arc-seconds to radians before being used in this equation.

Note: this is a simplified version of the Helmert formulae that applies for small rotation angles.  This is the official formulae to use for the NZGD49-NZGD2000 seven parameter transformation.

Cartesian coordinates to geographic coordinates

These formulas can be used to convert Cartesian coordinates ( X, Y, Z ) into geographic coordinates latitude ( Φ ), longitude ( λ ), and height ( h ).
Equation to convert cartesian coodinates into geographic coordinates
Where a and f are obtained from the reference ellipsoid used for the respective geodetic datum:
Equation to convert cartesian coodinates into geographic coordinates
Note: because NZGD1949 is a horizontal datum the height resulting from the transformation will not be in terms of the output datum, the equation is shown here for completeness.

For most conversions, Transformation Parameters can be found in the NIMA technical report “Department of Defense World Geodetic System 1984” (TR 8350.2) NSN: 7643-01-402-0347. Here is a little visual explanation on what is going on with this operations.

There is a lot of more information in this document, and also, on this other one.

VBA Excel as ActiveWindow Screenshot recorder

I was on the need to get screenshots of a lot of userforms from an application. I was not for the option of capture the image, save the image with name, go again… so here is a window capturer for the active window or for the full screen. It may be not the best option, but items can be done inside Excel.

#If VBA7 Then
    Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#Else
    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#End If

Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12
Private Const KEYEVENTF_KEYUP = &H2

Private Sub sPrintScreen()
' To capture the screen
    keybd_event VK_SNAPSHOT, 1, 0, 0
End Sub

Private Sub sAltPrintScreen()
' To capture the active window
    Application.Wait VBA.Now() + TimeSerial(0, 0, 5)
    
    keybd_event VK_MENU, 0, 0, 0
    keybd_event VK_SNAPSHOT, 0, 0, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
    keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0

    Application.Wait VBA.Now() + TimeSerial(0, 0, 1)
    
    ' Add a new worksheet to paste image
    Dim oXlWsh As Excel.Worksheet
    Dim oXlShp As Excel.Shape
    Dim sgLeft As Single
    Dim sgTop As Single
    Dim sgWidth As Single
    Dim sgHeight As Single
    Dim oCht As Excel.Chart
    Dim oChtObj As Excel.ChartObject
    
    Set oXlWsh = ThisWorkbook.Worksheets.Add 'ActiveSheet
    With oXlWsh
        '.Name = ...
        .Range("A1").Select
        .Paste
        
        ' Save image to file
        Set oXlShp = .Shapes(.Shapes.Count)
    
        With oXlShp
            ' Copy the picture
            .Copy
            '.CopyPicture
            
            '' To Resize
            '.Height = 600
            '.Width = 800
        
            '' To Position It: use the shape's TopLeftCell property.
            
            '' To Crop It: use the shp.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:
            'sgHeight = -(600 - .Height)
            'sgWidth = -(800 - .Width)
            
            '.LockAspectRatio = False
            '.PictureFormat.CropRight = sgWidth
            '.PictureFormat.CropBottom = sgHeight
        
            ' Save image
            'Set oCht = ThisWorkbook.Charts.Add
            'oCht.Location Where:=xlLocationAsObject, Name:=.Name
            
            Set oChtObj = oXlWsh.ChartObjects.Add(0, 0, .Width, .Height)
            With oChtObj
                .Border.LineStyle = 0
                .Left = oXlShp.Left
                .Width = oXlShp.Width
                .Top = oXlShp.Top
                .Height = oXlShp.Height
            
                'To save a range: oRng.CopyPicture xlScreen, xlPicture 'or xlPicture --> xlBitmap
                With .Chart
                    .Paste
                    .Export Filename:=VBA.Environ$("UserProfile") & "\Documents\SavedRange.jpg", FilterName:="JPG"
                End With
                
                DoEvents
                .Delete ' get rid of the chart
            End With
            
            '.Delete ' get rid of the image
        End With
        
        ' Other options to save the JPG
        'https://www.tek-tips.com/viewthread.cfm?qid=1764114
        'http://www.mvps.org/emorcillo/en/code/vb6/index.shtml
        
        
        ' Delete worksheet
        'Application.DisplayAlerts = False
        '.Delete
        'Application.DisplayAlerts = True
    End With
End Sub

From there on I can, for example, get the controls in that window (following the idea in this enlightning post from Xristos Samaras’s MyEngineeringWorld).

Option Explicit
  
'Declaring the necessary API functions for both 64 and 32 bit applications.
#If VBA7 And Win64 Then
'For 64 bit applications.
    'Performs an operation on a specified file.
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
    
    'Retrieves a handle to the top-level window whose class name and window name match the specified strings.
    'This function does not search child windows. This function does not perform a case-sensitive search.
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
            
    'Retrieves a handle to a window whose class name and window name match the specified strings.
    'The function searches child windows, beginning with the one following the specified child window.
    'This function does not perform a case-sensitive search.
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
       
    'Sends the specified message to a window or windows. The SendMessage function calls the window procedure
    'for the specified window and does not parentWindowurn until the window procedure has processed the message.
    Private 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
        
    'Places (posts) a message in the message queue associated with the thread that created the specified
    'window and parentWindowurns without waiting for the thread to process the message.
    Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
    
    Private Declare PtrSafe Function GetForegroundWindow Lib "user32.dll" () As LongPtr
    Private Declare PtrSafe Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" (ByVal hWnd As LongPtr) As LongPtr

    Private Declare PtrSafe Function GetClassName Lib "USER32" Alias "GetClassNameA" (ByVal hWnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As Long
    Private Declare PtrSafe Function EnumChildWindows Lib "user32.dll" (ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Boolean
    
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As LongPtr
    
    'Private Declare PtrSafe Function GetTopWindow Lib "user32.dll" (ByVal hWnd As LongPtr) As LongPtr
    'Private Declare PtrSafe Function GetNextWindow Lib "user32.dll" Alias "GetWindow" (ByVal hWnd As LongPtr, ByVal wFlag As LongPtr) As LongPtr
    'Private Declare PtrSafe Function IsWindowVisible Lib "user32.dll" (ByVal hWnd As LongPtr) As LongPtr
#Else
'For 32 bit applications.
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
                                                        
    Private Declare Function GetForegroundWindow Lib "user32" () As Long
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long

    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function EnumChildWindows Lib "user32.dll" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
    Private Declare Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Boolean
    
    Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
#End If
     
Private Const ERROR_INVALID_WINDOW_HANDLE As Long = 1400
Private Const ERROR_INVALID_WINDOW_HANDLE_DESCR As String = "Invalid window handle."

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

' Windows API Constants --> https://doc.pcsoft.fr/en-US/?6510001&verdisp=160  &  https://www.magnumdb.com/
Private Const SW_HIDE As Long = 0
Private Const SW_SHOWNORMAL As Long = 1
Private Const SW_SHOWMAXIMIZED As Long = 3
Private Const SW_SHOWMINIMIZED As Long = 2
Private Const VK_RETURN As Long = &HD
Private Const WM_SETTEXT As Long = &HC
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const WM_LBUTTONDOWN As Long = 513
Private Const WM_LBUTTONUP As Long = 514
Private Const WM_LBUTTONDBLCLK As Long = 515
Private Const WM_RBUTTONDOWN As Long = 516
Private Const WM_RBUTTONUP As Long = 517
Private Const WM_RBUTTONDBLCLK As Long = 518
Private Const WM_MBUTTONDOWN As Long = 519
Private Const WM_MBUTTONUP As Long = 520
Private Const WM_MBUTTONDBLCLK As Long = 521
Private Const WS_TABSTOP As Long = 65536
Private Const WM_CLOSE As Long = &H10
Private Const BM_CLICK As Long = &HF5

#If VBA7 And Win64 Then
    Private hWnd As LongPtr
    Private CtrlHandle As LongPtr
#Else
    Private hWnd As Long
    Private CtrlHandle As Long
#End If

 'Used a user defined type here rather than Enum so that it works on 97
Private Type winEnum
    winHandle As Integer
    winClass As Integer
    winTitle As Integer
    winHandleClass As Integer
    winHandleTitle As Integer
    winHandleClassTitle As Integer
End Type

Private winOutputType As winEnum
Private x As Integer
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

#If VBA7 And Win64 Then
    Private Type tHandle
        hWnd As LongPtr
        Name As String
        ClassName As String
    End Type
#Else
    Private Type tHandle
        hWnd As Long
        Name As String
        ClassName As String
    End Type
#End If

Private aChild() As tHandle
Private winNum As Long

#If VBA7 And Win64 Then
    Private Sub Test()
    ' You can't call this on a button click, because then your window will be the foreground window.
    ' Add a timer/wait
    ' Run the procedure, click another window within 5 seconds.
        Dim hWnd As LongPtr
        
        Dim strTitle As String
        Dim strClassName As String
        Dim lgClassNameLength As LongPtr
        Dim lgRetVal As Long
    
        MsgBox "Go activate the Window you want to Spy"
        Application.Wait VBA.Now() + TimeSerial(0, 0, 5)
        
        ' If no handle, get active window
        If hWnd = 0 Then hWnd = hWnd = GetForegroundWindow()
        
        strTitle = fWindowTitle(hWnd)
        strClassName = fWindowClassName(hWnd)
    
        ''https://stackoverflow.com/questions/6310731/window-click-ok-button-by-code
        Erase aChild(): winNum = 0
        lgRetVal = EnumChildWindows(hWnd, AddressOf EnumChildProc, 0)
    
Stop
'        For lgChild = LBound(aChild) To UBound(aChild)
'        Next lgChild
Stop
'        ' the Button's Caption is "Open" and it is a "Button".
'        CtrlHandle = FindWindowEx(hWnd, 0, "Button", "&Open")
        
'        ' send Click to the button(CtrlHandle).
'        lgRetVal = SendMessage(CtrlHandle, BM_CLICK, 0, 0)
        
'        'Fill with text the TextBox.
'        lgRetVal = SendMessage(CtrlHandle, WM_SETTEXT, 0&, ByVal strText)
        
'        'Press the OK button (it is the default action, so no need to find the handle of the button).
'        lgRetVal = PostMessage(CtrlHandle, WM_KEYDOWN, VK_RETURN, 0)
    End Sub
    
    Private Function fWindowClassName(ByVal hWnd As LongPrt) As String
        Dim strClassName As String
        Dim lgClassNameLength As LongPtr
        Dim lgRetVal As Long
        
        strClassName = String$(100, Chr$(0))
        lgRetVal = GetClassName(hWnd, strClassName, 100)
        fWindowClassName = VBA.Mid$(strClassName, 1, VBA.InStr(1, strClassName, Chr$(0)) - 1)
    End Function
    
    Private Function fWindowTitle(ByVal hWnd As LongPtr) As String
        Dim strTitle As String
        
'        Dim lgBufferLen As Long
'        Dim wintext As String ' window title text length and buffer
'        Dim lgRetVal As Long  ' return value
'        Dim strBuffer As String
'
'        lgBufferLen = GetWindowTextLength(hWnd) + 1 ' get length of title bar text
'        strBuffer = VBA.Space$(lgBufferLen)  ' make room in the buffer
'        lgRetVal = GetWindowText(hWnd, strBuffer, lgBufferLen)
'        fWindowTitle = VBA.Left$(strBuffer, lgBufferLen - 1)  ' display title bar text of enumerated window
        
        ' If not handle, get the active window
        If hWnd = 0 Then hWnd = GetForegroundWindow()
        
        ' get the title of the active window
        strTitle = VBA.String(GetWindowTextLength(hWnd) + 1, VBA.Chr$(0)) ' Make the buffer
        GetWindowText hWnd, strTitle, Len(strTitle) + 1
    
        fWindowTitle = VBA.Mid$(strTitle, 1, VBA.InStr(1, strTitle, Chr$(0)) - 1)
    End Function
    
    Private Function EnumChildProc(ByVal hWnd As LongPtr, _
                                   ByVal lParam As LongPtr) As Long
        Dim lgRetVal As Long
        
        winNum = winNum + 1
        ReDim Preserve aChild(1 To winNum)
        With aChild(winNum)
            .ClassName = fWindowClassName(hWnd)
            .Name = fWindowTitle(hWnd)
            .hWnd = hWnd
            '.hWnd = FindWindow(.ClassName, .Name)
            'lgRetVal = FindWindowEx(hWnd, 0, .ClassName, .Name)
            'lgRetVal = FindWindowEx(hWnd, .hWnd, vbNullString, vbNullString)
            'lgRetVal = FindWindowEx(hWnd, 0&, vbNullString, vbNullString)
        End With
        
        EnumChildProc = 1  ' nonzero return value means continue enumeration
    End Function
    
    Private Function fWindowRec(ByVal hWnd As LongPtr, _
                                ByRef Top As Long, _
                                ByRef Left As Long, _
                                ByRef Right As Long, _
                                ByRef Bottom As Long, _
                                ByRef Width As Long, _
                                ByRef Height As Long) As Boolean
    ' Get left, right, top, and bottom positions of a window in pixels.
        Dim rectWindow As RECT
         
        ' Pass in window handle and empty the data structure.
        ' If function returns 0, an error occurred.
        If GetWindowRect(hWnd, rectWindow) = 0 Then
        ' Check LastDLLError and display a dialog box if the error
        ' occurred because an invalid handle was passed.
            If Err.LastDllError = ERROR_INVALID_WINDOW_HANDLE Then
                fWindowRec = False
                'MsgBox ERROR_INVALID_WINDOW_HANDLE_DESCR, Title:="Error!"
            End If
        Else
            With rectWindow
                Bottom = .Bottom
                Left = .Left
                Right = .Right
                Top = .Top
                Width = .Right - .Left
                Height = .Bottom - .Top
            End With
            fWindowRec = True
        End If
    End Function

#Else
    Private Sub Test()
    ' You can't call this on a button click, because then your window will be the foreground window.
    ' Add a timer/wait
    ' Run the procedure, click another window within 5 seconds.
        Dim hWnd As Long
        
        Dim strTitle As String
        Dim strClassName As String
        Dim lgClassNameLength As Long
        Dim lgRetVal As Long
        Dim lgChild As Long
        Dim strText As String
    
        MsgBox "Go activate the Window you want to Spy"
        Application.Wait VBA.Now() + TimeSerial(0, 0, 5)
        hWnd = GetForegroundWindow()
        
        strTitle = fWindowTitle(hWnd)
        strClassName = fWindowClassName(hWnd)
    
        ''https://stackoverflow.com/questions/6310731/window-click-ok-button-by-code
        Erase aChild(): winNum = 0
        lgRetVal = EnumChildWindows(hWnd, AddressOf EnumChildProc, 0)
    
Stop
'        For lgChild = LBound(aChild) To UBound(aChild)
'        Next lgChild
Stop
'        ' the Button's Caption is "Open" and it is a "Button".
'        CtrlHandle = FindWindowEx(hWnd, 0, "Button", "&Open")
        
'        ' send Click to the button(CtrlHandle).
'        lgRetVal = SendMessage(CtrlHandle, BM_CLICK, 0, 0)
        
'        'Fill with text the TextBox.
'        lgRetVal = SendMessage(CtrlHandle, WM_SETTEXT, 0&, ByVal strText)
        
'        'Press the OK button (it is the default action, so no need to find the handle of the button).
'        lgRetVal = PostMessage(CtrlHandle, WM_KEYDOWN, VK_RETURN, 0)
    End Sub
    
    Private Function fWindowClassName(ByVal hWnd As Long) As String
        Dim strClassName As String
        Dim lgClassNameLength As Long
        Dim lgRetVal As Long
        
        strClassName = String$(100, Chr$(0))
        lgRetVal = GetClassName(hWnd, strClassName, 100)
        fWindowClassName = VBA.Mid$(strClassName, 1, VBA.InStr(1, strClassName, Chr$(0)) - 1)
    End Function
    
    Private Function fWindowTitle(ByVal hWnd As Long) As String
        Dim strTitle As String
        
'        Dim lgBufferLen As Long
'        Dim wintext As String ' window title text length and buffer
'        Dim lgRetVal As Long  ' return value
'        Dim strBuffer As String
'
'        lgBufferLen = GetWindowTextLength(hWnd) + 1 ' get length of title bar text
'        strBuffer = VBA.Space$(lgBufferLen)  ' make room in the buffer
'        lgRetVal = GetWindowText(hWnd, strBuffer, lgBufferLen)
'        fWindowTitle = VBA.Left$(strBuffer, lgBufferLen - 1)  ' display title bar text of enumerated window
        
        ' If not handle, get the active window
        If hWnd = 0 Then hWnd = GetForegroundWindow()
        
        ' get the title of the active window
        strTitle = VBA.String(GetWindowTextLength(hWnd) + 1, VBA.Chr$(0)) ' Make the buffer
        GetWindowText hWnd, strTitle, Len(strTitle) + 1
    
        fWindowTitle = VBA.Mid$(strTitle, 1, VBA.InStr(1, strTitle, Chr$(0)) - 1)
    End Function
    
    Private Function EnumChildProc(ByVal hWnd As Long, _
                                   ByVal lParam As Long) As Long
        Dim lgRetVal As Long
        
        winNum = winNum + 1
        ReDim Preserve aChild(1 To winNum)
        With aChild(winNum)
            .ClassName = fWindowClassName(hWnd)
            .Name = fWindowTitle(hWnd)
            .hWnd = hWnd
            '.hWnd = FindWindow(.ClassName, .Name)
            'lgRetVal = FindWindowEx(hWnd, 0, .ClassName, .Name)
            'lgRetVal = FindWindowEx(hWnd, .hWnd, vbNullString, vbNullString)
            'lgRetVal = FindWindowEx(hWnd, 0&, vbNullString, vbNullString)
        End With
        
        EnumChildProc = 1  ' nonzero return value means continue enumeration
    End Function
    
    Private Function fWindowRec(ByVal hWnd As Long, _
                                ByRef Top As Long, _
                                ByRef Left As Long, _
                                ByRef Right As Long, _
                                ByRef Bottom As Long, _
                                ByRef Width As Long, _
                                ByRef Height As Long) As Boolean
    ' Get left, right, top, and bottom positions of a window in pixels.
        Dim rectWindow As RECT
         
        ' Pass in window handle and empty the data structure.
        ' If function returns 0, an error occurred.
        If GetWindowRect(hWnd, rectWindow) = 0 Then
        ' Check LastDLLError and display a dialog box if the error
        ' occurred because an invalid handle was passed.
            If Err.LastDllError = ERROR_INVALID_WINDOW_HANDLE Then
                fWindowRec = False
                'MsgBox ERROR_INVALID_WINDOW_HANDLE_DESCR, Title:="Error!"
            End If
        Else
            With rectWindow
                Bottom = .Bottom
                Left = .Left
                Right = .Right
                Top = .Top
                Width = .Right - .Left
                Height = .Bottom - .Top
            End With
            fWindowRec = True
        End If
    End Function
#End If

Following is another piece of code that did not came to much use, as I could not guess what was the intention of the code -I did really not put too much attention on the thing-. It’s filling the worksheet with names/properties, but barelly understand anything. Seems it getting all the windows in the operating system, and start a loop that seems to not have an end… But looks promissing enough to rip some code apart, starting from the winOutputType.

Public Sub GetWindowInfo()
    MsgBox "Go activate the Window you want to Spy"
    Application.Wait Now() + TimeSerial(0, 0, 5)
    
    With winOutputType
        .winHandle = 0
        .winClass = 1
        .winTitle = 2
        .winHandleClass = 3
        .winHandleTitle = 4
        .winHandleClassTitle = 5

        sGetWinInfo 0&, 0, .winHandleClassTitle
    End With
End Sub
 
#If VBA7 And Win64 Then
    Private Sub sGetWinInfo(ByRef hParent As LongPtr, _
                            ByRef intOffset As Integer, _
                            ByRef OutputType As Integer)
    ' Recursively obtain window handles, classes and text given a parent window to search
    ' Written by Mark Rowlinson
    ' www.markrowlinson.co.uk - The Programming Emporium
        Dim hWnd As Long
        Dim lngRet As Long
        Dim y As Integer
        Dim strText As String
        
        hWnd = FindWindowEx(hParent, 0&, vbNullString, vbNullString)
        While hWnd <> 0
            Select Case OutputType
                Case winOutputType.winClass
                    strText = String$(100, Chr$(0))
                    lngRet = GetClassName(hWnd, strText, 100)
                    Range("a1").Offset(x, intOffset) = Left$(strText, lngRet)
                
                Case winOutputType.winHandle
                    Range("a1").Offset(x, intOffset) = hWnd
                
                Case winOutputType.winTitle
                    strText = String$(100, Chr$(0))
                    lngRet = GetWindowText(hWnd, strText, 100)
                    If lngRet > 0 Then
                        Range("a1").Offset(x, intOffset) = Left$(strText, lngRet)
                    Else
                        Range("a1").Offset(x, intOffset) = "N/A"
                    End If
                
                Case winOutputType.winHandleClass
                    Range("a1").Offset(x, intOffset) = hWnd
                    strText = String$(100, Chr$(0))
                    lngRet = GetClassName(hWnd, strText, 100)
                    Range("a1").Offset(x, intOffset + 1) = Left$(strText, lngRet)
                
                Case winOutputType.winHandleTitle
                    Range("a1").Offset(x, intOffset) = hWnd
                    strText = String$(100, Chr$(0))
                    lngRet = GetWindowText(hWnd, strText, 100)
                    If lngRet > 0 Then
                        Range("a1").Offset(x, intOffset + 1) = Left$(strText, lngRet)
                    Else
                        Range("a1").Offset(x, intOffset + 1) = "N/A"
                    End If
                
                Case winOutputType.winHandleClassTitle
                    Range("a1").Offset(x, intOffset) = hWnd
                    strText = String$(100, Chr$(0))
                    lngRet = GetClassName(hWnd, strText, 100)
                    Range("a1").Offset(x, intOffset + 1) = Left$(strText, lngRet)
                    strText = String$(100, Chr$(0))
                    lngRet = GetWindowText(hWnd, strText, 100)
                    If lngRet > 0 Then
                        Range("a1").Offset(x, intOffset + 2) = Left$(strText, lngRet)
                    Else
                        Range("a1").Offset(x, intOffset + 2) = "N/A"
                    End If
            End Select
             
            ' check for children
            y = x
            Select Case OutputType
                Case Is > 4
                    GetWinInfo hWnd, intOffset + 3, OutputType
                Case Is > 2
                    GetWinInfo hWnd, intOffset + 2, OutputType
                Case Else
                    GetWinInfo hWnd, intOffset + 1, OutputType
            End Select
             
            ' increment by 1 row if no children found
            If y = x Then x = x + 1
             
            ' now get next window
            hWnd = FindWindowEx(hParent, hWnd, vbNullString, vbNullString)
        Wend
    End Sub

#Else
    Private Sub sGetWinInfo(ByRef hParent As Long, _
                            ByRef intOffset As Integer, _
                            ByRef OutputType As Integer)
    ' Recursively obtain window handles, classes and text given a parent window to search
    ' Written by Mark Rowlinson
    ' www.markrowlinson.co.uk - The Programming Emporium
        Dim hWnd As Long
        Dim lngRet As Long
        Dim y As Integer
        Dim strText As String
        
        hWnd = FindWindowEx(hParent, 0&, vbNullString, vbNullString)
        While hWnd <> 0
            Select Case OutputType
                Case winOutputType.winClass
                    strText = String$(100, Chr$(0))
                    lngRet = GetClassName(hWnd, strText, 100)
                    Range("a1").Offset(x, intOffset) = Left$(strText, lngRet)
                
                Case winOutputType.winHandle
                    Range("a1").Offset(x, intOffset) = hWnd
                
                Case winOutputType.winTitle
                    strText = String$(100, Chr$(0))
                    lngRet = GetWindowText(hWnd, strText, 100)
                    If lngRet > 0 Then
                        Range("a1").Offset(x, intOffset) = Left$(strText, lngRet)
                    Else
                        Range("a1").Offset(x, intOffset) = "N/A"
                    End If
                
                Case winOutputType.winHandleClass
                    Range("a1").Offset(x, intOffset) = hWnd
                    strText = String$(100, Chr$(0))
                    lngRet = GetClassName(hWnd, strText, 100)
                    Range("a1").Offset(x, intOffset + 1) = Left$(strText, lngRet)
                
                Case winOutputType.winHandleTitle
                    Range("a1").Offset(x, intOffset) = hWnd
                    strText = String$(100, Chr$(0))
                    lngRet = GetWindowText(hWnd, strText, 100)
                    If lngRet > 0 Then
                        Range("a1").Offset(x, intOffset + 1) = Left$(strText, lngRet)
                    Else
                        Range("a1").Offset(x, intOffset + 1) = "N/A"
                    End If
                
                Case winOutputType.winHandleClassTitle
                    Range("a1").Offset(x, intOffset) = hWnd
                    strText = String$(100, Chr$(0))
                    lngRet = GetClassName(hWnd, strText, 100)
                    Range("a1").Offset(x, intOffset + 1) = Left$(strText, lngRet)
                    strText = String$(100, Chr$(0))
                    lngRet = GetWindowText(hWnd, strText, 100)
                    If lngRet > 0 Then
                        Range("a1").Offset(x, intOffset + 2) = Left$(strText, lngRet)
                    Else
                        Range("a1").Offset(x, intOffset + 2) = "N/A"
                    End If
            End Select
             
            ' check for children
            y = x
            Select Case OutputType
                Case Is > 4
                    sGetWinInfo hWnd, intOffset + 3, OutputType
                Case Is > 2
                    sGetWinInfo hWnd, intOffset + 2, OutputType
                Case Else
                    sGetWinInfo hWnd, intOffset + 1, OutputType
            End Select
             
            ' increment by 1 row if no children found
            If y = x Then x = x + 1
             
            ' now get next window
            hWnd = FindWindowEx(hParent, hWnd, vbNullString, vbNullString)
        Wend
    End Sub
#End If

Next steps in development should be get the captured image inside a picture control on a new UserForm, and once all the controls are identified and located by position, recreate the original UserForm, so the GUI is cloned in no time, with -depending on the original developer effort on tidyness- probably right names (instead of CommandButton1, ListBox1,…, you know), and all the labels filled with text. The internal code is where you as a developer should put your best to emulate the original code… but that is another history.

VBA Excel set columns width/rows height in millimeters

I wanted to get an Excel table with fixed dimensions (in millimeters). But Excel works with different units, not to say that column width and row heights are handled completely different.

Searching the web, did get to a viable code, but it was extremelly slow (when a bunch of resizes has to be performed). So I tunned the code a bit, with a first approximation to the final width objective, so less resize operations had to be carried out.

Here is the code, hope it helps:

Option Explicit

Sub ChangeWidthAndHeight()
    SetColumnWidthMM 1, 10
    SetRowHeightMM 1, 10
End Sub

Private Sub SetRowHeightMM(ByVal RowNo As Long, _
                           ByVal mmHeight As Integer)
' changes the Row Height to mm Height
    With ActiveSheet
        If RowNo < 1 Or RowNo > .Rows.Count Then Exit Sub
    End With
    
    With Application
        .ScreenUpdating = False
        ActiveSheet.Rows(RowNo).RowHeight = .CentimetersToPoints(mmHeight / 10)
        .ScreenUpdating = True
    End With
End Sub

Private Sub SetColumnWidthMM(ByVal ColNo As Long, _
                             ByVal mmWidth As Integer)
' changes the column width to mm Width
' Column widths are not really measured in any "unit" as such.
' Instead, the number refers to the number of characters which can be displayed in the column.
' For variable width fonts such as Arial, the "0" character is used.
' In VBA, the ColumnWidth property uses this measure of width, and the Width property uses Points.
' 1 inch = 72 points
' 1 pointH = 1/72 inches.
' 1 pointH = 0.0353 centimeters (or .353 millimetre)
' 1 pointH = ... x pixels
    
    Dim w As Single
    Dim wSize As Single
    
    With ActiveSheet
        If ColNo < 1 Or ColNo > .Columns.Count Then Exit Sub
    End With
    
    Application.ScreenUpdating = False
    
    w = Application.CentimetersToPoints(mmWidth / 10)
    With ActiveSheet
        wSize = (.Columns(ColNo + 1).Left - .Columns(ColNo).Left)
        
        ' First approximation:
        With .Columns(ColNo)
            .ColumnWidth = .ColumnWidth * (w / wSize)
        End With
        
        While .Columns(ColNo + 1).Left - .Columns(ColNo).Left - 0.1 > w
            '.Columns(ColNo).ColumnWidth = .Columns(ColNo).ColumnWidth - wMove
            With .Columns(ColNo)
                'Debug.Print .ColumnWidth
                .ColumnWidth = .ColumnWidth - 0.1
            End With
        Wend
        While .Columns(ColNo + 1).Left - .Columns(ColNo).Left + 0.1 < w
            With .Columns(ColNo)
                'Debug.Print .ColumnWidth
                .ColumnWidth = .ColumnWidth + 0.1
            End With
        Wend
    End With
    
    Application.ScreenUpdating = True
End Sub