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

GUID on VBA

BIM got this thing of GUID to reference the different elements/components inside the file.

But somewhen in the future, I’ll need to get my own GUID function to reference elements.

In Excel is a bit hard to produce via function with this formula:

= CONCATENATE(DEC2HEX(RANDBETWEEN(0,4294967295),8),"-",DEC2HEX(RANDBETWEEN(0,6553??5),4),"-",DEC2HEX(RANDBETWEEN(16384,20479),4),"-",DEC2HEX(RANDBETWEEN(32768,49151??),4),"-",DEC2HEX(RANDBETWEEN(0,65535),4),DEC2HEX(RANDBETWEEN(0,4294967295),8))

To get a more consistent method, we can rely on VBA. Here is the code:

' No VT_GUID available so must declare type GUID
Private Type GUID_TYPE
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

#If VBA7 Then
    Private Declare PtrSafe Function CoCreateGuid Lib "ole32.dll" (Guid As GUID_TYPE) As LongPtr
    Private Declare PtrSafe Function StringFromGUID2 Lib "ole32.dll" (Guid As GUID_TYPE, ByVal lpStrGuid As LongPtr, ByVal cbMax As Long) As LongPtr

    Public Function GenerateGUID() As String
        Dim Guid As GUID_TYPE
        Dim strGuid As String
        Dim retValue As Long 'Ptr
        Const guidLength As Long = 39 'registry GUID format with null terminator {xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx}
    
        retValue = CoCreateGuid(Guid)
        If retValue = 0 Then
            strGuid = String$(guidLength, vbNullChar)
            retValue = StringFromGUID2(Guid, StrPtr(strGuid), guidLength)
            If retValue = guidLength Then
                ' valid GUID as a string
                GenerateGUID = strGuid
            End If
        End If
    End Function
#Else
    Private Declare Function CoCreateGuid Lib "ole32" (ByRef Guid As Byte) As Long

    Public Function GenerateGUID() As String
        Dim ID(0 To 15) As Byte
        Dim N As Long
        Dim Guid As String
        Dim Res As Long
        
        Res = CoCreateGuid(ID(0))
        For N = 0 To 15
            Guid = Guid & IIf(ID(N) < 16, "0", "") & Hex$(ID(N))
            If Len(Guid) = 8 Or Len(Guid) = 13 Or Len(Guid) = 18 Or Len(Guid) = 23 Then
                Guid = Guid & "-"
            End If
            Next N
        GenerateGUID = Guid
    End Function

    'Private Declare Function CoCreateGuid_2 Lib "ole32" (ByRef Guid As GUID_TYPE) As Long
    'Public Function NewGUID() As String
    ''(c) 2000 Gus Molina
    '' Not working!
    '
    '    Dim udtGUID As GUID_TYPE
    '
    '    If (CoCreateGuid_2(udtGUID) = 0) Then
    '        GetGUID = _
                String(8 - Len(Hex$(udtGUID.Data1)), "0") & Hex$(udtGUID.Data1) & _
                String(4 - Len(Hex$(udtGUID.Data2)), "0") & Hex$(udtGUID.Data2) & _
                String(4 - Len(Hex$(udtGUID.Data3)), "0") & Hex$(udtGUID.Data3) & _
                IIf((udtGUID.Data4(0) < &H10), "0", "") & Hex$(udtGUID.Data4(0)) & _
                IIf((udtGUID.Data4(1) < &H10), "0", "") & Hex$(udtGUID.Data4(1)) & _
                IIf((udtGUID.Data4(2) < &H10), "0", "") & Hex$(udtGUID.Data4(2)) & _
                IIf((udtGUID.Data4(3) < &H10), "0", "") & Hex$(udtGUID.Data4(3)) & _
                IIf((udtGUID.Data4(4) < &H10), "0", "") & Hex$(udtGUID.Data4(4)) & _
                IIf((udtGUID.Data4(5) < &H10), "0", "") & Hex$(udtGUID.Data4(5)) & _
                IIf((udtGUID.Data4(6) < &H10), "0", "") & Hex$(udtGUID.Data4(6)) & _
                IIf((udtGUID.Data4(7) < &H10), "0", "") & Hex$(udtGUID.Data4(7))
    '    End If
    'End Function
#End If

Public Sub sGenerateGUID()
    MsgBox GenerateGUID ' NewGUID
End Sub

Revit VB.Net programming

I’m not for the Revit thing, but following the BIM master class I have to deal with this kind of software.

The practices needs to perform some repeated tasks, not a lot by now, but they will reach a point when they will start to bother me if I repeat them. So I looked for some automatization in the Revit world. For my desesperation, no VBA there, only C# and VB.Net rubbish.

First I must state that coming from the Excel VBA environment, the Revit macro manager environment looked like a baby (to say it pollitely). I’m shocked on how it performs every task so slow, and the little power for debugging that has been put there.

At the end of the day, playing around with Revit and the code I had found so far, I get the idea that Revit is very very very raw, still changing how to access the core components. Most of the code was not working because it has been deprecated, or some methods are not there anymore to be called. I feel frustrated. From this point, it starts the history of my struggle to get the thing working.

Continue reading “Revit VB.Net programming”

Get selection formatting

Here is a nice and handy script to get all the main format for a range selection, that can be applied afterwards to same range (as template):

Public Sub sFormatGet()
    Call fFormatGet(Selection)
End Sub

Public Function fRangeR1C1(ByVal oXlRng As Excel.Range, _
                           Optional ByVal oXlRef As Excel.Range = Nothing) As String
    Dim lgC As Long
    Dim lgR As Long
    Dim strRngR1C1 As String

    If oXlRef Is Nothing Then
        Set oXlRef = ActiveSheet.Cells(1, 1)
    End If

    lgR = oXlRng.Row
    lgC = oXlRng.Column

    fRangeR1C1 = strRngR1C1
End Function

Public Function fFormatGet(ByRef oXlRng As Excel.Range, _
                           Optional ByVal ReferenceStyle As XlReferenceStyle = xlA1) As Boolean
    If oXlRng Is Nothing Then
        Set oXlRng = Selection.Cells
    End If

    Dim oXlCell As Excel.Range
    Dim lgBorder As Long
    Dim iFileOut As Integer
    Dim bFormat As Boolean
    Dim bRange As Boolean
    Dim strRange As String

    Close
    iFileOut = VBA.FreeFile()
    Open VBA.Environ$("UserProfile") & "\Documents\" & "#Format.bas" For Output As #iFileOut
    
    Print #iFileOut, "Private Sub sFormatSet(ByVal xlWsh As Excel.Worksheet)"
    Print #iFileOut, "  'Dim oXlCell As Excel.Range"
    Print #iFileOut, ""
    Print #iFileOut, "  With xlWsh"
    
    For Each oXlCell In oXlRng.Cells
        bFormat = False
        bRange = False
        If oXlCell.MergeCells Then
            ' only if cell is the left-top most cell in merge area,...
            If oXlCell.MergeArea.Cells(1, 1).Address = oXlCell.Address Then
                bFormat = True
                oXlCell.MergeArea.Merge
                bRange = True
                strRange = ".Range(""" & oXlCell.MergeArea.Address & """)"
                
                'If ReferenceStyle = xlA1 Then
                '    strRange = .Formula
                'Else
                '    strRange = fRangeR1C1(oXlCell.MergeArea)
                'End If
            End If
        Else
            bFormat = True
            strRange = ".Cells(" & oXlCell.Row & ", " & oXlCell.Column & ")"
            
            'If ReferenceStyle = xlA1 Then
            '    strRange = .Formula
            'Else
            '    strRange = fRangeR1C1(oXlCell)
            'End If
        End If
        
        If bFormat Then
        Print #iFileOut, "    With " & strRange
        Print #iFileOut, "      .Merge"
        If oXlCell.Formula <> vbNullString Then
            'If ReferenceStyle = xlA1 Then
                Print #iFileOut, "      .Formula = " & VBA.Replace(oXlCell.Formula, """", """""")
            'Else
            '    Print #iFileOut, "      .Formula = " & VBA.Replace(oXlCell.FormulaR1C1, """", """""")
            'End If
        End If
        
        With oXlCell
            If .IndentLevel <> 0 Then
                Print #iFileOut, "    .IndentLevel = " & .IndentLevel
            End If
            
            With .Font
                Print #iFileOut, "      With .Font"
                Print #iFileOut, "        .Name = """ & .Name & """"
                Print #iFileOut, "        .Color = " & .Color
                Print #iFileOut, "        .Size = " & .Size
                If .Bold Then Print #iFileOut, "        .Bold = " & .Bold
                If .Italic Then Print #iFileOut, "        .Italic = " & .Italic
                If .Underline <> xlNone Then Print #iFileOut, "        .Underline = " & VBA.CBool(.Underline)
                If .Strikethrough Then Print #iFileOut, "        .Strikethrough = " & VBA.CBool(.Strikethrough)
                If .Subscript Then Print #iFileOut, "        .Subscript = " & VBA.CBool(.Subscript)
                If .Superscript Then Print #iFileOut, "        .Superscript = " & VBA.CBool(.Superscript)
                Print #iFileOut, "      End With"
            End With
            If .Hyperlinks.Count > 0 Then
                With .Hyperlinks(1)
                    Print #iFileOut, "    .Hyperlinks.Add(" & _
                        "               Anchor:=" & oXlCell & ", " & _
                        VBA.IIf(.Address = vbNullString, "", "               Address:=" & .Address & ", ") & _
                        VBA.IIf(.SubAddress = vbNullString, "", "               SubAddress:=" & .SubAddress & ", ") & _
                        VBA.IIf(.ScreenTip = vbNullString, "", "               ScreenTip:=" & .ScreenTip & ", ") & _
                        VBA.IIf(.TextToDisplay = vbNullString, "", "               TextToDisplay:=" & .TextToDisplay & ", ") & _
                        ")"
                End With
            End If
            Print #iFileOut, "      .NumberFormat = """ & .NumberFormat & """"
            Print #iFileOut, "      .Orientation = " & .Orientation
            Print #iFileOut, "      .ShrinkToFit = " & .ShrinkToFit
            
            With .Interior
                Print #iFileOut, "      With .Interior"
                If .ColorIndex <> xlNone Then Print #iFileOut, "        .ColorIndex = " & .ColorIndex
                If .PatternColor <> 0 Then Print #iFileOut, "        .PatternColor = " & .PatternColor
                If .Pattern <> xlNone Then Print #iFileOut, "        .Pattern = " & .Pattern
                Print #iFileOut, "      End With"
            End With
        End With
        
        For lgBorder = xlEdgeLeft To xlEdgeRight
            With oXlCell.Borders(lgBorder)
                Print #iFileOut, "      With .Borders(" & lgBorder & ")"
                Print #iFileOut, "        .LineStyle = " & .LineStyle
                'Print #iFileOut, "        .ThemeColor = " & .ThemeColor
                If .TintAndShade <> 0 Then Print #iFileOut, "        .TintAndShade = " & .TintAndShade
                If .Color <> 0 Then Print #iFileOut, "        .Color = " & .Color
                Print #iFileOut, "        .Weight = " & .Weight
                Print #iFileOut, "      End With"
            End With
        Next lgBorder
        Print #iFileOut, "    End With"
        Print #iFileOut, ""
        End If
    Next oXlCell
    
    Print #iFileOut, "  End With"
    Print #iFileOut, "End Sub"
    Close #iFileOut
End Function

Deep learning

Intro

I don’t know where this post will lead to (started the journey 01/21/19). The commitment is to get a Neuronal network add-in for Excel… limit time is end of 2019 (nothing bad would happen if goals could be achieved earlier).

Absolutely, Excel is not the right tool to carry serious ANN -in terms of perfomance-, but, considering that all the computations can be shown in real time, and that you can mount a RAD model of every architecture, it should be considered among the better options to learn the subject from the basics. And the two final reasons where I finally arrive at: because I can do it, and because is so ubiquous that it does not limit to matematicians and IT people to play this things. If you want to make big stuff, you should consider other platforms and even other hardware… but that’s not my target and this is not your site if you have arrived here looking for other than Excel.

Going to the business, from all the architectures that can be performed under the label of ANN, I’ll try to first pursue the ConvNet as they expose most of the algebra needed to perform the whole thing, so I hope it will be easier for me to adapt to other type of architectures. The final goal is to get a tool that can be good for any ANN model (considering the size limitations).

This post should end fused with my previous post on Neuronal Network on Excel (task pending…).

Milestones

Expecifically I’m looking after the following goals:

  • NN activation functions (those exposed on the wikipedia article). Achieved 01/22/19
  • NN matrix algebra (multiplication, add/substraction, element-wise operations… with matrices/vectors). Half achieved, refactoring the MatLab translator module. Others should came from the JS translator.
  • NN neuron manipulation (add/delete/copy/move).
  • NN layer manipulation (add/delete/copy/move).
  • NN specific functions. Filter, Pool, stride, convolute, backpropagate,…
  • BMP/JPG import/export… someway achieved refactoring the ASCII Excel module.

As soon as each goal be achieved, then it will be converted to milestone.

There’s one specific problem if this is to be done under Excel Environment… limits. For example, the >2K3 column limit of 16384 can hardly allow to show/represent more than a set of (72×72, RGB) bits in vectorized form in one worksheet. I still don’t have managed a way to overcome this limit, as I consider necessary to show the data on the cells, but surely will come to one (split neurons on different worksheets, aggregate inputs in 2D shape,…).

Other’s implementations that I can base the thing on…

Not an exhaustive list, and maybe not any usefull, but here is a recopilation of other software I’ve seen to perform NN tasks:

  • SNNS (Stuttgart Neural Network Simulator)
  • IMPLEMENTATION OF AN MS EXCEL TOOL FOR BACKPROPAGATION
    NEURAL NETWORK ALGORITHM IN ENVIRONMENTAL ENGINEERING
    EDUCATION (Selami DEMİR & others)
  • XLStat
  • deepExcel (even it’s satiric)

Bibliography

  • Andrew Ng specialization course -videos- Deeplearning.ai, on Coursera platform. Very instructive, tips are explained in a very clear form, so anyone, even with not a high level of maths, can follow. You need to know and understand algebra. Only one handicap, IMO, is that it’s focused on TensorFlow (Google) platform.
  • Jeremy Howard’s courses on fast.ai platform, online courses -also on Youtube– (and here a little trick if you’re to follow this course). To use on PyTorch, that seems to have its momentum by the end of 2018 and as a true OpenSource alternative can stay for long. Differences between them spotted here.
  • Geoffrey Hinton Machine Learning course (Collin McDonell’s youtube list). You will need a stronger math basement to follow this lessons.
  • Make Your Own Neural Network in Python book, by Tariq Rashid
  • Ian Goodfellow/Yoshua Bengio/Aaron Courville MIT book. A lot of algebra there (maybe a hard path to go if you’re to learn about NN).
  • Christopher Olah’s blog.
  • Andrej Karpathy’s blog
  • Andrew Trask’s blog
  • Emill Wallner’s blog and all the other stuff on FloydHub
  • https://pyrenn.readthedocs.io/en/latest/create.html
  • https://medium.com/@geek_kid
  • Youtube. You can drown before getting bored or quit out, so here is my ANN channel list on the topic to have all the videos I liked in the same place.

Other info

Moreover, some other projects on GitHub:

On Medium there are a lot of interesting articles as well (I must confess that I personally get surprised of how people put a lot of creativity to achieve a goal that stands above most “expert” no-sayers):

No Python performance on Excel?. Don’t worry, use Python in Excel and get the best of both worlds.

Even on Google Sheets

vtt to srt. Video subtittles

On the Cousera platform I downloaded the subtittles of the courses, but they only were offering the *.vtt file, which is a superset of the *.srt that MediaPlayerClassics handle for subs.

I was on the need to convert all from vtt to srt, but did not want to go through all files, delete the heading and save as new file, so, here is a macro that “hardly” goes for each folder and gets the job done.

Option Explicit
            
Function fFileLoad(ByRef strFullPathFile As String) As String()
    Dim iFile As Integer
    Dim lgLine As Long
    Dim aLine() As String
    Dim strLine As String

    iFile = VBA.FreeFile()
    Open strFullPathFile For Input Shared As #iFile
    Line Input #iFile, strLine
    Close #iFile
    'lgLine = 0
    'Do Until EOF(iFile)
        'lgLine = lgLine + 1
        'ReDim Preserve aLine(1 To lgLine)
        'aLine(lgLine) = VBA.Replace(strLine, vbLf, vbCrLf)
    'Loop
    aLine() = VBA.Split(strLine, vbLf)
    fFileLoad = aLine()
    Erase aLine()
End Function

Function fFoldersLoad(ByRef strPathBase As String) As String()
' get folders...
    Dim strPath As String
    Dim aFolder() As String
    Dim lgFolder As Long
    
    strPath = VBA.Dir(strPathBase, vbDirectory)
    lgFolder = 0
    Do
        If Not strPath Like ".*" Then
        If VBA.GetAttr(strPathBase & strPath) And vbDirectory Then
            lgFolder = lgFolder + 1
            ReDim Preserve aFolder(1 To lgFolder)
            aFolder(lgFolder) = strPathBase & strPath & "\"
        End If
        End If
        strPath = VBA.Dir
    Loop Until strPath = vbNullString

    fFoldersLoad = aFolder()
    Erase aFolder()
End Function

Function fFilesLoad(ByVal strPathBase As String, _
                    Optional ByVal strFilter As String = "*.*") As String()
' get Files...
    Dim strPath As String
    Dim aFile() As String
    Dim strFile As String
    Dim lgFile As Long
    
    strFile = VBA.Dir(strPathBase & strFilter, vbArchive)
    If strFile = vbNullString Then Exit Function
    lgFile = 0
    Do
        lgFile = lgFile + 1
        ReDim Preserve aFile(1 To lgFile)
        aFile(lgFile) = strPath & strFile
        strFile = VBA.Dir
    Loop Until strFile = vbNullString

    fFilesLoad = aFile()
    Erase aFile()
End Function

Function fVttToSrt(ByVal strFullPathFile As String) As Boolean
    Dim iFile As Integer
    Dim aLine() As String
    Dim lgLine As Long
    
    iFile = VBA.FreeFile()
    aLine() = fFileLoad(strFullPathFile)
    
    Open VBA.Replace(strFullPathFile, ".vtt", ".srt") For Output Shared As #iFile
    For lgLine = (LBound(aLine) + 2) To UBound(aLine)
        Print #iFile, aLine(lgLine)
    Next lgLine
    Close #iFile
End Function

Sub sVttToSrt()
    Dim aFile() As String
    Dim aFolder() As String
    Dim aSubFolder() As String
    Dim lgFolder As Long
    'Dim strFullPathFile As String
    Dim oFile As Variant
    Dim oFolder As Variant
    Dim oSubFolder As Variant
    Dim strPath As String
    Dim strPathBase As String
    Dim strFile As String
    Dim aLine() As String
    Dim lgLine As Long
    
    strPathBase = VBA.Environ$("UserProfile") & "\Downloads\" & "ANN\Andrew Ng_DeepLearning_Course\"
    Erase aFolder()
    aFolder() = fFoldersLoad(strPathBase)
    
    For Each oFolder In aFolder()
        strPathBase = VBA.CStr(oFolder)
        
        ' get subfolders
        Erase aSubFolder()
        aSubFolder() = fFoldersLoad(strPathBase)
        
        ' get files in root
        Erase aFile()
        aFile() = fFilesLoad(strPathBase, "*.vtt")
        If Not (Not aFile) Then
            For Each oFile In aFile()
                ' convert vtt to srt
                Call fVttToSrt(strPathBase & VBA.CStr(oFile))
            Next oFile
        End If
        
        ' go for subfolders
        If Not (Not aSubFolder) Then
            For Each oSubFolder In aSubFolder()
                strPathBase = VBA.CStr(oSubFolder)
                
                ' get files
                Erase aFile()
                aFile() = fFilesLoad(VBA.CStr(oSubFolder), "*.vtt")
                If Not (Not aFile) Then
                    For Each oFile In aFile()
                        ' convert vtt to srt
                        Call fVttToSrt(strPathBase & VBA.CStr(oFile))
                    Next oFile
                End If
            Next oSubFolder
        End If
    Next oFolder

End Sub

As mentioned, it’s not very sophisticated, but at least, finds the first subfolder structure in a folder, gets the files on the root and does the silly things to get the srt working on MPC. For a more advanced macro, that recursively gets all the folder structure, better look at this post.

Word to Excel (part 2)

In a past post I dealed with the needing of moving Word to Excel.

Recently I needed to get all the tables from a bunch of Word documents inside Excel. The thing was that the Copy-PasteSpecial Format:=”Text” did not behaved as expected, as it did not paste as text but as an image. Uhm, we start to get into trouble. To get things worse, then I found that the paste operation was getting itself in problems when they mess with the screenupdating or the calculation… Excel getting into “Busy state”, so I set a “wait until Complete state” loop to solve this point.

And then I realised the word tables, that came from a PDF that also came from a Word document had an caotic structure because the “translation” operations. Buf… to much to deal with (after we can get the table stuff).

Here is the code that takes the tables from Word to Excel (as they come). Handy to use whenever we need Word To Excel data interchange.

Public Sub read_word_document()
'!!!!!!!!!!!!!!!!!!!!!!!!!
    Dim DOC_PATH As String: DOC_PATH = ThisWorkbook.Path & "\"
'!!!!!!!!!!!!!!!!!!!!!!!!!
    Dim strFile As String
    Dim oXlApp As Excel.Application
    Dim oXlWbk As Excel.Workbook
    Dim oXlWbk0 As Excel.Workbook
    Dim oXlWsh As Excel.Worksheet
    Dim oXlWsh0 As Excel.Worksheet
    Dim oXlRng As Excel.Range
    Dim oXlTRow As Excel.Range
    Dim oXlTCol As Excel.Range
    Dim oXlCell As Excel.Range
    
    Dim oWdApp As Word.Application
    Dim oWdDoc As Word.Document
    Dim oWdTab As Word.Table
    Dim oWdTRow As Word.Row
    Dim oWdTCol As Word.Column
    Dim oWdCell As Word.Cell
    
    Dim lgTable As Long
    Dim bGetData As Boolean
    'Dim bSplitData As Boolean
    Dim lgR As Long
    Dim lgC As Long
    Dim strText As String
    Dim aData() As String
    Dim lgData As Long
    
'    On Error GoTo ErrHandler
    Set oWdApp = GetObject(, "Word.Application")
    'Set oWdApp = CreateObject("Word.Application")
    'oWdApp.Visible = False
    Do While oWdApp.Documents.Count > 0
        oWdApp.ActiveDocument.Close SaveChanges:=False
    Loop
    
    Set oXlApp = GetObject(, "Excel.Application")
    'Set oXlApp = CreateObject("Excel.Application")
    'oXlApp.Visible = False
    Set oXlWbk0 = oXlApp.ActiveWorkbook
     
    'lgR = 0
    strFile = VBA.Dir(DOC_PATH & "*.doc*")
    Do Until strFile = vbNullString
        Set oWdDoc = oWdApp.Documents.Open(Filename:=DOC_PATH & strFile, ReadOnly:=True)

        If oWdDoc.Tables.Count > 0 Then
            Set oXlWbk = oXlApp.Workbooks.Add() '.Open(fileName:=DOC_PATH & strFile, ReadOnly:=False)
            oXlWbk.SaveAs Filename:=DOC_PATH & VBA.Replace(strFile, ".doc", ".xls")
            
            lgR = 0
            Set oXlWsh0 = oXlWbk0.Sheets.Add
            oXlWsh0.Name = "#" & strFile
            oXlWsh0.Activate
            Set oXlRng = oXlWsh0.Range("A1")
            'oXlWsh0.Cells.ClearContents
            oXlRng.Select
            
            lgTable = 0 ' resume table
            For Each oWdTab In oWdDoc.Tables
                DoEvents

'                If vbNo = MsgBox("table " & lgTable & ", resume?", vbYesNo) Then Stop
'                On Error Resume Next
'                For Each oWdTRow In oWdTab.Rows
'                    If Err.Number = 5991 Then GoTo ExitTable
'                    If bGetData Then ' copy this data
'                        lgR = lgR + 1
'                        lgC = 0
'                        For Each oWdCell In oWdTRow.Cells
'                            lgC = lgC + 1
'                            If Not VBA.Trim$(oWdCell.Range.text) Like vbNullString Then
'                                oXlWsh.Cells(lgR, lgC).Value = oWdCell.Range.text
'                            End If
'                        Next oWdCell
'                    End If
'                Next oWdTRow
'ExitTable:
'                On Error GoTo 0
                'bSplitData = False
                lgTable = lgTable + 1
                Set oXlWsh = oXlWbk.Sheets.Add
                oXlWsh.Name = "H_" & lgTable
                oXlWsh.Activate
                Set oXlRng = oXlWsh.Range("A1")
                oXlRng.Select
                
                ' Copy table to Excel, then depurate
                oWdTab.Select
            
                On Error GoTo ErrWait
                oWdTab.Range.Copy
                oXlRng.Parent.Paste
                On Error GoTo 0
                
                'oXlRng.Parent.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False
                Set oXlRng = oXlRng.Resize(oWdTab.Rows.Count, oWdTab.Columns.Count)
                With oXlRng
                    With .Cells
                        .UnMerge
                        .MergeCells = False
                        .WrapText = False
                        .VerticalAlignment = xlBottom
                        .Orientation = 0
                        .AddIndent = False
                        .IndentLevel = -1
                        .ShrinkToFit = False
                        .ReadingOrder = xlContext
                        
                        '.columnWidth = 14
                        '.RowHeight = 14
                        .Font.Size = 10
                        .Font.Name = "Calibri"
                    End With
                    
                    For Each oXlTRow In oXlRng.Rows
                        'bGetData = False
                        'For Each oXlCell In oXlTRow.Cells
                        '    If VBA.UCase$(oXlCell.Value) Like "*" Then
                        '        bGetData = True
                        '        Exit For
                        '    End If
                        'Next oXlCell
    
                        If bGetData Then ' copy this row
                            'bSplitData = True
                            lgR = lgR + 1
                            lgC = 0
                            For Each oXlCell In oXlTRow.Cells
                                'If Not IsEmpty(oXlCell.Value) Then
                                If Not VBA.Trim$(oXlCell.Value) Like vbNullString Then
                                    lgC = lgC + 1
                                    oXlWsh0.Cells(lgR, lgC).Value = oXlCell.Value
                                End If
                            Next oXlCell
                        End If
                    Next oXlTRow
                End With
            
                'If bSplitData Then lgR = lgR + 3
                Set oXlRng = oXlRng.Offset(oWdTab.Rows.Count + 2, 0)
            Next oWdTab
        End If
                    
        'Stop
        ' Delete all temp worksheets
        'oXlApp.DisplayAlerts = False
        'For Each oXlWsh In oXlWbk.Worksheets
        '    If oXlWsh.Name Like "H*" Then
        '        oXlWsh.Delete
        '    End If
        'Next oXlWsh
        'oXlApp.DisplayAlerts = True
        'Stop

        oWdDoc.Close SaveChanges:=False
        oXlWbk.Close SaveChanges:=False
        
        strFile = VBA.Dir
    Loop
'    oWdApp.Quit
     
    GoTo done
     
ErrWait:
'Stop
    Application.Wait ((Now + TimeValue("0:00:02")))
    Resume

ErrClose:
    On Error Resume Next
     
ErrHandler:
    Debug.Print Err.Description
    On Error GoTo 0

done:
    ' Move all worksheets that has "#" to new file
    Dim aArray As Variant
    
    lgData = -1
    Erase aData()
    For Each oXlWsh0 In oXlWbk0.Worksheets
        If oXlWsh0.Name Like "[#]*" Then
            lgData = lgData + 1
            ReDim Preserve aData(0 To lgData)
            aData(lgData) = oXlWsh0.Name
        End If
    Next oXlWsh0
    aArray = aData()
    oXlWbk0.Sheets(aArray).Move
End Sub

EXCEL VBA MULTITHREADING

This is another post I have started beeing inspired by posts on AnalystCave blog, and wanted to reach further from where he left it.

There are some starting posts with info that worth to take a look before getting hands on dough:

Continue reading “EXCEL VBA MULTITHREADING”