Blog

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”

VBA FTP

Again, from AnalystCave blog, I’ve found an interesting post about how to perform download/upload via FTP protocol in VBA. We should rely on some API functions. The code presented here is 90% the same from the original post, but tidied a bit so it can be reused on a UserForm with ease. There’s only the need for 4 textboxes (userName, Password, Port, SeverHost IP address), and 2 more textboxes (linked one each to 2 listboxes/treebox) to deal with the archives both in the local drive and in the server. And buttons to Upload/Download and Cancel… and you have a clean interface to do FTP under VBA.

Following are the common API functions and constants needed:

Private Const FTP_TRANSFER_TYPE_UNKNOWN As Long = 0
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000

Private Declare Function InternetOpenA Lib "wininet.dll" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function InternetConnectA Lib "wininet.dll" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Long, ByVal sUsername As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lcontext As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet" (ByVal hInet As Long) As Long
Private Declare Function FtpGetFileA Lib "wininet.dll" (ByVal hConnect As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Long, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Declare Function FtpPutFileA Lib "wininet.dll" (ByVal hFtpSession As Long, ByVal lpszLocalFile As String, ByVal lpszRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean

VBA FTP Download Files

To download files via FTP protocol in VBA, use this code:

Private Function FtpDownload(ByVal strRemoteFile As String, _
                             ByVal strLocalFile As String, _
                             ByVal strHost As String, _
                             ByVal lngPort As Long, _
                             ByVal strUser As String, _
                             ByVal strPass As String) As Boolean
' to download file from server:
    
    Dim hOpen As Long
    Dim hConn As Long
    Dim lgRetVal As Long

    hOpen = InternetOpenA("FTPGET", 1, vbNullString, vbNullString, 1)
    hConn = InternetConnectA(hOpen, strHost, lngPort, strUser, strPass, 1, 0, 2)
    
    If Not FtpGetFileA(hConn, _
                       strRemoteFile, _
                       strLocalFile, _
                       1, _
                       0, _
                       FTP_TRANSFER_TYPE_UNKNOWN Or INTERNET_FLAG_RELOAD, _
                       0) Then
        lgRetVal = VBA.MsgBox("Error while downloading file [" & strRemoteFile & "] from server", _
                              vbCritical, "W A R N I N G")
    End If

     'Close connections
    InternetCloseHandle hConn
    InternetCloseHandle hOpen
End Function
Syntax

strRemoteFile 
A string path to the file on the remote FTP drive which you want to download e.g. “//home/user/text file.txt”

strLocalFile 
A string path to the file on the local drive which you want to save the remote file to e.g. “C:\text file.txt”

strHost 
A string with the FTP server name e.g. “192.168.0.100” or “myserver.domain.com”.

lngPort 
A number specifying the FTP port. 21 by default.

strUser 
A string with the FTP user name.

strPass
A string with the FTP user password.

Example

Now let us use the above VBA FTP Download procedure to download a file from our FTP server.

Public Sub TestDownload()
    FtpDownload strRemoteFile:="//Download/file.txt", _
                strLocalFile:="C:\text file.txt", _
                strHost:="192.168.0.100", _
                lngPort:=21, _
                strUser:="username", _
                strPass:="password"
End Sub
VBA FTP Upload Files

To upload files from your local drive via FTP protocol in VBA, use this code:

Private Function FtpUpload(ByVal strLocalFile As String, _
                           ByVal strRemoteFile As String, _
                           ByVal strHost As String, _
                           ByVal lngPort As Long, _
                           ByVal strUser As String, _
                           ByVal strPass As String) As Boolean
' to upload file to server:
    
    Dim hOpen As Long
    Dim hConn As Long
    Dim lgRetVal As Long

    hOpen = InternetOpenA("FTPGET", 1, vbNullString, vbNullString, 1)
    hConn = InternetConnectA(hOpen, strHost, lngPort, strUser, strPass, 1, 0, 2)

    If Not FtpPutFileA(hConn, _
                       strLocalFile, _
                       strRemoteFile, _
                       FTP_TRANSFER_TYPE_UNKNOWN Or INTERNET_FLAG_RELOAD, _
                       0) Then
        lgRetVal = VBA.MsgBox("Error while uploading file [" & strRemoteFile & "] to server", _
                              vbCritical, "W A R N I N G")
    End If

     'Close connections
    InternetCloseHandle hConn
    InternetCloseHandle hOpen
End Function

Syntax

strLocalFile 
A string path to the file on the local drive which you want to upload e.g. “C:\text file.txt”
strRemoteFile 
A string path with the name of the upload file on the remote drive to e.g. “//home/user/text file.txt”

strHost 
A string with the FTP server name e.g. “192.168.0.100” or “myserver.domain.com”.

lngPort 
A number specifying the FTP port. 21 by default.

strUser 
A string with the FTP user name.

strPass
A string with the FTP user password.

Example

Public Sub TestUpload()
    FtpUpload strLocalFile:=VBA.Environ("UserProfile") & "\Documents\" & "file.txt", _
              strRemoteFile:="//Download/file.txt", _
              strHost:="192.168.0.100", _
              lngPort:=21, _
              strUser:="username", _
              strPass:="password"
End Sub

Download a file via VBA. Resume downloads

I’ve tried several ways to download a file, but none of them were truly convincing me, beeing the most promissing the URLDownloadToFile API function. But recently I found a post on the AnalystCave that rely on the InternetReadBinaryFile
The use of this API functions got me thinking if I can control the download progress (for example, to resume a broken download, or throw it to perform on VBscript). The VBS option comes really handy, as can free Excel of the downloading process, and doesn’t require an InternetExplorer object, so it can be used also as a method to overcome ban situations and continue downloading.

The lNumBytesToRead in the InternetReadBinaryFile function was very promissing, but did not manage to tame it to my requirements, so it looks like to resume a download will not be achieved via API functions. Anyway, googling a bit shows me that it could be done via XMLHTTP request (you had to tune the Range attribute… worth looking here,  here and here)

There’s another option to download files described here.

And following, the code that achieves the download resume:


Private Sub ResumeDownload(ByVal strURL As String, _
                           ByVal sSaveToFile As String, _
                           Optional ByVal overWriteFile As Boolean = False, _
                           Optional ByVal lgFirstByteToRead As Long = 0, _
                           Optional ByVal lgBytesToRead As Long = 0)
    Dim oHTTP As Object
    Dim oStream As Object
    Dim sBuffer() As Byte
    Dim totalRead As Long
    
    'Const bufSize = 128
    
    Set oHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    
    With oHTTP
        .Open "GET", strURL, False
        
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .setRequestHeader "Range", VBA.CStr("bytes=" & lgFirstByteToRead & "-" & VBA.IIf(lgBytesToRead = 0, "", lgFirstByteToRead + lgBytesToRead)) ' retrieve only this bytes...
        .send ("")
        
        'wait
        Do While .Status = 200 And .readyState = 4
            DoEvents
        Loop
        
        If lgBytesToRead = 0 Then lgBytesToRead = VBA.Len(.responsetext)
        
        ReDim sBuffer(0 To lgBytesToRead - 1)
        
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        
        'Do
        '    lgRetVal = InternetReadBinaryFile(hInternet, sBuffer(0), UBound(sBuffer) - LBound(sBuffer), lngDataReturned)
        '    If lngDataReturned = 0 Then Exit Do
        '
        '    If lngDataReturned < bufSize Then ReDim Preserve sBuffer(0 To lngDataReturned - 1)
            oStream.Write sBuffer
        '    ReDim sBuffer(0 To bufSize - 1)
        '    totalRead = totalRead + lngDataReturned
        '    'Application.StatusBar = "Downloading file. " & CLng(100 * totalRead / bufSize) & "% of " & totalRead & " KB downloaded"
        '    DoEvents
        'Loop While lngDataReturned <> 0
            
        'Application.StatusBar = "Download complete"
        oStream.SaveToFile sSaveToFile, IIf(overWriteFile, 2, 1)
        oStream.Close
    
        Dim iFileOut As Integer
        iFileOut = VBA.FreeFile()
        Open sSaveToFile For Binary As #iFileOut
        Put #iFileOut, , VBA.StrConv(.responsetext, vbFromUnicode)
        Close #iFileOut
    End With
End Sub

For the API methods, both discussed are shown here, activate the one you whish to try:

Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Option Explicit

Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Private Const DOWNLOAD_OK As Long = 0
'Private Const E_OUTOFMEMORY As Long = &H8007000E
'Private Const INTERNET_OPEN_TYPE_PRECONFIG As Long = 0
'Private Const INTERNET_FLAG_EXISTING_CONNECT As Long = &H20000000
'Private Const INTERNET_OPEN_TYPE_DIRECT As Long = 1
'Private Const INTERNET_OPEN_TYPE_PROXY As Long = 3
'Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal lpszAgent As String, ByVal dwAccessType As Long, ByVal lpszProxyName As String, ByVal lpszProxyBypass As String, ByVal dwFlags As Long) As Long
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal sUrl As String, ByVal sHeaders As String, ByVal lHeadersLength As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetReadBinaryFile Lib "wininet.dll" Alias "InternetReadFile" (ByVal hfile As Long, ByRef bytearray_firstelement As Byte, ByVal lNumBytesToRead As Long, ByRef lNumberOfBytesRead As Long) As Integer
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer

Sub TestDownload()
    Dim strPath As String
    strPath = VBA.Environ$("UserProfile") & "\Documents\" 'ThisWorkbook.Path
    'DownloadFile "https://analystcave.com/junk.txt", strPath & "junk.txt", True
    DownloadFile "https://www.planwallpaper.com/static/cache/76/ae/76aef16c40b4e4447233badc50b1845a.jpg", strPath & "image_https_2.jpg"
End Sub

Sub DownloadFile(ByVal sUrl As String, _
                 ByVal sSaveToFile As String, _
                 Optional ByVal overWriteFile As Boolean = False)
    Dim oStream As Object
    Dim hInternet As Long
    Dim hSession As Long
    Dim lngDataReturned As Long
    Dim sBuffer() As Byte
    Dim totalRead As Long
    Dim lgRetVal As Long
    
Stop    ' Method URLDownloadToFile
    'lgRetVal = URLDownloadToFile(0&, sUrl, sSaveToFile, 0&, 0)
    'If lgRetVal = DOWNLOAD_OK Then Exit Sub ' download completed
    
Stop    ' Method InternetReadBinaryFile
    Const bufSize = 128
    
    ReDim sBuffer(0 To bufSize - 1)
 
    hSession = InternetOpen("", 0, vbNullString, vbNullString, 0)
    If hSession Then
        hInternet = InternetOpenUrl(hSession, sUrl, vbNullString, 0, INTERNET_FLAG_NO_CACHE_WRITE, 0)
    End If
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    
    If hInternet Then
        lngDataReturned = 0
        Do
            lgRetVal = InternetReadBinaryFile(hInternet, sBuffer(0), UBound(sBuffer) - LBound(sBuffer), lngDataReturned)
            If lngDataReturned = 0 Then Exit Do
            
            If lngDataReturned < bufSize Then ReDim Preserve sBuffer(0 To lngDataReturned - 1)
            oStream.Write sBuffer()
            ReDim sBuffer(0 To bufSize - 1)
            totalRead = totalRead + lngDataReturned
            Application.StatusBar = "Downloading file. " & CLng(100 * totalRead / bufSize) & "% of " & totalRead & " KB downloaded"
            DoEvents
        Loop While lngDataReturned <> 0
        
        Application.StatusBar = "Download complete"
        oStream.SaveToFile sSaveToFile, IIf(overWriteFile, 2, 1)
        oStream.Close
    End If
    Call InternetCloseHandle(hInternet)

    Set oStream = Nothing
End Sub

Also, dealing with downloads topic, I also liked this post.

Versioning files with VBA

I was wandering through the AnalystCave blog, and stumped on this topic.

The add-in posted there was not fullfilling my requirements, so I decided to go a bit further, and then this came out:

Public Sub sSaveNewVersion()
    MsgBox SaveNewVersion("yymmdd*###")
End Sub

Public Function SaveNewVersion(Optional ByVal strTemplate As String = "yymmdd*###") As String
' Recommended templates:
' yymmdd        991231
' hh.mm         2355
' hh.mm.ss      235545
' ###           027
' ##            27
' #             7
' yymmdd_###    991231_015
' yymmdd_hh.mm  991231_23.55
    
    Dim strFileName As String
    Dim strPath As String
    Dim strExtension As String
    Dim aNaming() As String
    Dim strMask As String
    Dim strLastVersion As String
    Dim strPrefix As String
    Dim strSuffix As String

    Dim strVersion As String
    Dim iIndex As Integer

    strPath = ActiveDocument.Path & "\"     ' ActiveWorkbook.Path
    strFileName = ActiveDocument.Name       ' ActiveWorkbook.Name
    'strFileName = "190104_this_is only a test#015.docx"
    
    aNaming() = VBA.Split(strFileName, ".")
    strExtension = aNaming(UBound(aNaming))
    
    strFileName = VBA.Mid$(strFileName, 1, VBA.Len(strFileName) - VBA.Len(strExtension) - 1)
    'iIndex = ...
    
    aNaming() = VBA.Split(strTemplate, "*")
    If LBound(aNaming) = UBound(aNaming) Then
        strPrefix = vbNullString
        strMask = fMask(aNaming(LBound(aNaming)), strSuffix)
        
        strLastVersion = VBA.Mid$(strFileName, VBA.InStrRev(strFileName, "#") + 1)
        strFileName = VBA.Mid$(strFileName, 1, VBA.Len(strFileName) - VBA.Len(strLastVersion) - 1)
        
        If strLastVersion Like strMask Then
        ' Rip off strLastVersion from strFileName
            strFileName = VBA.Mid$(strFileName, 1, InStr(1, strFileName, strLastVersion))
            If strLastVersion Like aNaming(UBound(aNaming)) Then
                ' Get index...
                strSuffix = fNewIndex(aNaming(LBound(aNaming)), VBA.CInt(strLastVersion) + 1)
            End If
        End If
    
    Else
        strMask = fMask(aNaming(LBound(aNaming)), strPrefix)
        strLastVersion = VBA.Mid$(strFileName, 1, VBA.Len(strMask))
        If strLastVersion Like strMask Then
            strFileName = VBA.Mid$(strFileName, VBA.Len(strMask) + 1 + 1)
            If strLastVersion Like aNaming(UBound(aNaming)) Then
                ' Get index...
                strPrefix = fNewIndex(aNaming(LBound(aNaming)), VBA.CInt(strLastVersion) + 1)
            End If
        End If

        strMask = fMask(aNaming(UBound(aNaming)), strSuffix)
        strLastVersion = VBA.Mid$(strFileName, VBA.InStrRev(strFileName, "#") + 1)
        
        If strLastVersion Like strMask Then
        ' Rip off strLastVersion from strFileName
            strFileName = VBA.Mid$(strFileName, 1, VBA.Len(strFileName) - VBA.Len(strLastVersion) - 1)
            If strLastVersion Like aNaming(UBound(aNaming)) Then
                ' Get index...
                strSuffix = fNewIndex(aNaming(UBound(aNaming)), VBA.CInt(strLastVersion) + 1)
            End If
        End If
    End If
    
    strFileName = strPath _
                & strPrefix _
                & "_" _
                & strFileName _
                & "#" _
                & strSuffix & _
                "." & strExtension
    
    'ActiveDocument.SaveAs strFileName ' ActiveWorkbook.SaveAs strFileName
End Function

Private Function fNewIndex(ByVal strTemplate As String, _
                           ByVal iIndex As Integer) As String
' Get new version index
    Dim strVersion As String
    
    strVersion = strTemplate
    If strVersion Like "*[#][#][#]*" Then
        strVersion = VBA.Replace(strVersion, "###", VBA.Format(iIndex, "000"))
    ElseIf strVersion Like "*[#][#]*" Then
        strVersion = VBA.Replace(strVersion, "##", VBA.Format(iIndex, "00"))
    ElseIf strVersion Like "*[#]*" Then
        strVersion = VBA.Replace(strVersion, "#", VBA.Format(iIndex, "0"))
    End If
    
    fNewIndex = strVersion
End Function

Private Function fMask(ByVal strTemplate As String, _
                       ByRef strVersion As String) As String
    Dim strMask As String
    Dim iIndex As Integer
    
    strMask = strTemplate
    strVersion = strTemplate
    If strVersion Like "*yyyy*" Then
        strVersion = VBA.Replace(strVersion, "yyyy", VBA.Format(VBA.Now(), "yyyy"))
        strMask = VBA.Replace(strMask, "yyyy", "####")
    ElseIf strVersion Like "*yy*" Then
        strVersion = VBA.Replace(strVersion, "yy", VBA.Format(VBA.Now(), "yy"))
        strMask = VBA.Replace(strMask, "yy", "##")
    End If
    If strVersion Like "*mmmm*" Then
        strVersion = VBA.Replace(strVersion, "mmmm", VBA.Format(VBA.Now(), "mmmm"))
        strMask = VBA.Replace(strMask, "mmmm", "####")
    ElseIf strVersion Like "*mmm*" Then
        strVersion = VBA.Replace(strVersion, "mmm", VBA.Format(VBA.Now(), "mmm"))
        strMask = VBA.Replace(strMask, "mmm", "###")
    ElseIf strVersion Like "*mm*" Then
        strVersion = VBA.Replace(strVersion, "mm", VBA.Format(VBA.Now(), "mm"))
        strMask = VBA.Replace(strMask, "mm", "##")
    End If
    If strVersion Like "*dd*" Then
        strVersion = VBA.Replace(strVersion, "dd", VBA.Format(VBA.Now(), "dd"))
        strMask = VBA.Replace(strMask, "dd", "##")
    ElseIf strVersion Like "*d*" Then
        strVersion = VBA.Replace(strVersion, "d", VBA.Format(VBA.Now(), "d"))
    End If
    If strVersion Like "*hh.mm*" Then
        strVersion = VBA.Replace(strVersion, "hh.mm", VBA.Format(VBA.Now(), "hh.mm"))
        strMask = VBA.Replace(strMask, "hh.mm", "##.##")
    ElseIf strVersion Like "*hh*" Then
        strVersion = VBA.Replace(strVersion, "HH", VBA.Format(VBA.Now(), "hh.mm"))
        strMask = VBA.Replace(strMask, "hh", "##")
    End If
    If strVersion Like "*ss*" Then
        strVersion = VBA.Replace(strVersion, "ss", VBA.Format(VBA.Now(), "ss"))
        strMask = VBA.Replace(strMask, "ss", "##")
    End If
    
    fMask = strMask
End Function

Hope you enjoy

Copy entire Word content in Excel, one paragraph by one

Ok, I had to deal with a Word document consisting in normal paragraphs and tables, and I wanted it on Excel.

But tables have several columns while paragraph is just monocolumn, so I needed to get them separated but with some order.

Here is the initial macro to separate contents:

Option Explicit

Sub WordImport()
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    Dim wdParag As Word.Paragraph
    Dim wdTable As Word.Table
    Dim wdRow As Word.Row
    Dim wdColumn As Word.Column
    Dim aWidth() As Single
    Dim oWsh As Excel.Worksheet
    Dim wdRng As Word.Range
    Dim wdRngTable As Word.Range
    
    Set wdApp = GetObject(, "Word.Application")
    'Set wApp = CreateObject("Word.Application")
    Set wdDoc = wdApp.ActiveDocument
    'Set wDoc = wApp.Documents.Open("C:\File.docx", ReadOnly:=True)

    Dim lgR As Long: lgR = 0
    Set oWsh = ActiveSheet
    With wdDoc
        
        Set wdRng = .Paragraphs(1).Range
        Do While wdRng.Paragraphs(1).Range.End <> .Range.End
            If Not wdRng.Information(wdWithInTable) Then
                'MsgBox wdRng.Text
                wdRng.Collapse wdCollapseEnd
                wdRng.MoveEnd wdParagraph, 1 'move one paragraph in text
                'Call sParagraphPaste(wdParag, oWsh, lgR)
            Else
            ' We have reached a table...
                Set wdRngTable = wdRng.Tables(1).Range
                
                'For Each wdColumn In wdRng.Tables(1).Columns
                '    Merge columns until oCell.Width >= wdColumn.Width
                'Next wdColumn
                
                ' Move to external procedure...
                Set oWsh = ThisWorkbook.Worksheets.Add
                Call sTablePaste(wdRngTable, oWsh, lgR)
                
                wdRngTable.Collapse wdCollapseEnd ' so initial and end points are equal
                wdRngTable.MoveEnd wdParagraph, 1
                Set wdRng = wdRngTable.Paragraphs(1).Range
            End If
        Loop 'Until wdRng.End = .Range.End
        
        'Check the last paragraph
        If Not wdRng.Information(wdWithInTable) Then
            'MsgBox wdRng.Text
        End If
        
    End With

    'wDoc.Close
    'wApp.Quit
End Sub

Private Sub sTablePaste(ByVal wdRngTable As Word.Range, _
                        ByVal oWsh As Excel.Worksheet, _
                        ByRef lgR As Long)
    
    'For Each wdTable In .Tables
    'Next wdTable
    
    'For Each wdParag In .Paragraphs
        'If wdParag.Range.Words.Count > 1 Then
            wdRngTable.Copy
            With oWsh
                .Range("A1").Offset(lgR, 0).Activate
                .Paste
                lgR = lgR + lgR
            End With
        'End If
    'Next wdParag
End Sub

Private Sub sParagraphPaste(ByVal wdParag As Word.Paragraph, _
                            ByVal oWsh As Excel.Worksheet, _
                            ByRef lgR As Long)
    'For Each wdParag In .Paragraphs
        'If wdParag.Range.Words.Count > 1 Then
            wdParag.Range.Copy
            With oWsh
                .Range("A1").Offset(lgR, 0).Activate
                .Paste
                lgR = lgR + lgR
            End With
        'End If
    'Next wdParag
End Sub

And there is something more coming here, as we need to autofit rows to content, and they may be merged, so new problem.

A little piece of code to solve it (from www.thesmallman.com, and contextures blog). The Small Man explores some handy alternatives to this topic in the workbook on that post.

Sub MergedAreaRowAutofit()
    Dim j As Long
    Dim n As Long
    Dim i As Long
    Dim MW As Double 'merge width
    Dim RH As Double 'row height
    Dim MaxRH As Double
    Dim rngMArea As Range
    Dim rng As Range
    
    Const SpareCol As Long = 26
    Set rng = Range("C10:O" & Range("C" & Rows.Count).End(xlUp).Row)
    
    With rng
        For j = 1 To .Rows.Count
            'if the row is not hidden
            If Not .Parent.Rows(.Cells(j, 1).Row).Hidden Then
                'if the cells have data
                If Application.WorksheetFunction.CountA(.Rows(j)) Then
                    MaxRH = 0
                    For n = .Columns.Count To 1 Step -1
                        If Len(.Cells(j, n).Value) Then
                            'mergecells
                            If .Cells(j, n).MergeCells Then
                                Set rngMArea = .Cells(j, n).MergeArea
                                With rngMArea
                                    MW = 0
                                    If .WrapText Then
                                        'get the total width
                                        For i = 1 To .Cells.Count
                                            MW = MW + .Columns(i).ColumnWidth
                                        Next
                                        MW = MW + .Cells.Count * 0.66
                                        'use the spare column
                                        'and put the value,
                                        'make autofit,
                                        'get the row height
                                        With .Parent.Cells(.Row, SpareCol)
                                            .Value = rngMArea.Value
                                            .ColumnWidth = MW
                                            .WrapText = True
                                            .EntireRow.AutoFit
                                            RH = .RowHeight
                                            MaxRH = Application.Max(RH, MaxRH)
                                            .Value = vbNullString
                                            .WrapText = False
                                            .ColumnWidth = 8.43
                                        End With
                                        .RowHeight = MaxRH
                                    End If
                                End With
                            ElseIf .Cells(j, n).WrapText Then
                                RH = .Cells(j, n).RowHeight
                                .Cells(j, n).EntireRow.AutoFit
                                If .Cells(j, n).RowHeight < RH Then .Cells(j, n).RowHeight = RH
                            End If
                        End If
                    Next
                End If
            End If
        Next
        .Parent.Parent.Worksheets(.Parent.Name).UsedRange
    End With
End Sub

Hope you enjoy it

Subscripts: ₀₁₂₃₄₅₆₇₈₉₊₋₌₍₎
Superscripts: ⁰¹²³⁴⁵⁶⁷⁸⁹⁺⁻⁼⁽⁾

Sub TestScriptness()
    Dim wdDoc As Word.Document
    Dim aWords As Word.Words
    Dim myRange As Word.Range
    Dim myNext As Word.Range

    Set wdDoc = ThisDocument 'ActiveDocument
    
    For Each myRange In ThisDocument.Words
        If myRange.Text Like "*[a-z,A-Z]#[0-9,a-z,A-Z]*" Then
            Set myNext = myRange.Next(Unit:=wdWord, Count:=1)
Stop
            Call FormatScript(myRange, myNext)
        End If
Exit For
        myNext.Select
        Stop
        myNext = myRange
    Next myRange
End Sub

Public Sub FormatScript(ByVal mySource As Word.Range, _
                        ByRef myDestination As Word.Range)
    Dim myChr As Word.Range
    Dim myChrDest As Word.Range
    Dim lgChr As Long
    'Do
        lgChr = 0
        For Each myChr In mySource.Characters
            lgChr = lgChr + 1
            With myChr
                If lgChr <= myDestination.Characters.Count Then
                    Set myChrDest = myDestination.Characters(lgChr)
                End If
                If .Font.Superscript = True Then
                    ' for LaTeX:
                    '.Font.Superscript = False: .InsertBefore "^"
                    myChrDest.Font.Superscript = True
                End If
                
                If .Font.Subscript = True Then
                    ' for LaTeX:
                    '.Font.Subscript = False: .InsertBefore "_"
                    myChrDest.Font.Subscript = True
                End If
            End With
        Next
        'Set myRange = myRange.NextStoryRange
    'Loop Until myRange Is Nothing
End Sub

Number of pages of Excel worksheet

There are a handful of functions on the Excel core, but none of them can retrieve the number of pages a worksheet has. It could be done with old versions via the  Excel 4.0 macros (XLM) GET functionality (but for me, no more).

You can also solve this via VBA macro, which will not be my preferred option since UDT functions have a poor performance in Excel (in this case, specially terrible performance, everything that has to deal with PrintArea is extremelly slow).

Here are some links to do the task recalling to Excel Macro 4.0:

But I couldn’t make them to work and finally gave up, so I needed a macro, tunned convenientely to show number of pages, total in vertical or total in horizontal:

Public Function fPages(ByVal Target As Excel.Range, _
                       Optional ByVal bVertical As Boolean = True, _
                       Optional ByVal bHorizontal As Boolean = True) As Long
    Dim oWsh As Excel.Worksheet
    Dim lgHpBreaks As Long
    Dim lgVBreaks As Long
    
    Set oWsh = Target.Parent
    With oWsh
        '.DytisplayAutomaticPageBreaks = False
        '.UsedRange.EntireRow.Hidden = True
        '.UsedRange.EntireColumn.Hidden = True
        '.Range(.PageSetup.PrintArea).EntireRow.Hidden = False
        '.Range(.PageSetup.PrintArea).EntireColumn.Hidden = False
        lgHpBreaks = .HPageBreaks.Count + 1
        lgVBreaks = .VPageBreaks.Count + 1
        '.UsedRange.EntireRow.Hidden = False
        '.UsedRange.EntireColumn.Hidden = False
    End With
    
    fPages = IIf(bVertical, lgVBreaks, 1) * IIf(bVertical, lgHpBreaks, 1)  
End Function

But this function do not autorecalculates… so you better use combined with a function that it does (the Now() function will perform good).

If you use it in the worksheet, go for:

=fPages(A1,True,True)+(NOW()*0)

WordPress plugins

I’m getting myself in this world of WP, and starting to look at plugins. There are thousands of them for WP, so I can barely know which one to use.

It’s a good idea to rely on someone that can guide you here.

I got my leaders, aside from my own work digging in the plugin search engine, this post was very profuse.

You must note that the use of plugins has its own handicaps, very well exposed here. For the best perfomance, and to avoid the “too much query noise” associated with the plugins, it’s highly recomended to use a Cache plugin. To test the perfomance, go here.

Finally, would you like how to create a plugin, then read this one.

An spanish blog with a good course on WP, and appifier plugins page.

If at any time you want to migrate to other hoster, the best option you can take is the Duplicator plugin, that will do the job quite simple and straight forward. Look at this youtube video.

Can VMware has “own” mouse and keyboard?

This is the first point to start.

 VMWare tech support tells to add the following line to the Workstation VMX file:

vmmouse.present = "FALSE"

It seems that the VMware bios doesn`t have support for USB keyboards – the keyboard isn`t useable on early boot. maybe you can add support for HID keyboard in the VMware bios?

some information on that:

http://www.microsoft.com/whdc/archive/Lf.mspx

http://www.microsoft.com/whdc/device/input/w2kbd.mspx#EQB