Translate

Sorry if code looks a little mess… the WordPress editor doesn’t like too much RegEx expressions, so you have to paste the RegEx at the end of this post. I attach the macros that I composed to translate using the services of “Google translator”, “Bing translator”, “Linguee”. I have not spent much time exploring the available languages, just point that the GoogleLanguageIds function already can handle most common languages and that the Bing translator provides the Klingon language. The implementation of Linguee is interesting as points to external reference texts, and although it does not give out a very clean result (probably should worked the MsgBox to show the HTML code formatted within the component, but I have not wanted to spend much more time); it is useful for reference. I’ve explored several ways to achieve the translation using the avaliable services. My final objective was to translate a DOC file keeping all the formatting and styling in place. That part is not shown here, although code is the final working version, just ripping the Word procedures off (that part drove me nuts, and is part of a future add-in development).
Option Explicit

' The program requires references to the following:
'1. Microsoft Internet Controls (SHDocVw)(ieFrame.dll)
'2. Microsoft HTML Object Library
'3. Microsoft Shell Controls And Automation

Private oIE As Object    'SHDocVw.InternetExplorer
Private oIETmp As Object 'SHDocVw.InternetExplorer
Private hDoc As MSHTML.HTMLDocument     'Object: to refer to the HTML document returned
Private strURL As String
Private hElement As MSHTML.IHTMLElement
Private hCollection As MSHTML.IHTMLElementCollection
Private hNode As MSHTML.IHTMLDOMNode
Private hDOMDoc As MSHTML.IHTMLDOMNode2

' For UTF-8 URL Encoding
Private Const CP_UTF8 = 65001
Private Declare Function WideCharToMultiByte Lib "Kernel32" (ByVal CodePage As Long, ByVal dwflags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
' -----------------------------

Private Const strSHORTCODES As String = ",af,sq,ar,hy,az,eu,be,bn,bg,ca,zh-CN,hr,cs,da,nl,en,eo,et,tl,fi,fr,gl,ka,de,el,gu,ht,iw,hi,hu,is,id,ga,it,ja,kn,ko,lo,la,lv,lt,mk,ms,mt,no,fa,pl,pt-PT,ro,ru,sr,sk,sl,es,sw,sv,ta,te,th,tr,uk,ur,vi,cy,yi"
Private Enum eLanguageId
    auto_detect = 0
    Afrikaans = 1
    Albanian = 2
    Arabic = 3
    Armenian = 4
    Azerbaijani = 5
    Basque = 6
    Belarusian = 7
    Bengali = 8
    Bulgarian = 9
    Catalan = 10
    Chinese = 11
    Croatian = 12
    Czech = 13
    Danish = 14
    Dutch = 15
    English = 16
    Esperanto = 17
    Estonian = 18
    Filipino = 19
    Finnish = 20
    French = 21
    Galician = 22
    Georgian = 23
    German = 24
    Greek = 25
    Gujarati = 26
    Haitian_Creole = 27
    Hebrew = 28
    Hindi = 29
    Hungarian = 30
    Icelandic = 31
    Indonesian = 32
    Irish = 33
    Italian = 34
    Japanese = 35
    Kannada = 36
    Korean = 37
    Lao = 38
    Latin = 39
    Latvian = 40
    Lithuanian = 41
    Macedonian = 42
    Malay = 43
    Maltese = 44
    Norwegian = 45
    Persian = 46
    Polish = 47
    Portuguese = 48
    Romanian = 49
    Russian = 50
    Serbian = 51
    Slovak = 52
    Slovenian = 53
    Spanish = 54
    Swahili = 55
    Swedish = 56
    Tamil = 57
    Telugu = 58
    Thai = 59
    Turkish = 60
    Ukrainian = 61
    Urdu = 62
    Vietnamese = 63
    Welsh = 64
    Yiddish = 65
End Enum

Public Sub sDoc_Translate()
' we should try http://www.statmt.org/moses/index.php?n=Main.HomePage
    Dim TransServer As String:  TransServer = "google"
    Dim LngFrom As String:  LngFrom = "spanish"
    Dim LngTo As String:    LngTo = "english"
    Dim strTextFrom As String
    
    If oIE Is Nothing Then fIE_Initialize
    
    msgbox getTranslation(strTextFrom, LngFrom, LngTo, TransServer)
        
    oIE.Visible = True

    Call fIE_Terminate
End Sub

'Public Sub sExcel_Translate()
'' Translate. Keep format...
'    Dim rgSelection As Excel.Range
'    Dim oCell As Excel.Range
'    Dim lgWord As Long
'    Dim lgWords As Long: lgWords = 0
'    Dim aWord() As String
'    Dim strTextFrom As String
'    Dim strTextTo As String
'
'    If Not loadExplorer(oIE) Then Exit Sub
'    If Not loadExplorer(oIETmp) Then Exit Sub
'
'    Set rgSelection = Selection
'    For Each oCell In rgSelection.Cells
'        If Not IsEmpty(oCell.Value2) Then
'        If Not IsNumeric(oCell.Value2) Then
'            strTextFrom = VBA.Trim$(oCell.Text)
'            strTextFrom = VBA.Replace$(strTextFrom, "  ", " ")
'            aWord() = VBA.Split(strTextFrom, " ")
'            If lgWords + UBound(aWord) - LBound(aWord) + 1 > 5000 Then
'                ' Delete contents
'                oCell.Value2 = vbNullString
'
'                ' Translate blocks (bunch of 5000 words)
'                Do
'                    strTextFrom = vbNullString
'                    For lgWord = LBound(aWord) To 4999
'                        strTextFrom = strTextFrom & " " & aWord(lgWord)
'                    Next lgWord
'                    oCell.Value2 = oCell.Value2 & getTranslation(strTextFrom, LngFrom, LngTo, TransServer)
'
'                    strTextFrom = vbNullString
'                    For lgWord = 5000 To UBound(aWord)
'                        strTextFrom = strTextFrom & " " & aWord(lgWord)
'                    Next lgWord
'                    aWord() = VBA.Split(strTextFrom, " ")
'                    lgWords = lgWords + UBound(aWord) - LBound(aWord) + 1 - 5000
'                Loop While lgWords > 5000
'                oCell.Value2 = oCell.Value2 & getTranslation(strTextFrom, LngFrom, LngTo, TransServer)
'            Else
'                oCell.Value2 = getTranslation(strTextFrom, LngFrom, LngTo, TransServer)
'            End If
'        End If
'        End If
'    Next oCell
'
'    Call closeExplorer(oIE)
'    Call closeExplorer(oIETmp)
'End Sub
'
'Private Sub sTranslate()
'' Select translation service: "google", "bing", "linguee"
'    Dim strService As String
'    Dim lgRetVal As Long
'
'    strService = VBA.InputBox("Select translation service: [google, bing, linguee]", "Service", "google")
'    lgRetVal = MsgBox(getTranslation("Lion", "english", "spanish", strService), vbInformation + vbOKOnly)
'End Sub
'
'Private Function loadExplorer(ByRef oIE As Object) As Boolean
'    On Error GoTo ErrControl
'
'    If oIE Is Nothing Then
'        Set oIE = CreateObject("InternetExplorer.Application")
'    End If
'    loadExplorer = True
'
'ExitProc:
'    On Error GoTo 0
'    Exit Function
'
'ErrControl:
'    GoTo ExitProc
'End Function
'
'Private Function closeExplorer(ByRef oIE As Object) As Boolean
'    On Error GoTo ErrControl
'
'    oIE.Quit
'    Set oIE = Nothing
'
'    closeExplorer = True
'
'ExitProc:
'    On Error GoTo 0
'    Exit Function
'
'ErrControl:
'    GoTo ExitProc
'End Function

Private Function getWordTranslated(ByVal strSourceString As String, _
                                   ByVal strInputLang As String, _
                                   ByVal strOutputLang As String, _
                                   Optional ByVal strService As String = "Google") As String
    Dim strTranslation As String
    
    Do
        strTranslation = getTranslation(VBA.Trim$(strSourceString), strInputLang, strOutputLang, strService)
    Loop While VBA.Right$(strTranslation, 3) = "..."
    
    getWordTranslated = strTranslation
End Function

Private Sub sTranslate()
    Dim strSourceString As String: strSourceString = "Aquí una prueba de esto/ que es una prueba"
    Dim strInputLang As String: strInputLang = "spanish"
    Dim strOutputLang As String: strOutputLang = "english"
    Dim strService As String: strService = "bing"

    MsgBox getTranslation(strSourceString, strInputLang, strOutputLang, strService)
End Sub
Following is the main translator procedure:
Private Function getTranslation(ByVal strSourceString As String, _
                                ByVal strInputLang As String, _
                                ByVal strOutputLang As String, _
                                Optional ByVal strService As String = "Google") As String
    Dim strURL As String
    Dim strRes As String

    Dim strInputLangId As String
    Dim strOutputLangId As String
    Dim strTranslationElementID As String
    Dim strTempOutput As String
    Dim strHTML As String
    Dim aCleaData() As String
    Dim lngLoop As Long
    Dim bQuitExplorer As Boolean
    Dim bComplete As Boolean

    If strSourceString = "" Then Exit Function
    
    'INPUT LANGUAGE
    strInputLang = VBA.LCase$(strInputLang)
    If strInputLang = "" Then
        strInputLangId = "auto"
    Else
        strInputLangId = GoogleLanguageIds(strInputLang)
    End If

    'OUTPUT LANGUAGE
    strOutputLang = VBA.LCase$(strOutputLang)
    strOutputLangId = GoogleLanguageIds(strOutputLang)

    If strInputLang <> vbNullString And strOutputLang <> vbNullString Then
        If oIE Is Nothing Then fIE_Initialize
        
        'open Explorer instance
        'oIE.Visible = False

        strService = VBA.Trim$(VBA.LCase$(strService))

        If strService = vbNullString Then strService = "google"

        If strService = "google" Then
            
            strURL = "https://translate.google.com/#view=home" & _
                     "&op=translate" & _
                     "&sl=" & strInputLangId & _
                     "&tl=" & strOutputLangId & _
                     "&text=" & URLEncode(strSourceString)
            
            'strURL = "http://translate.google.com/translate_a/t?client=t" & _
                     "&text=" & URLEncode(strSourceString) & _
                     "&hl=en" & _
                     "&sl=" & strInputLangId & _
                     "&tl=" & strOutputLangId & _
                     "&multires=1" & _
                     "&pc=0" & _
                     "&rom=1" & _
                     "&sc=1"
            
            'strURL = "https://translate.google.com/#" & _
                     strInputLangId & "/" & _
                     strOutputLangId & "/" & _
                     strSourceString
            
            strTranslationElementID = "tlid-translation translation"

        ElseIf strService = "bing" Then
            strURL = "http://www.bing.com/translator/?text=" & _
                     URLEncode(strSourceString, True) & _
                     "&from=" & strInputLangId & "/" & _
                     "&to=" & strOutputLangId
            strTranslationElementID = "t_txtoutblk"

        ElseIf strService = "linguee" Then
            strURL = "https://www.linguee.com/" & _
                     strInputLang & "-" & _
                     strOutputLang & _
                     "/search?source=auto" & _
                     "&query=" & URLEncode(strSourceString, True)

            'strURL = "https://www.linguee.es/" & _
                     getTranslation(strInputLang, "en", "es") & "-" & _
                     getTranslation(strOutputLang, "en", "es") & _
                     "/traduccion/" & _
                     URLEncode(strSourceString, True) & ".html"

            strTranslationElementID = "lingueecontent"
        End If

        'open website
        If fIE_Load(strURL, False) Then
            Call fIE_Document

            Do Until oIE.readyState = 4
                DoEvents
            Loop
    
            Do Until oIE.readyState = 4
                DoEvents
            Loop
    
            'Get return HTML code
            oIE.Visible = True
            
            ' get translated node item
            If strService = "google" Then
                bComplete = False
                Do
                    Set hCollection = hDoc.getElementsByClassName(strTranslationElementID)
                    If hCollection.Length = 1 Then
                        bComplete = True
                        For Each hElement In hCollection
                            strTempOutput = hElement.innerText
                        Next hElement
                    End If
                    If (VBA.Trim$(strTempOutput) = vbNullString And VBA.Trim$(strSourceString) <> vbNullString) Then
                        WordWait 5 'although is readyState = COMPLETE the oIE could be still working to get the DOM structure...
                    Else
                        bComplete = True
                    End If
                    If VBA.Right$(strTempOutput, 3) = "..." Then bComplete = False
                Loop Until bComplete
                getTranslation = strTempOutput
            Else
                getTranslation = oIE.Document.getElementById(strTranslationElementID).innerText
            End If
        End If

        'If bQuitExplorer Then
        '    oIE.Quit
        '    Set oIE = Nothing
        'End If
    Else
        getTranslation = vbNullString
    End If

End Function

For the Google service we need a procedure to select languages:
Private Function GoogleLanguageIds(ByVal strLang As String) As String
    Dim strLangIds As String
    Dim arrLangIds() As String
    Dim strId As String
    Dim intLoop As Integer

    GoogleLanguageIds = VBA.Switch(strLang = "chinese", "zh-CN", _
                                   strLang = "danish", "da", _
                                   strLang = "dutch", "nl", _
                                   strLang = "english", "en", _
                                   strLang = "french", "fr", _
                                   strLang = "german", "de", _
                                   strLang = "greek", "el", _
                                   strLang = "italian", "it", _
                                   strLang = "japanese", "ja", _
                                   strLang = "norwegian", "no", _
                                   strLang = "polish", "pl", _
                                   strLang = "portuguese", "pt", _
                                   strLang = "romanian", "ro", _
                                   strLang = "russian", "ru", _
                                   strLang = "spanish", "es", _
                                   strLang = "swedish", "sv", _
                                   strLang = "Turkish", "tr", _
                                   strLang = "ukrainian", "uk")
    
    'Dim LanguageId As eLanguageId
    'GoogleLanguageIds = VBA.Split(strSHORTCODES, ",")(LanguageId)
End Function

Instead of using the Internet Explorer object, we could have chosen the XMLHTTP object, much faster, but completely hidden from user. And one point I didn’t like, it is usually recognised as a robot, and banned; so I prefer keeping the IE way, the XMLHTTP is just for reference (and, if you are for using with an API key, this should be the way to go):
Private Function ServerXMLHTTPTranslate(ByVal strSourceString As String, _
                                        ByVal strInputLang As String, _
                                        ByVal strOutputLang As String, _
                                        Optional ByVal strService As String = "Google") As String
    Dim strURL As String
    Dim trans As String
    Dim oHTTP As Object
    Dim strInputLangId As String
    Dim strOutputLangId As String
    
    Set oHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    strURL = "https://translate.google.com/m?" & _
             "hl=" & strInputLangId & _
             "&sl=" & strInputLangId & _
             "&tl=" & strOutputLangId & _
             "&ie=UTF-8" & _
             "&prev=_m" & _
             "&q=" & URLEncode(strSourceString)
    With oHTTP
        .Open "GET", strURL, False
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .send ("")
        If InStr(.responseText, "div dir=""ltr""") > 0 Then
            trans = ... here put the code mentioned outside this block of code (mess of the WordPress Plugin with RegEx expressions
            MsgBox UnEncodeURL(trans)
        Else
            MsgBox ("Error")
        End If
    End With
End Function

Private Function GoogleTranslateAPI(ByVal text As String, _
                                    ByVal srcLang As String, _
                                    ByVal resLang As String) As String
' Needs an API key
    Dim jsonProvider As Object
    Dim jsonResult As Object
    Dim jsonResultText As String
    Dim googleApiUrl As String
    Dim googleApiKey As String
    Dim resultText As String
    
    Set jsonProvider = CreateObject("MSXML2.ServerXMLHTTP")
    
    text = URLEncode(text)
'!!!!!!!!!!!!!!!!!
Stop
'https://cloud.google.com/translate/pricing?hl=en
'https://cloud.google.com/products/calculator/
'If you get a 403 error, add payment method
    googleApiKey = "..." ' GOOGLE API KEY
'!!!!!!!!!!!!!!!!!
    
    googleApiUrl = "https://translation.googleapis.com/language/translate/v2?key=" & googleApiKey & "&source=" & srcLang & "&target=" & resLang & "&q=" & text
    
    jsonProvider.Open "POST", googleApiUrl, False
    jsonProvider.setRequestHeader "Content-type", "application/text"
    jsonProvider.send ("")
    jsonResultText = jsonProvider.responseText
    
    'Set jsonResult = jsonProvider.ParseJson(jsonResultText)
    'Set jsonResult = jsonResult("data")
    'Set jsonResult = jsonResult("translations")
    'Set jsonResult = jsonResult(1)
    
    'resultText = jsonResult("translatedText")
    
    GoogleTranslateAPI = resultText
End Function
To deal with the Internet Explorer object, we can rely on these procedures:
Private Function fIE_Initialize(Optional ByRef bIEMedium As Boolean = False) As Boolean
    'open Internet Explorer in memory, and go to website
    'Dim oIE As New InternetExplorer
    'If oIE Is Nothing Then
    If bIEMedium Then
        'Set oIE = New InternetExplorerMedium
        Set oIE = CreateObject("new:{D5E8041D-920F-45e9-B8FB-B1DEB82C6E5E}") 'Internet Explorer Medium
        Set oIE = GetObject("new:{D5E8041D-920F-45e9-B8FB-B1DEB82C6E5E}") 'Internet Explorer Medium
    Else
        Set oIE = CreateObject("InternetExplorer.Application")
        'Set oIE = New InternetExplorer
    End If
    'End If
    oIE.Visible = True
    
    fIE_Initialize = Not (oIE Is Nothing)
End Function

Private Function fIE_Load(Optional ByVal strURL As String = vbNullString, _
                          Optional ByVal bMedium As Boolean = False) As Boolean
    Dim Timer As Date
    
    If strURL = vbNullString Then
        strURL = VBA.InputBox("URL:", , "https://...")
    End If
    
    'Wait until IE is done loading page
    Err.Clear
    'On Error Resume Next
    oIE.navigate strURL '"http://", , , , "Content-Type: application/x-www-form-urlencoded" & vbCrLf
    Timer = VBA.Now()
    
    'On Error Resume Next
    While oIE.Busy
        Application.StatusBar = "Trying to connect..."
        DoEvents
    Wend
    
    If bMedium Then
        WordWait 5
    Else
        Do While oIE.readyState <> READYSTATE_COMPLETE
            'Application.StatusBar = "Trying to connect..."
            DoEvents
            'If (VBA.Now() - Timer) > 10000 Then 'Stop: End
        Loop
    End If
    If Err.Number = 462 Then
        If strURL Like "file:///*" Then
            fIE_Load = True
        Else
            ''Stop: End
            fIE_Load = False
        End If
    Else
        fIE_Load = True
    End If
    Err.Clear
    On Error GoTo 0
    
    Application.StatusBar = ""
End Function
    
Private Function fIE_Document() As Boolean
    'show text of HTML document returned
    Set hDoc = oIE.Document
    
    'save to file: hDoc.DocumentElement.innerHTML

    ' Also: ------------------------
    ''Create HTMLFile Object
    'Set hDoc = CreateObject("htmlfile")
    '
    ''Get the WebPage Content to HTMLFile Object
    'With CreateObject("msxml2.xmlhttp")
    '    .Open "GET", strURL, False
    '    .send
    '    '??? hDoc.body.innerHTML = .responseText
    'End With
    ' ------------------------------

End Function

Private Function fIE_Terminate() As Boolean 'ByVal oIE As InternetExplorer) 'Object

    Set hDoc = Nothing

    'close down IE and reset status bar
    ' oIE.Refresh ' Refresh if needed
    Set oIE = Nothing
    
    Application.StatusBar = ""

Err_Clear:
    If Err <> 0 Then
        Debug.Assert Err = 0
        Err.Clear
        'Resume Next
    End If
End Function

And we need some code to parse the text string to translate to the URL string, so we can feed the translator box:
Public Function UTF16To8(ByVal UTF16 As String) As String
    Dim sBuffer As String
    Dim lLength As Long
    
    If UTF16 <> "" Then
        lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, 0, 0, 0, 0)
        sBuffer = Space$(lLength)
        lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, StrPtr(sBuffer), Len(sBuffer), 0, 0)
        sBuffer = StrConv(sBuffer, vbUnicode)
        UTF16To8 = Left$(sBuffer, lLength - 1)
    Else
        UTF16To8 = ""
    End If
End Function

Public Function URLEncode(ByVal strTextSource As String, _
                          Optional ByVal SpaceAsPlus As Boolean = False, _
                          Optional ByVal UTF8Encode As Boolean = True) As String

    Dim StringValCopy As String: StringValCopy = IIf(UTF8Encode, UTF16To8(strTextSource), strTextSource)
    Dim StringLen As Long:       StringLen = VBA.Len(StringValCopy)
    Dim Result() As String
    
    If StringLen > 0 Then
        ReDim Result(1 To StringLen)
        Dim lgChr As Long
        Dim CharCode As Integer
        Dim Char As String
        Dim Space As String
        
        If SpaceAsPlus Then Space = "+" Else Space = "%20"
        
        For lgChr = 1 To StringLen
            Char = Mid$(StringValCopy, lgChr, 1)
            CharCode = Asc(Char)
            Select Case CharCode
                Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
                    Result(lgChr) = Char
                Case 32
                    Result(lgChr) = Space
                Case 0 To 15
                    Result(lgChr) = "%0" & Hex(CharCode)
                Case Else
                    Result(lgChr) = "%" & Hex(CharCode)
            End Select
        Next lgChr
        URLEncode = Join(Result, "")
    End If

    ' It can also be achieved via JavaScript:
        'Dim ScriptEngine As ScriptControl: Set ScriptEngine = New ScriptControl
        'Dim ScriptEngine As Object: Set ScriptEngine = CreateObject("ScriptControl")
        'ScriptEngine.Language = "JScript"
        'ScriptEngine.AddCode "function encode(f) {return encodeURIComponent(f);}"
        'URLEncode = ScriptEngine.Run("encode", strTextSource)
        'Set ScriptEngine = Nothing

End Function

Public Function UnEncodeURL(ByVal URLEncoded As String) As String
' revert urlencoded characters to regular texts
    Dim ibyte As Integer
    Dim txt As String
    Dim hexChr As String

    txt = URLEncoded
    
    ' replace '+' with space
    txt = Replace(txt, "+", " ")
    
    For ibyte = 1 To 255
        Select Case ibyte
            Case 1 To 15: hexChr = "%0" & Hex(ibyte)
            Case 37: ' skip '%' character
            Case Else: hexChr = "%" & VBA.Hex(ibyte)
        End Select
        
        txt = VBA.Replace(txt, VBA.UCase$(hexChr), VBA.Chr(ibyte))
        txt = VBA.Replace(txt, VBA.LCase$(hexChr), VBA.Chr(ibyte))
    Next ibyte
    
    'replace '%' character
    txt = VBA.Replace(txt, "%25", "%")
    txt = VBA.Replace(txt, """, """")
    txt = VBA.Replace(txt, "%2C", ",")
    txt = VBA.Replace(txt, "'", "'")
    UnEncodeURL = txt
End Function

'Private Function xURLEncode(ByVal StringVal As String, _
'                           Optional ByVal SpaceAsPlus As Boolean = False) As String
''!!!!!!!!!!!!!!!!!
'' Not valid for UTF-8
''!!!!!!!!!!!!!!!!!
'    Dim StringLen As Long
'    StringLen = VBA.Len(StringVal)
'
'    Dim Result() As String
'    Dim I As Long
'    Dim CharCode As Integer
'    Dim Char As String
'    Dim Space As String
'
'    If StringLen > 0 Then
'        ReDim Result(StringLen)
'
'        If SpaceAsPlus Then Space = "+" Else Space = "%20"
'
'        For I = 1 To StringLen
'            Char = Mid$(StringVal, I, 1)
'            CharCode = Asc(Char)
'            Select Case CharCode
'                Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
'                    Result(I) = Char
'                Case 32
'                    Result(I) = Space
'                Case 0 To 15
'                    Result(I) = "%0" & Hex(CharCode)
'                Case Else
'                    Result(I) = "%" & Hex(CharCode)
'            End Select
'        Next I
'        xURLEncode = Join(Result, "")
'    End If
'End Function

Public Function RegexExecute(str As String, reg As String, _
                             Optional matchIndex As Long, _
                             Optional subMatchIndex As Long) As String
    On Error GoTo ErrHandl
    Dim regex As Object
    Dim matches As Object
    
    Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = reg
    regex.Global = Not (matchIndex = 0 And subMatchIndex = 0) 'For efficiency
    If regex.Test(str) Then
        Set matches = regex.Execute(str)
        RegexExecute = matches(matchIndex).SubMatches(subMatchIndex)
        Exit Function
    End If

ErrHandl:
'    RegexExecute = CVErr(xlErrValue)
End Function
If you want to use Google or Microsoft API, here some links:
  • API microsoft: https://sysmod.wordpress.com/2012/01/09/microsoft-translator-vba-code-sample/ ((c) Patrick O’Beirne (@ExcelAnalytics))
  • API Google: https://stackoverflow.com/a/43273425 (requieres module JSonConverter VBA-JSON v2.2.3 (c) Tim Hall – https://github.com/VBA-tools/VBA-JSON
Following a list with the 104 languages supported by Google translator service (in spanish), taken from here.
LANGUAGE SHORT
afrikaans af
albanés sq
alemán de
amárico am
árabe ar
armenio hy
azerí az
bengalí bn
bielorruso be
birmano my
bosnio bs
búlgaro bg
camboyano (o jemer) km
canarés kn
catalán ca
cebuano ce
checo cs
chichewa ny
chino zh
chino tradicional zh
cingalés si
coreano ko
corso co
criollo haitiano ht
croata hr
danés da
eslovaco sk
esloveno sl
español (o castellano) es
esperanto eo
estonio et
euskera eu
finés (o finlandés) fi
francés fr
frisón (o frisio) fy
gaélico escocés gd
galés cy
gallego gl
georgiano ka
griego (moderno) el
guyaratí (o guyaratí) gu
hausa ha
hawuaiano ha
hebreo he
hindi (o hindú) hi
hmong hm
holandes nl
húngaro hu
igbo ig
indonesio id
inglés en
irlandés (o gaélico) ga
islandés is
italiano it
japonés ja
javanés jv
kazajo (o kazajio) kk
kirguís ky
kurdo ku
lao lo
latín la
letón lv
lituano lt
luxemburgués lb
macedonio mk
malayalam ml
malayo ms
malgache (o malagasy) mg
maltés mt
maorí mi
maratí mr
mongol mn
nepalí ne
noruego no
panyabí (o penyabi) pa
pastú (o pashto) ps
persa fa
polaco pl
portugués pt
rumano ro
ruso ru
samoano sm
serbio sr
sesotho st
shona sn
sindhi sd
somalí so
suajili sw
sueco sv
sundanés su
tagalo tl
tailandés th
tamil ta
tayiko tg
telugú te
turco tr
ucraniano uk
urdu ur
uzbeko uz
vietnamita vi
xhosa xh
yídish (o yiddish) yi
yoruba yo
zulú zu
Paste this code where indicated: trans = RegexExecute(.responseText, “div[^””]*?””ltr””.*?>(.+?)
“)

VBA Excel Dynamic Data filter with Dynamically created ComboBox

Yes, so redundant. It’s a dynamically created comboBox (or DropDown) OLE Object that can be modified in runtime (for example, to set a filter). It’s not fully working as expected, but kind of. As it was not behaving well, I ripped it off from my code, but consider it interestingly enough to kept it for future needings. I have achieved this functionallity via Validation method, which is not so tricky and behaves well in nearly all Excel versions out there. Inspiration came from here, here and here.
Private oShpComboBox As Excel.Shape
'Private oComboBox As Excel.Shape 'Private WithEvents oComboBox As MSForms.comboBox
Private oOLE As Excel.OLEObject
Private bEvents As Boolean
Private oCodeMod As VBIDE.CodeModule

Private Sub Worksheet_Activate()
    Call sComboBox_Delete
    Call sCombobox_Create
End Sub

Private Sub Worksheet_Deactivate()
    Call sComboBox_Delete
End Sub

Private Sub sCombobox_Create()
    Dim strCode As String
    Dim lgLine As Long

    With Me.Cells(1, 1)
        ' oShpComboBox can not handle WithEvents
        'Set oShpComboBox = Me.Shapes.AddFormControl(xlDropDown, _
                                                    Left:=.Left, _
                                                    Top:=.Top, _
                                                    Width:=.Width, _
                                                    Height:=.Height)

        Set oOLE = Me.OLEObjects.Add(ClassType:="Forms.ComboBox.1", _
                                     Link:=False, _
                                     DisplayAsIcon:=False, _
                                     Left:=.Left, _
                                     Top:=.Top, _
                                     Width:=.Width, _
                                     Height:=.Height)
    End With
    With oOLE
        .Name = "cboFilter"
        .Visible = False
    End With
    'MsgBox TypeName(oOLE)

    Set oCodeMod = ThisWorkbook.VBProject.VBComponents(Me.CodeName).CodeModule

    With oCodeMod
        lgLine = .CreateEventProc("Change", oOLE.Name) + 1
        strCode = vbNullString
        strCode = strCode & "    Dim rgName As Excel.Range" & vbNewLine _
                          & "    Dim oCell As Excel.Range" & vbNewLine _
                          & "" & vbNewLine _
                          & "    With " & oOLE.Name & ".Object" & vbNewLine _
                          & "        .BorderStyle = 0 'fmBorderStyleNone" & vbNewLine _
                          & "" & vbNewLine _
                          & "        .Font.Name = ""Calibri""" & vbNewLine _
                          & "        .Font.Size = 10" & vbNewLine _
                          & "        .Value = vbNullString" & vbNewLine _
                          & "        .List = Array() '""Item1"", ""Item2"", ""Item3"", ""Item4"")" & vbNewLine _
                          & "        Set rgName = ActiveSheet.Names(strDataBase).RefersToRange" & vbNewLine _
                          & "        For Each oCell In rgName.SpecialCells(xlCellTypeConstants).Cells" & vbNewLine _
                          & "            If oCell.Value2 Like ""*"" & " & oOLE.Name & ".value & ""*"" Then" & vbNewLine _
                          & "                .AddItem oCell.Value2" & vbNewLine _
                          & "            End If" & vbNewLine _
                          & "        Next oCell" & vbNewLine _
                          & "        '.AddItem " & """Item1""" & vbNewLine _
                          & "    End With" & vbNewLine _
                          & "" & vbNewLine _
                          & "    'MsgBox ""Name: "" & " & oOLE.Name & ".Value" & vbNewLine _
                          & "    ActiveCell.Value2 = " & oOLE.Name & ".value"
        .InsertLines lgLine, strCode

        'lgLine = .CreateEventProc("LostFocus", oOLE.Name) + 1
        'strCode = vbNullString
        'strCode = strCode & "    " & oOLE.Name & ".Visible = False"
        '.InsertLines lgLine, strCode
    End With

    Set oCodeMod = Nothing
End Sub

Private Sub DeleteProcedureCode(ByVal ProcedureName As String)
    Dim ProcStartLine As Long
    Dim ProcLineCount As Long

    On Error Resume Next

    'Creating object of workbook module
    Set oCodeMod = ThisWorkbook.VBProject.VBComponents(Me.CodeName).CodeModule

    'Checking whether the procedure exist in the codemodule
    If Not oCodeMod Is Nothing Then
        ProcStartLine = 0

        With oCodeMod
            'Function assigning the line no. of starting line for the procedure
            ProcStartLine = .ProcStartLine(ProcedureName, vbext_pk_Proc)

            If ProcStartLine > 0 Then
                'Function assign the no. of lines in the procedure
                ProcLineCount = .ProcCountLines(ProcedureName, vbext_pk_Proc)

                'Delete all the lines in the procedure
                .DeleteLines ProcStartLine, ProcLineCount
            End If
        End With
    End If

    On Error GoTo 0
End Sub

Private Sub sComboBox_Delete()
    On Error Resume Next
    Set oCodeMod = ThisWorkbook.VBProject.VBComponents(Me.CodeName).CodeModule
    Me.Shapes("cboFilter").Delete
    Call DeleteProcedureCode("cboFilter_GetFocus")
    Call DeleteProcedureCode("cboFilter_LostFocus")
    Call DeleteProcedureCode("cboFilter_Change")
    On Error GoTo 0
End Sub

This can be activated via code like the one following. Just paste it inside Worksheet_SelectionChange procedure to get it fired when activecell falls in either Columns 5 or 6:
    If Not (Intersect(Target, Me.Columns(5)) Is Nothing) Then
        If Target.Rows.Count = 1 Then
            strDataBase = ***** customize DataBase name

'bEvents = Application.EnableEvents
'Application.EnableEvents = False
'Target.value = vbNullString
'Application.EnableEvents = bEvents

            Set oOLE = Me.OLEObjects("cboFilter")
            With oOLE
                .Visible = True
                .Left = Target.Left
                .Top = Target.Top
                .Width = Target.Width
                .Height = Target.Height

                '.Border.Weight = xlHairline
                '.Border.LineStyle = xlContinuous 'xlLineStyleNone
                With .Object
                    .BorderStyle = 0 'fmBorderStyleNone

                    .Font.Name = "Calibri"
                    .Font.Size = 10
                End With
            End With
'
'            Call cboFilter_Change
        End If

    ElseIf Not (Intersect(Target, Me.Columns(6)) Is Nothing) Then
        If Target.Rows.Count = 1 Then
            strDataBase = ***** customize DataBase name

'bEvents = Application.EnableEvents
'Application.EnableEvents = False
'Target.value = vbNullString
'Application.EnableEvents = bEvents

            Set oOLE = Me.OLEObjects("cboFilter")
            With oOLE
                .Visible = True
                .Left = Target.Left
                .Top = Target.Top
                .Width = Target.Width
                .Height = Target.Height

                '.Border.Weight = xlHairline
                '.Border.LineStyle = xlContinuous 'xlLineStyleNone
                With .Object
                    .BorderStyle = 0 'fmBorderStyleNone

                    .Font.Name = "Calibri"
                    .Font.Size = 10
                End With
            End With
'
'            Call cboFilter_Change
        End If
    Else
'        Set oOLE = Me.OLEObjects("cboFilter")
'        oOLE.Visible = False
    End If
[/sourcecode]	

VBA UDT Get/Put

You have to take a look to the following posts: By the way… please, come here to dig inside this site:  http://sandsprite.com/openSource.php?id=66

XML To UDT

As stated on Wikipedia, on the entry XML (or Extensible Markup Language) is a markup language that defines a set of rules for encoding documents in a format that is both human-readable and machine-readable. The W3C‘s XML 1.0 Specification and several other related specifications—all of them free open standards—define XML. And XML schemas are everywhere in the Net. They describe a vast whole of items. From here on, we encounter the problem when developing software that complies with the specification described in the XML, so that it can interoperate data (I/O operations) with objects or XML files. But most of the time, we only have a bare XML file, no schema. It would be nice a procedure that can read an XML file (or even the schema on its own) an get it converted to user defined types. For sure we’ll need to code some functions that operate with the UDT, but getting the description into an UDT schema without minimal coding would be really neat. For this to be achieved, first we’ll need to manage an object that can deal the schema. For this task, the easiest way is doing so with MSXML (v 2.0 or above) library (Tools > References > Microsoft XML vX.x). Procedure fXML_Node_Parse showing next, will iterate through the nodes, declaring the required UDT. At the end of the code there are some other functions to detect the type of variable we are dealing with (it can fail beeing the data ambiguous, but it will get big part of the job done). Paste this code inside a module, and call sXML_Parse by any means:
Option Explicit

Private oTmpXMLDoc As MSXML2.DOMDocument
Private iFileOut As Integer
Private aSchema() As String
Private aUDT() As String

'---------------------------
Private Type tVariable
    Name As String
    TypeVar As Long
End Type
Private Type tUDT
    Header As String
    Variable() As tVariable
End Type
'---------------------------

Private Sub sXML_UDT_Clash()
    Dim lgUDT As Long
    Dim aVar() As String

    For lgUDT = LBound(aUDT) To UBound(aUDT)
        aVar() = VBA.Split(aUDT(lgUDT), vbNewLine)
    Next lgUDT
End Sub

Private Sub sXML_Parse()
    Dim strXML As String
    Dim strFullPathFile_XML As String
    Dim lgRetVal As Long
    Dim lgUDT As Long
    Dim lgUDT_Child As Long

    Dim oXMLDoc As MSXML2.DOMDocument
    Dim oXMLNode As MSXML2.IXMLDOMNode
    Dim oXMLElement As MSXML2.IXMLDOMElement
    Dim oXMLChildElement As MSXML2.IXMLDOMElement
    Dim oXMLSubChildElement As MSXML2.IXMLDOMElement

    'On Error GoTo ErrControl

    If oTmpXMLDoc Is Nothing Then
        Set oTmpXMLDoc = New MSXML2.DOMDocument
    End If

    ' Load XML
    strFullPathFile_XML = fSelectFile(VBA.Environ$("UserProfile") & "\Documents\", "*.xml")

    strXML = fFile_Load(strFullPathFile_XML)
    If strXML = vbNullString Then
        Exit Sub
    Else
        If Not oTmpXMLDoc.LoadXML(strXML) Then   'strXML is the string with XML'
            Err.Raise oTmpXMLDoc.parseError.ErrorCode, , oTmpXMLDoc.parseError.reason
        End If
        strXML = vbNullString
    End If

    If oTmpXMLDoc.ChildNodes.Length > 0 Then
        ' Sample on how to operate with a particular node:
        'Dim oXMLChildNode As MSXML2.IXMLDOMNode
        'Debug.Print oXMLNode.SelectSingleNode(oXMLChildNode.nodeName).Text
        'Debug.Print oXMLNode.SelectSingleNode("Y").Text

        '---------------------
        ' Parse XML
        '---------------------
        lgUDT = -1 'Initialize global counter
        For Each oXMLNode In oTmpXMLDoc.ChildNodes
            ' Parse XML node/child
            With oXMLNode
                If .ChildNodes.Length > 0 Then 'Avoid XML declaration (opening line)
                    lgUDT = lgUDT + 1: ReDim Preserve aSchema(lgUDT)
                    ReDim Preserve aUDT(lgUDT)
                    aSchema(lgUDT) = "Type t" & .BaseName & vbNewLine
                    aUDT(lgUDT) = .BaseName
                    For Each oXMLElement In .ChildNodes
                        aSchema(lgUDT) = aSchema(lgUDT) & vbTab & oXMLElement.BaseName & " As t" & oXMLElement.BaseName & vbNewLine
                        lgUDT_Child = UBound(aSchema) + 1
                        ReDim Preserve aSchema(0 To lgUDT_Child)
                        ReDim Preserve aUDT(0 To lgUDT_Child)
                        aSchema(lgUDT_Child) = "Type t" & oXMLElement.BaseName & vbNewLine
                        aUDT(lgUDT_Child) = oXMLElement.BaseName

                        Call fXML_Node_Parse(oXMLElement, lgUDT_Child)
                        aSchema(lgUDT_Child) = aSchema(lgUDT_Child) & "End Type"
                    Next oXMLElement
                    aSchema(lgUDT) = aSchema(lgUDT) & "End Type"
                End If
            End With
        Next oXMLNode

        '---------------------
        ' Sort blocks in order to not declare UDT after used
        '---------------------
        Dim aVar() As String
        Dim lgVar As Long
        Dim lgCheck As Long
        Dim bAdvanced As Boolean
        Dim bLoop As Boolean
        Dim strTmpUDT As String
        Dim strUDT As String
        Do
            For lgUDT = LBound(aSchema) To UBound(aSchema)
                Erase aVar()
                aVar() = VBA.Split(aSchema(lgUDT), vbNewLine)
                For lgVar = (LBound(aVar) + 1) To (UBound(aVar) - 1)
                    aVar(lgVar) = VBA.Mid$(aVar(lgVar), 2, VBA.InStr(1, aVar(lgVar), " As ") - 2)
                    aVar(lgVar) = VBA.Replace$(aVar(lgVar), "()", "")
                Next lgVar

                bAdvanced = False
                For lgVar = (LBound(aVar) + 1) To (UBound(aVar) - 1)
                    For lgCheck = lgUDT - 1 To LBound(aSchema) Step -1
                        If VBA.UCase$(aVar(lgVar)) Like VBA.UCase$(aUDT(lgCheck)) Then
                            bAdvanced = True: Exit For
                        End If
                    Next lgCheck

                    If bAdvanced Then ' Go sort element
                        ' Move clash to over UBound position
                        ReDim Preserve aSchema(LBound(aSchema) To UBound(aSchema) + 1)
                        aSchema(UBound(aSchema)) = aSchema(lgCheck)
                        aSchema(lgCheck) = vbNullString
                        ReDim Preserve aUDT(LBound(aUDT) To UBound(aUDT) + 1)
                        aUDT(UBound(aUDT)) = aUDT(lgCheck)
                        aUDT(lgCheck) = vbNullString

                        ' Move elements from clash to UBound one step back
                        For lgCheck = lgCheck To (UBound(aSchema) - 1)
                            aSchema(lgCheck) = aSchema(lgCheck + 1)
                            aUDT(lgCheck) = aUDT(lgCheck + 1)
                        Next lgCheck
                        ReDim Preserve aSchema(LBound(aSchema) To UBound(aSchema) - 1)
                        ReDim Preserve aUDT(LBound(aUDT) To UBound(aUDT) - 1)

                        Exit For
                    End If
                Next lgVar
                If bAdvanced Then lgUDT = (lgUDT - 1): Exit For
            Next lgUDT

            If lgUDT > UBound(aSchema) Then
                bLoop = bAdvanced
            Else
                bLoop = True
            End If
        Loop While bLoop

        '---------------------
        ' Flip UDT
        '---------------------
        For lgUDT = LBound(aSchema) To (UBound(aSchema) \ 2)
            strTmpUDT = aSchema(lgUDT)
            aSchema(lgUDT) = aSchema(UBound(aSchema) + LBound(aSchema) - lgUDT)
            aSchema(UBound(aSchema) + LBound(aSchema) - lgUDT) = strTmpUDT
        Next lgUDT

        For lgUDT = LBound(aSchema) To UBound(aSchema)
            Debug.Print aSchema(lgUDT)
        Next lgUDT
    End If

ExitProc:
    'Erase aSchema()

    On Error GoTo 0
    Exit Sub
ErrControl:
    lgRetVal = VBA.MsgBox("Couldn't load XML file [" & strFullPathFile_XML & "]", vbCritical, "W A R N I N G")
    GoTo ExitProc
End Sub

Private Function fXML_Node_Parse(ByVal oXMLElement As MSXML2.IXMLDOMElement, _
                                 ByVal lgUDT As Long) As Boolean
' Parse XML oXMLElement

    'On Error GoTo ErrControl

    Dim oXMLChildElement As MSXML2.IXMLDOMElement
    Dim oXMLChildNode As MSXML2.IXMLDOMNode
    Dim lgUDT_Child As Long
    Dim strDeclaration As String
    Dim lgFound As Long
    Dim bMultiple As Boolean
    Dim lgRetVal As Long

    With oXMLElement
        If .ChildNodes.Length > 0 Then
            Set oXMLChildNode = .ChildNodes.NextNode
            For Each oXMLChildElement In .ChildNodes
                With oXMLChildElement
                    If .ChildNodes.Length > 0 Then
                        Set oXMLChildNode = .ChildNodes.NextNode
                        If .ChildNodes.Length = 1 And oXMLChildNode.nodeTypeString = "text" Then
                                               'also: oXMLChildNode.childnodes.length = 0
                            Call fXML_Parse_Text(oXMLChildNode, lgUDT)

                        Else
                            'Check if recursive
                            lgFound = LBound(aSchema) - 1
                            bMultiple = fXML_Element_Found(.BaseName, lgUDT, lgFound)

                            If Not bMultiple Then
                                aSchema(lgUDT) = aSchema(lgUDT) & vbTab & .BaseName & " As t" & .BaseName & vbNewLine

                                ' Parse XML oXMLChildElement
                                lgUDT_Child = UBound(aSchema) + 1
                                ReDim Preserve aSchema(0 To lgUDT_Child)
                                ReDim Preserve aUDT(0 To lgUDT_Child)
                                aSchema(lgUDT_Child) = "Type t" & .BaseName & vbNewLine
                                aUDT(lgUDT_Child) = .BaseName
                                Call fXML_Node_Parse(oXMLChildElement, lgUDT_Child)
                                aSchema(lgUDT_Child) = aSchema(lgUDT_Child) & "End Type"

                            Else
                                If lgFound = lgUDT Then
                                    aSchema(lgUDT) = VBA.Replace(aSchema(lgUDT), _
                                                                 vbTab & .BaseName & " As t" & .BaseName & vbNewLine, _
                                                                 vbTab & .BaseName & "() As t" & .BaseName & vbNewLine)
                                Else
                                    aSchema(lgUDT) = aSchema(lgUDT) & vbTab & .BaseName & " As t" & .BaseName & vbNewLine
                                End If

                            End If
                        End If
                    End If
                End With
            Next oXMLChildElement
        End If
    End With

    fXML_Node_Parse = True

ExitProc:
    On Error GoTo 0
    Exit Function

ErrControl:
    lgRetVal = VBA.MsgBox("Couldn't load XML [" & oXMLElement.BaseName & "]", _
                          vbCritical, _
                          "W A R N I N G")
    GoTo ExitProc
End Function

Private Function fXML_Parse_Text(ByVal oXMLChildNode As MSXML2.IXMLDOMNode, _
                                 ByVal lgUDT As Long)
    Dim strDeclaration As String
    Dim lgFound As Long
    Dim bMultiple As Boolean
    Dim lgRetVal As Long

    With oXMLChildNode
        strDeclaration = VarDeclaration(.Text)
        'Check if recursive
        lgFound = LBound(aSchema) - 1
If .BaseName  "" Then Stop
        bMultiple = fXML_Element_Found(.ParentNode.BaseName, lgUDT, lgFound)
'Stop
        If Not bMultiple Then
            aSchema(lgUDT) = aSchema(lgUDT) & vbTab & .ParentNode.BaseName & " As " & strDeclaration & vbNewLine

        Else
'Stop
            If lgFound = lgUDT Then
                aSchema(lgUDT) = VBA.Replace(aSchema(lgUDT), _
                                             vbTab & .ParentNode.BaseName & " As " & strDeclaration & vbNewLine, _
                                             vbTab & .ParentNode.BaseName & "() As " & strDeclaration & vbNewLine)
            Else
                aSchema(lgUDT) = aSchema(lgUDT) & vbTab & .ParentNode.BaseName & " As " & strDeclaration & vbNewLine
            End If

        End If
    End With
End Function

Private Function fXML_Element_Found(ByVal strBaseName As String, _
                                    ByRef lgSelf As Long, _
                                    ByRef lgFound As Long) As Boolean
    fXML_Element_Found = False

    Dim lgUDT As Long
    Dim aVar() As String

    If Not (Not aUDT) Then
        aVar() = VBA.Split(aSchema(lgSelf), vbNewLine)
        For lgUDT = LBound(aVar) To UBound(aVar)
            aVar(lgUDT) = VBA.Trim$(aVar(lgUDT))
            aVar(lgUDT) = VBA.Replace$(aVar(lgUDT), vbTab, "")
            If VBA.UCase$(aVar(lgUDT)) Like VBA.UCase$(strBaseName) & " *" Then
                lgFound = lgSelf
                fXML_Element_Found = True
                Erase aVar()
                Exit Function
            End If
        Next lgUDT
    End If

    ' Search in the other declarations
    For lgUDT = (UBound(aSchema) - 1) To LBound(aSchema) Step -1
        If Not (Not aUDT) Then
            If aUDT(lgUDT) = strBaseName Then
                lgFound = lgUDT
                fXML_Element_Found = True
                Exit For
            End If
        End If
    Next lgUDT
End Function

Private Function fSelectPath() As String
    Dim strPathBase As String

    'strPathBase = VBA.Environ$("UserProfile") & "\Documents\"
    strPathBase = ActiveWorkbook.Path & "\"
    fSelectPath = strPathBase
End Function

'Private Function FolderSelection() As String
'' Shows the folder picker dialog in order the user to select folder
'    Dim lgRetVal As Long
'
'    'Show the folder picker dialog.
'    With Application.FileDialog(msoFileDialogFolderPicker)
'        .Title = "Select folder"
'        .Show
'        If .SelectedItems.Count = 0 Then
'            lgRetVal = MsgBox("You haven't selected a folder!", _
'                              vbExclamation, "Canceled")
'            Exit Function
'        Else
'            FolderSelection = .SelectedItems(1) & "\"
'        End If
'    End With
'End Function

Private Function fSelectFile(Optional ByRef strPathBase As String = vbNullString, _
                             Optional ByRef strExtension As String = "*.xml", _
                             Optional ByRef bNewFile As Boolean = False) As String
' Shows the file picker dialog in order the user to select folder

    Dim lgRetVal As Long

    'Show the folder picker dialog.
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select file"
        .Show
        .AllowMultiSelect = False
        '.Filters.Add Description:="XML files", Extensions:="*.xml"
        '.Filters.Add Description:="All files", Extensions:="*.*"

        If .SelectedItems.Count = 0 Then
            lgRetVal = MsgBox("You haven't selected a file!", _
                              vbExclamation, "Canceled")
            Exit Function
        Else
            fSelectFile = .SelectedItems(1)
        End If
    End With
End Function

Private Function fFile_Load(ByRef strFullPathFile As String) As String
    Dim strFile As String
    Dim strLine As String
    Dim iFileIn As Integer
    Dim lgItem As Long

    iFileIn = VBA.FreeFile
    Open strFullPathFile For Input Shared As #iFileIn
    Do Until EOF(iFileIn)
        Line Input #iFileIn, strLine
        strFile = strFile & strLine
    Loop
    Close #iFileIn

    fFile_Load = strFile
End Function

Private Function IsDouble(ByVal value As Variant) As Boolean
    IsDouble = (IsNumeric(value) And Not IsLong(value))
End Function

Private Function IsLong(ByVal value As Variant) As Boolean
    IsLong = (VarType(value) = vbLong)
End Function

Private Function IsString(ByVal value As Variant) As Boolean
    IsString = (VarType(value) = vbString)
End Function

'Private Function IsInteger(ByVal value As Variant) As Boolean
'    IsInteger = (VarType(value) = vbInteger)
'End Function

Private Function VarDeclaration(ByVal strVarCheck As String) As String
    If IsDouble(strVarCheck) Then
        VarDeclaration = "Double"
    ElseIf IsLong(strVarCheck) Then
        VarDeclaration = "Long"
    ElseIf IsDate(strVarCheck) Then
        VarDeclaration = "Date"
    ElseIf IsString(strVarCheck) Then
        VarDeclaration = "String"
    End If
End Function
UDT declarations should be shown in the "Inmediate window" From this point, you can code some procedures to write/read an XML structure linked to the UDT schema. I will not show here how to get these functionalities, but I should point that most of the code to get them can be recycled from the sXML_Parse function. Do your homework! 😉 Finally, we'll also consider of interest to get some functions coded to deal with arrays of complex data (UDT variables), as VBA doesn't have any specific, out of Library, Directory and Collection objects -which I avoid as they are far from optimized when dealing with big arrays-. We can imitate the JavaScript sentences, so it'll be easier in the future to do a port to other programming languages. ' Array UDT functions 'https://www.w3schools.com/js/js_array_methods.asp Here are exposed the templates for building these functions
Option Explicit

'!!!!!!!!!!!!!!!!!!
Private Enum estrUDTName
    Value1
End Enum
Private Type strVarType
    Test As Boolean
End Type
Private Type tstrUDTName
    strVarType As strVarType
End Type
Public Const g_Base As Long = 0
'!!!!!!!!!!!!!!!!!!

Private Function fstrUDTName_Slice(ByRef astrUDTName() As tstrUDTName, _
                                   Optional ByVal lgFrom As Long = 0, _
                                   Optional ByVal lgTo As Long = -1) As tstrUDTName()
' _Slice/Get : Return the elements in array, from item lgFrom to item lgTo
    Dim aSlice() As tstrUDTName
    Dim lgItem As Long
    Dim lgSlice As Long

    If Not (Not astrUDTName) Then
        If lgFrom >= lgTo Then
            If lgFrom <= LBound(astrUDTName) Then lgFrom = LBound(astrUDTName)
            If lgTo <= UBound(astrUDTName) Then lgTo = UBound(astrUDTName)
        End If

        lgSlice = g_Base - 1
        ReDim aSlice(g_Base To lgTo - lgFrom + 1 - g_Base)
        For lgItem = lgFrom To lgTo
            lgSlice = lgSlice + 1
            aSlice(lgSlice) = astrUDTName(lgItem)
        Next lgItem

        fstrUDTName_Slice = aSlice()
        Erase aSlice()
    End If
End Function

Private Function fstrUDTName_Delete(ByRef astrUDTName() As tstrUDTName, _
                                    Optional ByVal lgStart As Long = 0, _
                                    Optional ByVal lgItems As Long = 1) As Boolean
' _Delete : erase content (leave blank) items in the middle
    Dim aBlankstrUDTName As tstrUDTName
    Dim lgItem As Long

    If Not (Not astrUDTName) Then
        If lgStart  UBound(astrUDTName) - lgStart + 1 Then lgItems = UBound(astrUDTName) - lgStart + 1

        For lgItem = lgStart To UBound(astrUDTName)
            astrUDTName(lgItem) = aBlankstrUDTName
            If lgItem > (lgStart + lgItems + 1 - g_Base) Then Exit For
        Next lgItem

        fstrUDTName_Delete = True
    End If
End Function

Private Function fstrUDTName_Splice(ByRef astrUDTName() As tstrUDTName, _
                                    ByRef AddstrUDTName() As tstrUDTName, _
                                    Optional ByVal lgStart As Long = 0, _
                                    Optional ByVal lgItems As Long = 1) As tstrUDTName()
'  The first parameter defines the elements that should be added (spliced).
'  The second parameter defines the position where new elements should be added (spliced in).
'  The third parameter defines how many elements should be removed.
'  The splice() method returns an array with the deleted items:

    Dim aSplice() As tstrUDTName
    Dim aTmpSplice() As tstrUDTName
    Dim lgItem As Long
    Dim lgSplice As Long
    Dim lgAddings As Long

    If Not (Not astrUDTName) Then
        If lgStart  UBound(astrUDTName) - lgStart + 1 Then lgItems = UBound(astrUDTName) - lgStart + 1

        If Not (Not AddstrUDTName) Then
Stop
            lgAddings = UBound(AddstrUDTName) - LBound(AddstrUDTName) + 1
        End If

        If lgItems = (UBound(astrUDTName) - LBound(astrUDTName) + 1) Then
            aSplice() = astrUDTName()
            Erase astrUDTName()

        Else
            lgSplice = g_Base - 1
            ReDim aSplice(g_Base To lgItems + g_Base - 1 + lgAddings)

            aTmpSplice() = aSplice()
            ' Get starting items (and allocated space for new items)
            ReDim Preserve aTmpSplice(g_Base To UBound(astrUDTName) - lgItems)

            ' Get removed items aSplice
            For lgItem = lgStart To UBound(astrUDTName)
                lgSplice = lgSplice + 1
                aSplice(lgSplice) = astrUDTName(lgItem)
                If lgSplice > (lgItems + 1 - g_Base) Then Exit For
            Next lgItem

            lgSplice = lgStart - 1
 '!!!!!!!!!!!!!!!!!!!!
            ' Add items
            'For lgItem = lgStart To lgStart + lgAddings - 1
            '    lgSplice = lgSplice + 1
            '    aSplice(lgSplice) = astrUDTName(lgItem)
            '    If lgSplice > (lgStart + lgAddings - 1) Then Exit For
            'Next lgItem
 '!!!!!!!!!!!!!!!!!!!!

            ' Get final items back
            For lgItem = (lgStart + lgItems) To UBound(astrUDTName)
                lgSplice = lgSplice + 1
                aTmpSplice(lgSplice) = astrUDTName(lgItem)
                If lgSplice > (lgItems + 1 - g_Base) Then Exit For
                'If lgSplice > ubound(aTmpSplice) Then Exit For
            Next lgItem
            Erase astrUDTName() ' needed???
            astrUDTName() = aTmpSplice()
        End If

        fstrUDTName_Splice = aSplice()
        Erase aSplice()
        Erase aTmpSplice()
    End If
End Function

Private Function fstrUDTName_Push(ByRef astrUDTName() As tstrUDTName, _
                                  ByRef AddstrUDTName As tstrUDTName) As Long
' Push : Add items to the end of an array, returns the new array length:

    If Not (Not astrUDTName) Then
        ReDim Preserve astrUDTName(LBound(astrUDTName) To UBound(astrUDTName) + 1)
    Else
        ReDim Preserve astrUDTName(LBound(astrUDTName) To UBound(astrUDTName) + 1)
    End If
    astrUDTName(UBound(astrUDTName)) = AddstrUDTName

    fstrUDTName_Push = UBound(astrUDTName) + LBound(astrUDTName) + 1
End Function

Private Function fstrUDTName_Pop(ByRef astrUDTName() As tstrUDTName) As tstrUDTName
' _Pop : Remove an item from the end of an array, and returns the value that was "popped out":

    If Not (Not astrUDTName) Then
        fstrUDTName_Pop = astrUDTName(UBound(astrUDTName))
        If LBound(astrUDTName) = UBound(astrUDTName) Then
            Erase astrUDTName()
        Else
            ReDim Preserve astrUDTName(LBound(astrUDTName) To UBound(astrUDTName) - 1)
        End If
    End If
End Function

Private Function fstrUDTName_Unshift(ByRef astrUDTName() As tstrUDTName, _
                                     ByRef AddstrUDTName As tstrUDTName) As Long
' _Unshift() : Add items to the beginning of an array, returns the new array length

    Dim aTmpstrUDTName() As tstrUDTName

    If Not (Not astrUDTName) Then
        ReDim Preserve astrUDTName(LBound(astrUDTName) To UBound(astrUDTName) + 1)
    Else
        ReDim Preserve aTmpstrUDTName(LBound(astrUDTName) To UBound(astrUDTName) + 1)
        aTmpstrUDTName(LBound(astrUDTName)) = AddstrUDTName
        For lgItem = LBound(astrUDTName) To UBound(astrUDTName)
            aTmpstrUDTName(lgItem + 1) = astrUDTName(lgItem)
        Next lgItem
        astrUDTName() = aTmpstrUDTName()
        Erase aTmpstrUDTName()
    End If

    fstrUDTName_Unshift = UBound(astrUDTName) + LBound(astrUDTName) + 1
End Function

Private Function fstrUDTName_Shift(ByRef astrUDTName() As tstrUDTName) As tstrUDTName()
' _Shift() : Remove an item from the beginning of an array, returns the string that was "shifted out":

    Dim aTmpstrUDTName() As tstrUDTName

    If Not (Not astrUDTName) Then
        fstrUDTName_Shift = astrUDTName(LBound(astrUDTName))
        If LBound(astrUDTName) = UBound(astrUDTName) Then
            Erase astrUDTName()
        Else
            ReDim Preserve aTmpstrUDTName(LBound(astrUDTName) To UBound(astrUDTName) - 1)
            For lgItem = LBound(astrUDTName) + 1 To UBound(astrUDTName)
                aTmpstrUDTName(lgItem - 1) = astrUDTName(lgItem)
            Next lgItem
            astrUDTName() = aTmpstrUDTName()
            Erase aTmpstrUDTName()
        End If
    End If
End Function

Private Function fstrUDTName_ReDim(ByRef astrUDTName() As tstrUDTName) As tstrUDTName()
' _ReDim()

End Function

Private Function fstrUDTName_Concat(ByRef astrUDTName() As tstrUDTName) As tstrUDTName()
' _Concat

End Function

Private Function fstrUDTName_Swap(ByRef astrUDTName() As tstrUDTName) As tstrUDTName()
' _Swap

End Function

Private Function fstrUDTName_Flip(ByRef astrUDTName() As tstrUDTName) As tstrUDTName()
' _Flip

End Function

Private Function fstrUDTName_Flat(ByRef astrUDTName() As tstrUDTName) As tstrUDTName()
' _Flat()

End Function

Private Function fstrUDTName_FlatMap(ByRef astrUDTName() As tstrUDTName) As tstrUDTName()
' _FlatMap()

End Function

'---------------------------------------------------
' Array data functions:
'---------------------------------------------------
Private Function fstrUDTName_strVar_Get(ByRef astrUDTName() As tstrUDTName) As strVarType()
    Dim astrVar() As strVarType
    Dim lgItem As Long

    If Not (Not astrUDTName) Then
        ReDim astrVar(LBound(astrUDTName) To UBound(astrUDTName))
        For lgItem = LBound(astrUDTName) To UBound(astrUDTName)
            astrVar(lgItem) = astrUDTName(lgItem).strVarType
        Next lgItem
        fstrUDTName_strVar_Get = astrVar()
    End If
End Function

Private Function fstrUDTName_Min(ByRef astrUDTName() As tstrUDTName, _
                                 ByRef Key As estrUDTName) As Long
    Dim lgPos As Long

    Select Case Key
'        Case "X"
'            Call fDblMin(aValue, lgPos)
'            fstrUDTName_Min = lgPos
    End Select
End Function

Private Function fstrUDTName_Max(ByRef astrUDTName() As tstrUDTName, _
                                 ByRef Key As estrUDTName) As Long
    Dim lgPos As Long

    Select Case Key
'        Case "X"
'            Call fDblMax(aValue, lgPos)
'            fstrUDTName_Max = lgPos
    End Select
End Function

' _Join
'"Private Function f" & strUDTName & "_" & strVar & "_Join(ByRef a" & strUDTName & " As t" & strUDTName, _
                                                           ByVal Separator As String) As String"
' _Find: "Private Function f" & strUDTName & "_" & strVar & "_Find(ByVal Key As String) As Long()"
' _Sort: "Private Function f" & strUDTName & "_" & strVar & "_Sort(Optional ByVal lgFrom As Long = 0, Optional ByVal lgTo As Long = -1) As Boolean"

'Select Case strTypeVar
'    Case "String"
'    Case "Double"
'    Case "Single"
'    Case "Long"
'    Case "Integer"
'    Case "Boolean"
'    Case "Byte"
'End Select
There are some caveats:
  • Unicode characters, that not met UTF-8 codification (i.e. áéí...àè...).
  • Comments inside the XML, that is "" strings. They are not correctly handled by the MSXML library, so you should rip them off before parsing the XML string to the loader.
For the first one, I could be solved with the code in this post. For the second one, I managed to do it by code, following: So for the non UTF-8 files, do something like this:
''' WinApi function that maps a UTF-16 (wide character) string to a new character string
#If VBA7 Then
Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpWideCharStr As LongPtr, _
    ByVal cchWideChar As Long, _
    ByVal lpMultiByteStr As LongPtr, _
    ByVal cbMultiByte As Long, _
    ByVal lpDefaultChar As Long, _
    ByVal lpUsedDefaultChar As Long _
    ) As Long
#Else
Private Declare Function WideCharToMultiByte Lib "kernel32" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpWideCharStr As Long, _
    ByVal cchWideChar As Long, _
    ByVal lpMultiByteStr As Long, _
    ByVal cbMultiByte As Long, _
    ByVal lpDefaultChar As Long, _
    ByVal lpUsedDefaultChar As Long _
    ) As Long
#End If

''' Maps a character string to a UTF-16 (wide character) string
#If VBA7 Then
Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpMultiByteStr As LongPtr, _
    ByVal cchMultiByte As Long, _
    ByVal lpWideCharStr As LongPtr, _
    ByVal cchWideChar As Long _
    ) As Long
#Else
Private Declare Function MultiByteToWideChar Lib "kernel32" ( _
    ByVal CodePage As Long, _
    ByVal dwFlags As Long, _
    ByVal lpMultiByteStr As Long, _
    ByVal cchMultiByte As Long, _
    ByVal lpWideCharStr As Long, _
    ByVal cchWideChar As Long _
    ) As Long
#End If

' CodePage constant for UTF-8
Private Const CP_UTF8 = 65001

Private Function fFile_Load_UTF8(Optional ByRef strFullPathFile As String = vbNullString) As String
' Will load any file not UTF-8 codification to UTF-8 codification inside VBA
    Dim strUnicode As String
    Dim strUTF8 As String
    Dim aUTF8() As Byte
    Dim iFileIn As Integer

    strFullPathFile = fSelectFile
    ReDim aUTF8(0 To VBA.FileLen(strFullPathFile) - 1)
    iFileIn = VBA.FreeFile
    Open strFullPathFile For Binary As #iFileIn
    Get #iFileIn, , aUTF8()
    Close #iFileIn
    fFile_Load_UTF8 = Utf8BytesToString(aUTF8())
End Function

Private Function BytesLength(abBytes() As Byte) As Long
''' Return length of byte array or zero if uninitialized
' https://www.di-mgt.com.au/howto-convert-vba-unicode-to-utf8.html
    ' Trap error if array is uninitialized
    On Error Resume Next
    BytesLength = UBound(abBytes) - LBound(abBytes) + 1
End Function

Private Function Utf8BytesToString(abUtf8Array() As Byte) As String
''' Return VBA "Unicode" string from byte array encoded in UTF-8
' https://www.di-mgt.com.au/howto-convert-vba-unicode-to-utf8.html
    Dim nBytes As Long
    Dim nChars As Long
    Dim strOut As String

    Utf8BytesToString = ""

    ' Catch uninitialized input array
    nBytes = BytesLength(abUtf8Array)
    If nBytes  Reference to "Microsoft Scripting Runtime"
    Set oFSO = CreateObject("Scripting.FileSystemObject")

'--------------------
    Dim var_txt_file As Object
    Set var_txt_file = oFSO.GetFile(strFullPathFile).OpenAsTextStream(ForReading, TristateTrue)
    xFile_Load_UTF8 = var_txt_file.ReadLine
    var_txt_file.Close
'--------------------

'    Dim oTextStream As Scripting.TextStream
'    Dim aUnicode() As String
'    Dim lgLine As Long
'    Dim strUTF8 As String
'
'    With oFSO
'        Set oTextStream = .OpenTextFile(strFullPathFile, ForReading, False, TristateTrue)
'        aUnicode() = VBA.Split(oTextStream.ReadAll(), vbCrLf)
'        Set oTextStream = Nothing
'        For lgLine = LBound(aUnicode) To UBound(aUnicode)
'            strUTF8 = strUTF8 & vbCrLf & aUnicode(lgLine)
'        Next lgLine
'        Erase aUnicode()
'        xFile_Load_UTF8 = strUTF8
'    End With
'    Set oFSO = Nothing
End Function
And for the comments problem, use this:
Private Function fXML_Uncomment(ByRef strFullPathFile_XSD As String) As String
' There seems to be a problem parsing schemas, as they have comment items:
' "" that are not read by MSMXL object
' We have to split the XSD file into sections... and then reunite in a whole
    Dim strXML As String
    Dim strXMLOrphan As String
    Dim aLine() As String
    Dim aBlock() As String
    Dim lgLine As Long
    Dim lgBlock As Long
    Dim lgPosComment As Long

    strXML = fFile_Load(strFullPathFile_XSD)
    aLine() = VBA.Split(strXML, vbNewLine)

    lgBlock = g_Base - 1
    For lgLine = (LBound(aLine) + 1) To UBound(aLine)
        lgBlock = lgBlock + 1
        ReDim Preserve aBlock(g_Base To lgBlock)

        aLine(lgLine) = aLine(lgLine) & strXMLOrphan: strXMLOrphan = vbNullString
        lgPosComment = VBA.InStr(1, aLine(lgLine), " 0
            If VBA.Trim$(aLine(lgLine))  vbNullString Then
                aBlock(lgBlock) = aBlock(lgBlock) & aLine(lgLine) & vbNewLine
            End If
            lgLine = lgLine + 1
            If lgLine > UBound(aLine) Then: lgLine = lgLine - 1: lgPosComment = 1: Exit Do
            lgPosComment = VBA.InStr(1, aLine(lgLine), "<!--")
DoEvents
        Loop
        aBlock(lgBlock) = aBlock(lgBlock) & VBA.Mid$(aLine(lgLine), 1, lgPosComment - 1)

        If VBA.InStr(aLine(lgLine), " 0 Then
            ' Avoid empty blocks
            If VBA.Len(aBlock(lgBlock)) ") + 3
            Do Until lgPosComment > 3
                lgPosComment = 1
                lgLine = lgLine + 1
                If lgLine > UBound(aLine) Then: lgLine = lgLine - 1: lgPosComment = 1: Exit Do
                lgPosComment = VBA.InStr(lgPosComment, aLine(lgLine), "-->") + 3
DoEvents
            Loop
            strXMLOrphan = VBA.Mid$(aLine(lgLine), lgPosComment) & vbNewLine
        End If
    Next lgLine

    fXML_Uncomment = VBA.Join(aBlock(), vbNewLine)
End Function
[/sourcecode]	

VBA data types

There is a bunch of data type we can handle with VBA, but looking at a variable value it will not get us to the type of value it is. From Ms Online help we can get the constant values returned by the function VarType(). So we can make a table like this one:
Data Type Bytes Used Range of Values Const value Constant
Byte 1 0 to 255 17 vbByte
Boolean 2 true or False 11 vbBoolean
Integer 2 -32,768 to 32767 2 vbInteger
Long 4 -2,147,483,648 to 2,147,483,647 3 vbLong
Single 4 -3.402823E38 to 1.401298E45 4 vbSingle
Double (negative) 8 -1.79769313486232E308 to -4.94065645841247E-324 5 vbDouble
Double (positive) 8 4.94065645841247E-324 to 1.79769313486232E308 5 vbDouble
Currency 8 -922,337,203,685,477.5808 to 922,337,203,685,477.5807 6 vbCurrency
Date 8 1/1/100 to 12/31/9999 7 vbDate
String 1 per character Varies according to the number of characters 8 vbString
Object 4 Any defined object 9 vbObject
Variant Varies Any data type 12 vbVariant
Used defined Varies Varies 36 vbUserDefinedType
Although, there are some Const values that do not strictly correspond to data types,  mainly related to functions (IsArray, IsEmpty, IsError, IsNull, IsArray), or near to databases (DataObject):
Constant VBA7 Value
vbArray 8192
vbDataObject 13
vbDecimal           Decimal 14
vbEmpty 0
vbError 10
vbLongLong LongPtr 20 (only on implementations that support a LongLong value type)
vbNull 1

PIC

Cuatro años de obras y 20 de explotación. Las actuaciones del PIC (el denominado Plan Junker) estaban pensadas para cuatro años de intensas obras y 30 años de explotación en manos privadas. Estos son los 27 proyectos que lo integran, con la premisa de que estén incluídos en la red transeuropea de transportes.
  • Eje Este-Oeste de la A-7. Alicante-Murcia.
  • Autovía a-30 Murcia. ( Eje Norte-Sur).
  • Autovía A-73. Burgos-Aguilar de Campoo.
  • Prolongación de la A-7.VilanovaD’Alcolea y Traiguera (Castellón).
  • A-32. Linares-Albacete (en Albacete)
  • Variante a la N-120. Porriño-Vigo.
  • Duplicación By Pass A-7 Valencia.
  • Mejora de la capacidad de la A-62. Tramos Dueñas-Cigales-Simancas-Tordesillas.
  • Autovía A-8. Laredo (Cantabria)-Límite provincial de Vizcaya.
  • Variante Autovía A-1 en Madrid.
  • Aumento de capacidad en la N-II. Girona-La Jonquera.
  • Tercer carril A-8. Gijón- Avilés.
  • A-32. Linares-Albacete (Jaén)
  • Autovía A-11. Zamora-Frontera portuguesa.
  • Autovía A-15. Soria-Límite provincial Navarra.
  • A-1. Madrid-El Molar.
  • A-1. El Molar-Sto. Tomé del Puerto.
  • A-3. Madrid (M-30)-Lím. Prov. Cuenca.
  • A-4. Km. 67,5 (R4)-Puerto Lápice.
  • A-4. Límite provincial Jaén/Ciudad Real – Lim. prov. Córdoba/Jaén.
  • A-4. Lím. prov. Córdoba/Jaén – Lím. prov. Sevilla/Córdoba
  • A-4. Lím. prov. Sevilla/Córdoba – Sevilla
  • A-5. Madrid – Toledo Km 4 – 168
  • A-2. Igualada – Martorell
  • A-6. Adanero – Benavente
  • Autovía SE-40. Túneles Sur del Guadalquivir – Embocadura Oeste. 48-SE-4520ª
  • Autovía SE-40. Tramo A-66 / A-49.

Microsoft Office XP Developer (MOD)

[adapted from https://www.itprotoday.com/office-365/microsoft-office-2000-developer ] Starting from 2000 version, Microsoft introduced the Developer edition (MOD). MOD provides all the tools you need: COM AddInDesigners, data-bound controls, the Package and Deployment Wizard, Visual SourceSafe (VSS) integration with Visual Basic for Applications (VBA), and the Code Librarian. In MOD, Microsoft expands Office applications’ object models. More important, MOD documents these object models well. To optimally use MOD, you must know applications’ object models. With this knowledge, you can choose whether to use an Office facility or write code to gain functionality. For example, you can write a routine that counts the words in a Microsoft Word document or you can use Word’s inherent Word Count feature. You can find MOD’s object model documentation here. Beyond the developer tools contained in Office XP Developer, the product integrates a number of key productivity enhancements, including:
  • Smart Tags, which can help users easily access information by automatically linking them to rich, up-to-date corporate and Web information directly from within Office documents.
  • XML Designer, which lets developers create and manipulate XML data easily, and provides a Source View for working with XML and XSD (XML schema definition) files.
  • COM Add-In Designer, which developers can use to create stand-alone COM add-ins (DLLs) for use in any or all of the Office applications.
  • The Code Librarian, which offers a drag-and-drop database for storing and retrieving code modules, functions and code snippets, allows developers to retrieve the tools they need while they are creating their applications. Code Librarian is a database that contains example code and scripts for all the things you’d want to work on in Office XP.
  • A VBA Code Commenter, which makes it easier to add comments into code using customizable templates, and VBA Error Handler helps developers create more professional applications that are easier to debug and support.
  • A collection of documentation resources, including the Microsoft Office XP Developer’s Guide , to help developers learn the product quickly, as well as prewritten code for standard routines for VBA and the Visual Studio development environment, workflow samples and step-by-step white papers that help developers learn to build workflow solutions.
  • Developer-only versions of Exchange 2000 Server and SQL Server 2000.
  • Developers can create or edit XML code by typing directly in the Source View editor window. The designer color-codes the XML source code as it is input and automatically completes tags, offering a pop-up list of available properties as a tag is inserted.
  • Native XML support in Excel and Access enables Office developers to create data-driven solutions that share data with a virtually unlimited number of sources, and interoperate with external applications that are within the corporation or over the Web.
  • For example, Medicity, a provider of the only secure, vendor-neutral Internet platform for physicians, created an Office XP solution built on smart tags and XML technology. The solution automatically triggers a smart tag option and generates a letter that is embedded within patient information. This automation allows patients to be notified more quickly and accurately than before. Because physicians and staff can create accurate letters in seconds, they can spend more time focusing on patient care.
Many of MOD’s tools are part of the standard Office package and other Microsoft products. For example, Microsoft has integrated Access’s database diagramming tools into MOD. You can use the Access database diagramming tool by selecting a database’s Database Diagrams option in MOD. This option provides a default Relationships diagram that shows the database’s entity-relationship model. MOD lets you share this diagram with Microsoft SQL Server 7.0 and Visual Studio (VS) 6.0 so that you can create tables. If you lack the proper rights to create tables, you can pass diagrams to a DBA who can create tables. MOD also includes Microsoft Database Engine (MSDE), which is an alternative database engine for Access. Think of MSDE as a runtime version of SQL Server. Because MSDE is SQL Server-compatible, you can develop Access databases that port to SQL Server with little or no modification. The Jet 4.0 engine is the default Access engine, so developers can still distribute an Access runtime program as well as distribute MSDE with their applications. Unlike conventional SQL Server, MSDE runs on Windows 9x. An Access Project file, which has an .adp extension, represents Access databases stored in SQL Server or MSDE. This file contains the Access databases’ code, forms, reports, macros, modules, and HTML-based database objects, and information that tells the system to use the OLE DB connector to connect to Access through SQL Server. MSDE looks like SQL Server to users and other programs, but it lacks many of SQL Server’s high-end management and development tools, such as Enterprise Manager. MSDE includes the Service Manager, which lets you stop and restart the service; network configuration tools, which ensure that the MSDE server uses the proper network protocols; and the Data Transformation Services (DTS) wizard, which shows you how to import and export data. MSDE limits database size to 2GB and performs adequately with as many as five concurrent users.

COM AddIns

One of MOD’s unique capabilities is that it lets you use COM AddIns to write software that works across the entire Office suite. COM AddIns are special DLLs that all Office applications can invoke. You can write these AddIns in any compiled language that can handle COM and create DLLs. COM AddIns can access the Office object model, so you can write code that is generically applicable to Office applications. Through the Office object model, COM AddIns can also gain access to SQL Server or MSDE databases and perform sophisticated operations on the data. To help you get started with COM AddIns, MOD provides AddInDesigners, which are dialog boxes that contain options that create a component shell. In an AddInDesigner dialog box, you can specify identification information, the application you’re targeting, and specific application versions (e.g., Word 9.0). You can customize load behavior by selecting from the following options: None, Load on demand, Startup, and Load at next startup only. You can specify the AddIn’s DLL name and location. In addition, you can specify a Registry key from which the AddIn can retrieve external data. By default, MOD writes AddIns in the VBA environment, but Microsoft provides templates for you to write AddIns in Visual C++ (VC++), Visual Basic (VB), and Visual J++ (VJ++). These templates aren’t installed by default, so you must go to the \odetools\v9\samples\unsupported\mkaddin directory to install them.

Data-Bound Controls

MOD comes with several new data-bound controls, such as bound lists and bound data grids. To bind the controls to data, you use MOD’s Data Environment Designer (DED). The DED lets you use ADO and OLE DB to define queries and save them in a form that you can pass to other users for use in their queries. To create a connection in a VBA environment, select Data Environment from the Insert menu. After VBA inserts a connection object into your project, right-click the object, select Properties, and fill out the Connection dialog box to connect the object to an ADO, OLE DB, or other database source. Next, choose a driver (e.g., ODBC, OLAP, Oracle, SQL Server) and enter the server and database you’ll be working with. To test the connection in the same dialog box you created it in, click Test Connection. You then use ADO to command the database. To change the database’s properties, select Add Command. As you change the database’s properties, the DED progressively queries the database, simplifying the building process. Data-bound controls have been around for some time, and the DED first shipped in VB 6.0. But Microsoft’s inclusion of the DED in MOD represents a qualitative leap in ease-of-use for building data-aware applications. Building read/write database applications has never been this easy.

Package and Deployment Wizard

Any software deployment can be difficult, but deploying Office solutions is especially arduous. Office application deployment is complex and involves ActiveX controls and templates for numerous application types, graphics, and add-ons. MOD’s Package and Deployment Wizard simplifies this process by letting you build a deployment package on 3.5″ disks, CD-ROMs, a LAN drive, or an intranet location. To create a deployment package, select Package and Deployment Wizard from the Add-Ins menu. The system presents you with three options: Package, Deploy, and Manage Scripts. The Package option lets you bundle different files into one dependency file (i.e., a file that defines the rules for installing the program from any location). The Deploy option sends the dependency file to a server, file share, or intranet location from which users can install it. The Manage Scripts option is a simple interface from which you can delete, rename, and duplicate deployment packages. When you invoke the Package option, the system asks for the DLL that contains the component you created (i.e., the DLL you specified for the COM AddIn), then analyzes the DLL and creates a list of dependencies (i.e., a list of files it wants to include in the package). This list probably includes the contents of the DLL, OLE custom control (OCX) files you might have used to build the DLL, Help files and HTML you created, and setup.exe and other overhead files. In addition, if you used MSDE, you’ll find it in the dependency list. At this point, you can opt to include the traditional Access runtime. You then decide whether you want the wizard to create one compressed cabinet format (CAB) file or to split the file into 1.44MB 3.5″ disk-sized chunks. You define the installation’s title and, optionally, a postinstallation program (e.g., display a README file, launch an application). You define where the application links go in the Start menu. Next, you use generic environment names, such as $(WinSysPath) for \windows\system, to specify the deployment package files’ location on the client system. (Change the default locations at your own risk.) You can mark a file (e.g., the COM AddIn you created) as a shared file so that the system establishes a counter in the Registry for the number of applications that use that file. The system won’t uninstall that file until the counter hits 0. Click Finish to complete the package. The system produces a report that lists any problems that occurred during the package-creation process. To install the package, users run setup.exe from where you placed it in the wizard.

VSS Integration with VBA 

VSS is a source-code revision-control tool—a necessary facility in team-development situations. When multiple developers work on a project, two or more of them might work on the same source code file with undefined and undesirable results. VSS is a special database for source-code files. Developers must check out code from the database to use VSS. When they’re finished, they check the code back in. While a user or tool (e.g., a compiler) has code checked out, no other users or tools can access the code. First, go to MOD’s AddIn Manager and instruct MOD to load the VBA Source Code Control. Next, add the project to VSS by selecting VBA Source Code Control from the Add-Ins menu, assigning a project name, and specifying which files to control. When you right-click a file in your VBA project window, you’ll see the check-in and check-out options. You can also look in the Source Code Control Status window to see who has which project files open.

Code Librarian 

The Code Librarian is a database of code snippets—hundreds of code bits that perform isolated actions. When you’re programming, you often write routines for the same common tasks and you usually have to look up each task’s details. The Code Librarian, lets you browse or search for the task you need (e.g., OLE automating an Excel object) and drag the code into your project. The Code Librarian comes preloaded with snippets of Office code, mostly VBA, but you can extend it to any language. The libraries are Access (i.e., .mdb) databases, so they’re easy to distribute. The Code Librarian stores snippets in a hierarchical list with attached keywords. You can search the keywords or the database’s contents. You can add your snippets to the database, or you can create a database of your snippets. The Code Commenter is also a useful tool. You usually want to comment your code in a consistent way (e.g., a particular header-comment structure for a module or function). The Code Commenter enforces these rules. After you invoke the Code Commenter from the Add-Ins menu, you specify that the comments apply to a specific procedure, an entire module, or an entire project. You specify your name and initials, and a template file. When you click OK, the Code Commenter uses the template and applies the comments to the code in whatever scope you specified. The Code Commenter works only in VBA.

Access Workflow Designer 

MOD’s Access Workflow Designer for SQL Server is a separate tool for creating Access applications that implement processes with rules. Access Workflow Designer lets you implement the stages of a project in a flowchart-like design. You assign code at different steps to implement the work at that point, and you assign code on the connectors to implement the decision-making process. You can find the Access Workflow Designer at http://msdn.microsoft.com/officedev/awd.

Printers

Again, from My Engineering World, I stomped on this post, dealing with printers. Is not that I do a lot of printing, but sometimes come handy when you need to send to PDF. I have several other procedures coded in the past that perform these tasks, but decided to try to work on them again, and retailor to better fit as general procedures/functions.
'----------------------------------------------------------------------------------
' Functions to deal with printers from VBA:
'
' • PrinterExists:           Checks if there is a printer installed with the given name.
' • IsDefaultPrinter:        Checks if the given printer corresponds to the default windows printer.
' • SetDefaultPrinter:       Makes the given printer to be the default one.
'
' • SelectPrinter:           Shows the list of installed printers and retrieves one.
'
' • GetInstalledPrinters:    Loops through all the installed printers and outputs to an array.
'                            Moreover, it checks if each printer is the default one.
'
' • SetAsTheDefaultPrinter:  The user selects a printer to becomes the default one.
'----------------------------------------------------------------------------------

Private computer            As String
Private wmiService          As Object
Private installedPrinters   As Object 'Variant
Private printer             As Object

Public Function PrinterExists(ByVal printerName As String) As Boolean
    On Error Resume Next

    'Check if the printer name is empty.
    If printerName = vbNullString Then Exit Function

    'Set the computer (Dot means the computer running the code).
    computer = "."

    'Get the WMI object
    Set wmiService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & computer & "\root\cimv2")

    'Retrieve information about the installed printers (by running a query).
    Set installedPrinters = wmiService.ExecQuery("Select * from Win32_Printer")

    'If an error occurs in the previous step, the function should exit and return False.
    If Err.Number  0 Then GoTo ExitProc

    'Loop through all the installed printers.
    'If the given name matches to any of the installed printers, exit the loop and return True.
    For Each printer In installedPrinters
        If UCase(printer.Name) = UCase(printerName) Then
            PrinterExists = True
            GoTo ExitProc
        End If
    Next printer

ExitProc:
    On Error GoTo 0
End Function

Public Function IsDefaultPrinter(ByVal printerName As String) As Boolean
    On Error Resume Next

    'Check if the printer name is empty.
    If printerName = vbNullString Then Exit Function

    'Set the computer (Dot means the computer running the code).
    computer = "."

    'Get the WMI object
    Set wmiService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & computer & "\root\cimv2")

    'Retrieve information about the installed printers (by running a query).
    Set installedPrinters = wmiService.ExecQuery("Select * from Win32_Printer")

    'If an error occurs in the previous step, the function should exit and return False.
    If Err.Number  0 Then GoTo ExitProc

    'Loop through all the installed printers. If the given name matches to any of the installed printers
    'and the Default property is set to True, exit the loop and return True.
    For Each printer In installedPrinters
        If UCase(printer.Name) = UCase(printerName) And printer.Default = True Then
            IsDefaultPrinter = True
            Exit Function
        End If
    Next printer

ExitProc:
    On Error GoTo 0
End Function

Public Function SelectPrinter() As String
    Dim aPrinter() As String
    Dim lgPrinter As Long
    Dim strMsg As String

    On Error Resume Next

    aPrinter() = VBA.Split(GetInstalledPrinters, vbCrLf)
    ReDim Preserve aPrinter(LBound(aPrinter) To UBound(aPrinter) - 1)
    strMsg = "Default        PrinterName" & vbCrLf
    For lgPrinter = LBound(aPrinter) + 1 To UBound(aPrinter)
        strMsg = strMsg & lgPrinter & ": " & aPrinter(lgPrinter) & vbCrLf
    Next lgPrinter

    lgPrinter = VBA.CLng(VBA.InputBox("Select printer (0 for default):" & vbCrLf & vbCrLf & strMsg, _
                                      "Select printer", 1))
    If lgPrinter = 0 Then
        GoTo ExitProc
    ElseIf lgPrinter  UBound(aPrinter) Then
        GoTo ExitProc
    Else
        SelectPrinter = VBA.Trim$(VBA.Mid$(VBA.Trim$(aPrinter(lgPrinter)), 2))
    End If

ExitProc:
    On Error GoTo 0
End Function

Public Function SetDefaultPrinter(Optional ByVal printerName As String = vbNullString) As Boolean
    Dim wscNetwork As Object

    On Error Resume Next

    'Check if the printer name is empty.
    'If printerName = vbNullString Then GoTo ExitProc
    If printerName = vbNullString Then
        'Select printer
        printerName = SelectPrinter
    End If

    If Not PrinterExists(printerName) Then
        MsgBox "Printer [" & printerName & "] does not exist. Won't set printer", vbExclamation, "W A R N I N G"
        GoTo ExitProc
    End If

    'Test if the printer is already the default one. If yes, return True.
    If IsDefaultPrinter(printerName) = True Then
        SetDefaultPrinter = True
        GoTo ExitProc
    End If

    'The printer is not the default one. Create the WScript.Network object.
    Set wscNetwork = CreateObject("WScript.Network")

    'If the WScript.Network object was not created, exit.
    If wscNetwork Is Nothing Then GoTo ExitProc

    'Set the given printer to be the default one.
    wscNetwork.SetDefaultPrinter printerName

    'Release the WScript.Network object.
    Set wscNetwork = Nothing

    'Check (again) if after the change, the given printer is indeed the default one.
    SetDefaultPrinter = IsDefaultPrinter(printerName)

ExitProc:
    On Error GoTo 0
End Function

Public Function GetInstalledPrinters() As String
    Dim computer            As String
    Dim wmiService          As Object
    Dim installedPrinters   As Object 'Variant
    Dim printer             As Object
    Dim strPrinters         As String

    On Error Resume Next

    'Set the computer. Dot means the computer running the code.
    computer = "."

    'Get the WMI object
    Set wmiService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & computer & "\root\cimv2")

    'Retrieve information about the installed printers (by running a query).
    Set installedPrinters = wmiService.ExecQuery("Select * from Win32_Printer")

    'If an error occurs in the previous step, inform the user.
    If Err.Number  0 Then
        MsgBox "Could not retrieve the printer information from WMI object!", vbCritical, "WMI Object Error"
        GoTo ExitProc
    End If

    'Loop through all the installed printers and get their name.
    'Check if one of them is the default one.
    strPrinters = "Default   PrinterName" & vbCrLf
    For Each printer In installedPrinters
        strPrinters = strPrinters & _
                      VBA.Space(5) & VBA.IIf(printer.Default, "•", "º") & VBA.Space(9) & _
                      printer.Name & vbCrLf
    Next printer

    GetInstalledPrinters = strPrinters

ExitProc:
    On Error GoTo 0
End Function

Public Sub SetAsTheDefaultPrinter()
    Dim printerName As String

    On Error Resume Next

    printerName = SelectPrinter
    Call SetDefaultPrinter(printerName)

ExitProc:
    On Error GoTo 0
End Sub


Public Function CheckPrinterStatus(ByVal strPrinterName As String) As String
' Returns a string with the printer status.

    Dim strComputer As String
    Dim objWMIService As Object
    Dim colInstalledPrinters As Variant
    
    On Error Resume Next
    
    'Set the WMI object and the check the install printers.
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
    Set colInstalledPrinters = objWMIService.ExecQuery("Select * from Win32_Printer")
        
    'If an error occurs in the previous step, the function will return error.
    If Err.Number  0 Then
        CheckPrinterStatus = "Error"
        GoTo ExitProc
    End If
    
    'The function loops through all installed printers and for the selected printer,
    'checks it status.
    For Each Printer In colInstalledPrinters
        If Printer.Name = strPrinterName Then
            Select Case Printer.PrinterStatus
                Case 1: CheckPrinterStatus = "Other"
                Case 2: CheckPrinterStatus = "Unknown"
                Case 3: CheckPrinterStatus = "Idle"
                Case 4: CheckPrinterStatus = "Printing"
                Case 5: CheckPrinterStatus = "Warmup"
                Case 6: CheckPrinterStatus = "Stopped printing"
                Case 7: CheckPrinterStatus = "Offline"
                Case Else: CheckPrinterStatus = "Error"
            End Select
        End If
    Next Printer
    
    'If there is a blank status the function returns error.
    If CheckPrinterStatus = "" Then CheckPrinterStatus = "Error"
    
ExitProc:
    On Error GoTo 0
End Function
 

Access windows (in WindowsOS)

I was looking to this post of My Engineering World, about opening PDF with VBA, and it seems to be calling for reuse in other purposes different from the PDF task. It’s somewhat related to this other one, so I think I must try to dissasemble both and try to do a mashup of them. The point is that they rely in a little Microsoft app called Spy++, that is shiped with Visual Studio, but can be downloaded from here (at your own risk). Other tool that comes very handy is APIViewer, to get how the API calls are correctly defined.
What follows is a full copy paste of the posts from My Engineering World, just to do the cut/copy/paste process near me:
For the example we will manage (print a web in PDF, and open the file), there are several API functions that are beeing called
  • API functions (FindWindow, SetForegroundWindow andFindWindowEx) in order to “find” the print window of Internet Explorer and its “child” windows.
  • API functions (SendMessage and keybd_event) for changing the PDF file path.
  • API functions (FindWindow and PostMessage) for finding the opened PDF document and closing it.The above list describes more or less the sequence of actions that I followed in order to fulfil this task
Also there’s the need to do some WMI queries:
  • A custom WMI (Windows Management Instrumentation) function in order to determine if the printer has finished printing.
For the printing task, you should copy the procedures from this post. And finally, you’ll need the following tools to accomplish this project:
  • Spy++ is a utility that gives you a graphical view of the system’s processes, threads, windows, and window messages.
  • API Viewer is a utility that helps you write the API declarations, by providing the correct syntax of each function.

VBA code

' By Christos Samaras
' http://www.myengineeringworld.net

'API functions (FindWindow, SetForegroundWindow andFindWindowEx) in order
'to “find” the print window of Internet Explorer and its “child” windows.
'API functions (SendMessage and keybd_event) for changing the PDF file path.
'A custom WMI (Windows Management Instrumentation) function in order to determine if the printer has finished printing.
'API functions (FindWindow and PostMessage) for finding the opened PDF document and closing it.The above list describes more or less the sequence of actions that I followed in order to fulfil this task. However, I should mention that without the following tools it would be impossible to finish this project:

'Spy++ is a utility that gives you a graphical view of the system’s processes, threads, windows, and window messages.
'API Viewer (href="http://www.activevb.de/rubriken/apiviewer/index-apiviewereng.html") is a utility that helps you write the API declarations, by providing the correct syntax of each function.

'Shows how to use API functions in order to specify a control (i.e. combo box, listbox,...) in a specific window.
'
'It requires the following steps
' • Check the file path and if is valid, use the FollowHyperlink method in order to open the PDF file.
' • With the FindWindow API function find the window of Adobe Reader or Adobe Professional that contains the opened PDF file and bring it to foreground using the SetForegroundWindow API function.
' • Find the subsequent child windows with the FindWindowEx API function.
' • Use the SendMessage and PostMessage API functions in order to send the desired page number and window zoom value to the corresponding textboxes.

'API calls:
'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.
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

'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.
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

'Sets the specified window's show state.
Public Declare Function ShowWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

'Brings the thread that created the specified window into the foreground and activates the window.
'Keyboard input is directed to the window, and various visual cues are changed for the user.
'The system assigns a slightly higher priority to the thread that created the foreground
'window than it does to other threads.
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long

'Suspends the execution of the current thread until the time-out interval elapses.
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'Sends the specified message to a window or windows. The SendMessage function calls the window procedure
'for the specified window and does not return until the window procedure has processed the message.
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

'Places (posts) a message in the message queue associated with the thread that created the specified
'window and returns without waiting for the thread to process the message.
Public 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

'Synthesizes a keystroke. The system can use such a synthesized keystroke to generate a WM_KEYUP or
'WM_KEYDOWN message. The keyboard driver's interrupt handler calls the keybd_event function.
Public Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

'Constants used in API functions.
Public Const SW_MAXIMIZE = 3
Public Const WM_SETTEXT = &HC
Public Const VK_DELETE = &H2E
Public Const KEYEVENTF_KEYUP = &H2
Public Const BM_CLICK = &HF5&
Public Const WM_CLOSE As Long = &H10

Public Const ¼ As Double = 0.25
Public Const ½ As Double = 0.5
Public Const ¾ As Double = 0.75
Public Const ¹÷³ As Double = 0.333
Public Const ²÷³ As Double = 0.667

Private Sub TestPDF()
    OpenPDF ThisWorkbook.Path & "\" & "Sample File.pdf", 6, 143
    URLToPDF ThisWorkbook.Path & "\" & "Sample File.pdf"
End Sub

Private Sub URLToPDF(pageURL As String, PDFFullPath As String)
' main procedure.
' Loops through all the URLs at column C and print the web pages as PDF using Adobe Professional.
' First, it checks the folder’s path that was selected in the previous step.
' If the folder’s path exists and is not blank it tries to find if there are any
' illegal characters in the PDF files’ path;
' if it finds anyone it replaces it with a “-“.
' Afterwards, the code calls the WebpageToPDF sub using as parameters the URL
' address and the corresponding PDF file name that is provided in the main sheet (by the user).
    Dim arrSpecialChr() As String
    Dim dblSpCharFound  As Double
    Dim PDFFullPath     As String
    Dim i               As Long
    Dim j               As Integer

    'An array with special characters that cannot be used for naming a file.
    arrSpecialChr() = Split("\ / : * ? " & Chr$(34) & "  |", " ")

    'Set the default printer to PDFCreator (or whatever you like).
    SetDefaultPrinter "PDFCreator"

    'Convert the URLs to PDFs.
    On Error Resume Next

    'Check if the PDF name contains a special/illegal character.
    For j = LBound(arrSpecialChr) To UBound(arrSpecialChr)
        dblSpCharFound = VBA.InStr(1, PDFFullPath, arrSpecialChr(j))
        If dblSpCharFound > 0 Then
            PDFFullPath = VBA.Replace(PDFFullPath, arrSpecialChr(j), "-")
        End If
    Next j
    'PDFFullPath = PDFFolder & PDFPath

    On Error GoTo 0

    'Save the PDF files to the selected folder.
    Call WebpageToPDF(pageURL, PDFFullPath & ".pdf")

    'Inform the user that macro finished.
    MsgBox "Web page successfully saved as PDF!", vbInformation, "Done"

End Sub

Private Sub WebpageToPDF(pageURL As String, PDFPath As String)
'Creates a new web browser object, opens a selected URL and then prints to selected printer
'The API functions FindWindow and SetForegroundWindow are used in order to find the IE window
'and bring it to the foreground (above other windows).

   'The macro needs a reference to Windows Script Host Object Model Library, as well
   'as to the Microsoft Internet Controls Library in order to work.
   'From VBA editor go to Tools -> References -> add the two references.
   'Or you can find them at C:\Windows\system32\wshom.ocx and C:\Windows\system32\ieframe.dll.

    Dim WebBrowser   As InternetExplorer
    Dim StartTime    As Date
    Dim intRet       As Long

    'Create new web browser object, make it visible,
    'maximize the window and navigate to the desired url.
    Set WebBrowser = New InternetExplorer
    WebBrowser.Visible = True
    ShowWindow WebBrowser.hwnd, SW_MAXIMIZE
    WebBrowser.Navigate (pageURL)

    'Wait until the web page is fully loaded.
    Do
        DoEvents
    Loop Until WebBrowser.ReadyState = READYSTATE_COMPLETE

    'Check if the internet explorer window exists.
    StartTime = Now()
    Do Until Now() > StartTime + TimeValue("00:00:05")
        intRet = 0
        DoEvents
        'IEFrame is the class name for internet explorer.
        intRet = FindWindow("IEFrame", vbNullString)
        If intRet  0 Then Exit Do
    Loop

    'If the IE window exists, print the web page as PDF.
    If intRet  0 Then
        Call SetForegroundWindow(intRet)
        WebBrowser.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER
        Call PDFPrint(PDFPath)
        SetForegroundWindow (intRet)
    End If

    'Release the web browser object.
    WebBrowser.Quit
    Set WebBrowser = Nothing

End Sub

Private Sub PDFPrint(ByVal strPDFPath As String)
'!!!!!!!!!!!!!!!!!!!!!!
'In order to change the default name (and path) of the save as dialog,
'I used Spy++ in order to specify and edit the combo box
'that contains the file name.
'The sequence goes like this: Save PDF File As (main window) ? DUIViewWndClassName (first child) ? DirectUIHWND (second child) ? FloatNotifySink (third child) ? ComboBox ? Edit.
'Having found the Edit property of the combo box the SendMessage API is used to send the PDF file path.
'
'Well, here there is a tricky part: for some unknown reason if you pass the PDF path using
'directly the SendMessage function and then press the Save button (again, using SendMessage)
'the file is not saved with the desired name and at the desired path!
'The file is named by the URL (for example vba-macro-to-convert-) and is saved at the last folder
'you selected within IE window! Quite strange….

'I overcome this obstacle by doing a small trick: when I pass the PDF path in the combo box
'I use a space before the path. So in the combo box, the SendMessage function passes a string like
'" " & "C:\Users\???st??\Desktop\New folder\" & "Daily Schedule Charts.pdf" (notice the blank space before C).
'Then, I delete this space using the keybd_event API function.
'This function simulates a key press (here the delete button) and a key release.
'Why I did this? Well, because when I was experimenting (without using code)
'I saw that the PDF path changed only if there was a keyboard change.
'So, I tried to simulate this observation using VBA code.

'Having passed the PDF path successfully and pressed the Save button,
'then the macro checks if the printer has finished printing (i.e. creating the PDF file)
'by using the CheckPrinterStatus function.
'If the function returns "Idle" it means that the printing finished.

'Finally, since the Adobe Professional opens the file after finishing the printing,
'a combination of FindWindow and PostMessage API functions are used in order to find the PDF window and close it.
'!!!!!!!!!!!!!!!!!!!!!!

    'Prints a web page as PDF file using Adobe Professional.
    'API functions are used to specify the necessary windows while
    'a WMI function is used to check printer's status.

    Dim Ret                 As Long
    Dim ChildRet            As Long
    Dim ChildRet2           As Long
    Dim ChildRet3           As Long
    Dim comboRet            As Long
    Dim editRet             As Long
    Dim ChildSaveButton     As Long
    Dim PDFRet              As Long
    Dim PDFName             As String
    Dim StartTime           As Date

    'Find the main print window.
    StartTime = Now()
    Do Until Now() > StartTime + TimeValue("00:00:05")
        Ret = 0
        DoEvents
        Ret = FindWindow(vbNullString, "Save PDF File As")
        If Ret  0 Then Exit Do
    Loop

    If Ret  0 Then
        SetForegroundWindow (Ret)
        'Find the first child window.
        StartTime = Now()
        Do Until Now() > StartTime + TimeValue("00:00:05")
            ChildRet = 0
            DoEvents
            ChildRet = FindWindowEx(Ret, ByVal 0&, "DUIViewWndClassName", vbNullString)
            If ChildRet  0 Then Exit Do
        Loop

        If ChildRet  0 Then
            'Find the second child window.
            StartTime = Now()
            Do Until Now() > StartTime + TimeValue("00:00:05")
                ChildRet2 = 0
                DoEvents
                ChildRet2 = FindWindowEx(ChildRet, ByVal 0&, "DirectUIHWND", vbNullString)
                If ChildRet2  0 Then Exit Do
            Loop

            If ChildRet2  0 Then
                'Find the third child window.
                StartTime = Now()
                Do Until Now() > StartTime + TimeValue("00:00:05")
                    ChildRet3 = 0
                    DoEvents
                    ChildRet3 = FindWindowEx(ChildRet2, ByVal 0&, "FloatNotifySink", vbNullString)
                    If ChildRet3  0 Then Exit Do
                Loop

                If ChildRet3  0 Then
                    'Find the combobox that will be edited.
                    StartTime = Now()
                    Do Until Now() > StartTime + TimeValue("00:00:05")
                        comboRet = 0
                        DoEvents
                        comboRet = FindWindowEx(ChildRet3, ByVal 0&, "ComboBox", vbNullString)
                        If comboRet  0 Then Exit Do
                    Loop

                    If comboRet  0 Then
                        'Finally, find the "edit property" of the combobox.
                        StartTime = Now()
                        Do Until Now() > StartTime + TimeValue("00:00:05")
                            editRet = 0
                            DoEvents
                            editRet = FindWindowEx(comboRet, ByVal 0&, "Edit", vbNullString)
                            If editRet  0 Then Exit Do
                        Loop

                        'Add the PDF path to the file name combobox of the print window.
                        If editRet  0 Then
                            SendMessage editRet, WM_SETTEXT, 0&, ByVal " " & strPDFPath
                            keybd_event VK_DELETE, 0, 0, 0 'press delete
                            keybd_event VK_DELETE, 0, KEYEVENTF_KEYUP, 0 ' release delete

                            'Get the PDF file name from the full path.
                            On Error Resume Next
                            PDFName = Mid(strPDFPath, WorksheetFunction.Find("*", WorksheetFunction.Substitute(strPDFPath, "\", "*", Len(strPDFPath) _
                            - Len(WorksheetFunction.Substitute(strPDFPath, "\", "")))) + 1, Len(strPDFPath))
                            On Error GoTo 0

                            'Save/print the web page by pressing the save button of the print window.
                            Sleep 1000
                            ChildSaveButton = FindWindowEx(Ret, ByVal 0&, "Button", "&Save")
                            SendMessage ChildSaveButton, BM_CLICK, 0, 0

                            'Sometimes the printing delays, especially in large colorful web pages.
                            'Here the code checks printer status and if is idle it means that the
                            'printing has finished.
                            Do Until CheckPrinterStatus("Adobe PDF") = "Idle"
                                DoEvents
                                If CheckPrinterStatus("Adobe PDF") = "Error" Then Exit Do
                            Loop

                            'Since the Adobe Professional opens after finishing the printing, find
                            'the open PDF document and close it (using a post message).
                            StartTime = Now()
                            Do Until StartTime > StartTime + TimeValue("00:00:05")
                                PDFRet = 0
                                DoEvents
                                PDFRet = FindWindow(vbNullString, PDFName & " - Adobe Acrobat Pro")
                                If PDFRet  0 Then Exit Do
                            Loop
                            If PDFRet  0 Then
                                PostMessage PDFRet, WM_CLOSE, 0&, 0&
                            End If
                        End If
                    End If
                End If
            End If
        End If
   End If
End Sub

Private Sub OpenPDF(ByVal strPDFPath As String, ByVal strPageNumber As String, ByVal strZoomValue As String)
' Opens a PDF file to a specific page and with a specific zoom.
' API functions are used to specify the necessary windows
' and send the page and zoom info to the PDF reader window.

    Dim strPDFName                  As String
    Dim lParent                     As Long
    Dim lFirstChildWindow           As Long
    Dim lSecondChildFirstWindow     As Long
    Dim lSecondChildSecondWindow    As Long
    Dim dtStartTime               As Date

    'Check if the PDF path is correct.
    If FileExists(strPDFPath) = False Then
        MsgBox "The PDF path is incorect!", vbCritical, "Wrong path"
        Exit Sub
    End If

    'Get the PDF file name from the full path.
    On Error Resume Next
    strPDFName = Mid(strPDFPath, InStrRev(strPDFPath, "\") + 1, Len(strPDFPath))
    On Error GoTo 0

    'The following line depends on the apllication you are using.
    'For Word:
    'ThisDocument.FollowHyperlink strPDFPath, NewWindow:=True
    'For Power Point:
    'ActivePresentation.FollowHyperlink strPDFPath, NewWindow:=True
    'Note that both Word & Power Point pop up a security window asking
    'for access to the specified PDf file.
    'For Access:
    'Application.FollowHyperlink strPDFPath, NewWindow:=True
    'For Excel:
    ThisWorkbook.FollowHyperlink strPDFPath, NewWindow:=True
    'Find the handle of the main/parent window.
    dtStartTime = Now()
    Do Until Now() > dtStartTime + TimeValue("00:00:05")
        lParent = 0
        DoEvents
        'For Adobe Reader.
        'lParent = FindWindow("AcrobatSDIWindow", strPDFName & " - Adobe Reader")
        'For Adobe Professional.
        lParent = FindWindow("AcrobatSDIWindow", strPDFName & " - Adobe Acrobat Pro")
        If lParent  0 Then Exit Do
    Loop

    If lParent  0 Then

        'Bring parent window to the foreground (above other windows).
        SetForegroundWindow (lParent)

        'Find the handle of the first child window.
        dtStartTime = Now()
        Do Until Now() > dtStartTime + TimeValue("00:00:05")
            lFirstChildWindow = 0
            DoEvents
            lFirstChildWindow = FindWindowEx(lParent, ByVal 0&, vbNullString, "AVUICommandWidget")
            If lFirstChildWindow  0 Then Exit Do
        Loop

        'Find the handles of the two subsequent windows.
        If lFirstChildWindow  0 Then
            dtStartTime = Now()
            Do Until Now() > dtStartTime + TimeValue("00:00:05")
                lSecondChildFirstWindow = 0
                DoEvents
                lSecondChildFirstWindow = FindWindowEx(lFirstChildWindow, ByVal 0&, "Edit", vbNullString)
                If lSecondChildFirstWindow  0 Then Exit Do
            Loop

            If lSecondChildFirstWindow  0 Then

                'Send the zoom value to the corresponding window.
                SendMessage lSecondChildFirstWindow, WM_SETTEXT, 0&, ByVal strZoomValue
                PostMessage lSecondChildFirstWindow, WM_KEYDOWN, VK_RETURN, 0

                dtStartTime = Now()
                Do Until Now() > dtStartTime + TimeValue("00:00:05")
                    lSecondChildSecondWindow = 0
                    DoEvents
                    'Notice the difference in syntax between lSecondChildSecondWindow and lSecondChildFirstWindow.
                    'lSecondChildSecondWindow is the handle of the next child window after lSecondChildFirstWindow,
                    'while both windows have as parent window the lFirstChildWindow.
                    lSecondChildSecondWindow = FindWindowEx(lFirstChildWindow, lSecondChildFirstWindow, "Edit", vbNullString)
                    If lSecondChildSecondWindow  0 Then Exit Do
                Loop

                If lSecondChildSecondWindow  0 Then
                    'Send the page number to the corresponding window.
                    SendMessage lSecondChildSecondWindow, WM_SETTEXT, 0&, ByVal strPageNumber
                    PostMessage lSecondChildSecondWindow, WM_KEYDOWN, VK_RETURN, 0
                End If
            End If
        End If
    End If

End Sub

Private Function FileExists(strFilePath As String) As Boolean
'Checks if a file exists.

    On Error Resume Next
    If Not Dir(strFilePath, vbArchive) = vbNullString Then FileExists = True
    On Error GoTo 0

End Function

Private Function FolderExists(strFolderPath As String) As Boolean
'Checks if a folder exists.

   On Error Resume Next
   If Not Dir(strFolderPath, vbDirectory) = vbNullString Then FolderExists = True
   On Error GoTo 0

End Function

Private Function FolderSelection() As String
' Shows the folder picker dialog in order the user to select
' the folder in which the downloaded files will be saved.

    Dim FoldersPath     As String

    'Show the folder picker dialog.
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select a folder to save your files..."
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "You did't select a folder!", vbExclamation, "Canceled"
            Exit Function
        Else
            FoldersPath = .SelectedItems(1)
        End If
    End With

    'Pass the folder's path to the cell.
    FolderSelection = FoldersPath & "\"
End Function
API Viewer Window
Figure 2: The API Viewer window.
Folder Picker Dialog
Figure 3: The PDFFolderSelection sub results (folder picker dialog).
3. The URLToPDF constitutes the main procedure.  First, it checks the folder’s path that was selected in the previous step. If the folder’s path exists and is not blank it tries to find if there are any illegal characters in the PDF files’ path; if it finds anyone it replaces it with a “-“. Afterwards, the code calls the WebpageToPDF sub using as parameters the URL address and the corresponding PDF file name that is provided in the main sheet (by the user). 5. The WebpageToPDF creates a new web browser object, makes it visible, maximizes the browser window and navigates to the desired URL. If the IE window is visible it popups the print window. The API functions FindWindow and SetForegroundWindow are used in order to find the IE window and bring it to the foreground (above other windows). Then the code calls the PDFPrint procedure.
Webpage To PDF
Figure 4: WebpageToPDF sub results.
6. In order to change the default name (and path) of the save as dialog, I used Spy++ in order to specify and edit the combo box that contains the file name. The sequence goes like this: Save PDF File As (main window) → DUIViewWndClassName (first child) → DirectUIHWND (second child) → FloatNotifySink (third child) → ComboBox → Edit. Having found the Edit property of the combo box the SendMessage API is used to send the PDF file path.
Spyxx Window
Figure 5: Showing the hierarchy of Save As PDF window in Spy++.
Well, here there is a tricky part: for some unknown reason if you pass the PDF path using directly the SendMessage function and then press the Save button (again, using SendMessage) the file is not saved with the desired name and at the desired path! The file is named by the URL (for example vba-macro-to-convert-) and is saved at the last folder you selected within IE window! Quite strange…. I overcome this obstacle by doing a small trick: when I pass the PDF path in the combo box I use a space before the path. So in the combo box, the SendMessage function passes a string like “ C:\Users\Χρήστος\Desktop\New folder\ Daily Schedule Charts.pdf” (notice the blank space before C). Then, I delete this space using the keybd_event API function. This function simulates a key press (here the delete button) and a key release. Why I did this? Well, because when I was experimenting (without using code) I saw that the PDF path changed only if there was a keyboard change. So, I tried to simulate this observation using VBA code. Having passed the PDF path successfully and pressed the Save button, then the macro checks if the printer has finished printing (i.e. creating the PDF file) by using the CheckPrinterStatus function. If the function returns “Idle” it means that the printing finished. Finally, since the Adobe Professional opens the file after finishing the printing, a combination of FindWindow and PostMessage API functions are used in order to find the PDF window and close it.
    • Open PDF File With VBA
In comparison with my previous attempt the VBA code below doesn’t use the Adobe object system or the sendkeys method. Instead, a combination of various API functions is used in order to find and manipulate the page number and page zoom textboxes. The general idea behind this code can be divided in four steps:
 
  1. Check the file path and if is valid, use the FollowHyperlink method in order to open the PDF file.
  2. With the FindWindow API function find the window of Adobe Reader or Adobe Professional that contains the opened PDF file and bring it to foreground using the SetForegroundWindow API function.
  3. Find the subsequent child windows with the FindWindowEx API function.
  4. Use the SendMessage and PostMessage API functions in order to send the desired page number and window zoom value to the corresponding textboxes.
  • Windows Hierarchy In Adobe Reader-Professional
  • Similarly to my previous post, the Spy++ software was used in order to specify the windows hierarchy in Adobe Reader/Professional. The picture above shows the window tree of a sample PDF document.The VBA code in this post can be used with almost all the office programs. I have tested it with Access, Excel, Word and Power Point (both 2010 and 2003 versions) and works like charm. Since it doesn’t require any reference to Adobe library and no sendkeys are used is probably much easier to use and more reliable than my previous codes.
  VBA code The short video below demonstrates how the above VBA code can be used with  Access, Word, Power Point and Excel 2010.
[youtube https://www.youtube.com/watch?v=xadHPW2BYS0]
 

VBA RegExp (Regular Expressions)

Regular expressions are used for Pattern Matching. Maybe one of the best answers I’ve seen in StackOverflow is this about Regular expressions, from user Portland Runner, but the topic can get as tricky as this answer show, epic!. Following are a series of procedures to perform Regular Expressions operations. You can work with “Early binding” (set a reference to Microsoft VBScript Regular Expressions 5.5) or with “Late binding” through objects.

Early binding

  • Press ALT+F11 to access to the VBE.
  • Select “Tools” from the top menu.
  • Select “References”, and  check the box of “Microsoft VBScript Regular Expressions 5.5” to include in your workbook.
  • Click “OK”

Patterns

Basic definitions: - Range.
  • E.g. a-z matches an lower case letters from a to z
  • E.g. 0-5 matches any number from 0 to 5
[] Match exactly one of the objects inside these brackets.
  • E.g. [a] matches the letter a
  • E.g. [abc] matches a single letter which can be a, b or c
  • E.g. [a-z] matches any single lower case letter of the alphabet.
() Groups different matches for return purposes. See examples below. {} Multiplier for repeated copies of pattern defined before it.
  • E.g. [a]{2} matches two consecutive lower case letter a: aa
  • E.g. [a]{1,3} matches at least one and up to three lower case letter a, aa, aaa
+ Match at least one, or more, of the pattern defined before it.
  • E.g. a+ will match consecutive a’s a, aa, aaa, and so on
? Match zero or one of the pattern defined before it.
  • E.g. Pattern may or may not be present but can only be matched one time.
  • E.g. [a-z]? matches empty string or any single lower case letter.
* Match zero or more of the pattern defined before it. – E.g. Wildcard for pattern that may or may not be present. – E.g. [a-z]* matches empty string or string of lower case letters. . Matches any character except newline \n
  • E.g. a. Matches a two character string starting with a and ending with anything except \n
| OR operator
  • E.g. a|b means either a or b can be matched.
  • E.g. red|white|orange matches exactly one of the colors.
^ NOT operator
  • E.g. [^0-9] character can not contain a number
  • E.g. [^aA] character can not be lower case a or upper case A
\ Escapes special character that follows (overrides above behavior)
  • E.g. \., \\, \(, \?, \$, \^

Anchoring Patterns: ^ Match must occur at start of string
  • E.g. ^a First character must be lower case letter a
  • E.g. ^[0-9] First character must be a number.
$ Match must occur at end of string
  • E.g. a$ Last character must be lower case letter a

Precedence table:
Order  Name                Representation
1      Parentheses         ( )
2      Multipliers         ? + * {m,n} {m, n}?
3      Sequence & Anchors  abc ^ $
4      Alternation         |

Predefined Character Abbreviations:
abr    same as       meaning
\d     [0-9]         Any single digit
\D     [^0-9]        Any single character that's not a digit
\w     [a-zA-Z0-9_]  Any word character
\W     [^a-zA-Z0-9_] Any non-word character
\s     [ \r\t\n\f]   Any space character
\S     [^ \r\t\n\f]  Any non-space character
\n     [\n]          New line

Example 1: Run as macro The following example macro looks at the value in cell A1 to see if the first 1 or 2 characters are digits. If so, they are removed and the rest of the string is displayed. If not, then a box appears telling you that no match is found. Cell A1 values of 12abc will return abc, value of 1abc will return abc, value of abc123 will return “Not Matched” because the digits were not at the start of the string.
Private Sub simpleRegex()
    Dim strPattern As String: strPattern = "^[0-9]{1,2}"
    Dim strReplace As String: strReplace = ""
    'Dim regEx As New RegExp
    Dim regEx As Object: Set regEx = CreateObject("VBScript.RegExp")
    Dim strInput As String
    Dim Myrange As Excel.Range

    Set Myrange = ActiveSheet.Range("A1")

    If strPattern  "" Then
        strInput = Myrange.Value

        With regEx
            .Global = True
            .MultiLine = True
            .IgnoreCase = False
            .Pattern = strPattern
        End With

        If regEx.Test(strInput) Then
            MsgBox (regEx.Replace(strInput, strReplace))
        Else
            MsgBox ("Not matched")
        End If
    End If
    Set regEx = Nothing
End Sub

Example 2: Run as an in-cell function This example is the same as example 1 but is setup to run as an in-cell function. To use, change the code to this:
Function simpleCellRegex(Myrange As Excel.Range) As String
    'Dim regEx As New RegExp
    Dim regEx As Object: Set regEx = CreateObject("VBScript.RegExp")
    Dim strPattern As String
    Dim strInput As String
    Dim strReplace As String
    Dim strOutput As String


    strPattern = "^[0-9]{1,3}"

    If strPattern  "" Then
        strInput = Myrange.Value
        strReplace = ""

        With regEx
            .Global = True
            .MultiLine = True
            .IgnoreCase = False
            .Pattern = strPattern
        End With

        If regEx.test(strInput) Then
            simpleCellRegex = regEx.Replace(strInput, strReplace)
        Else
            simpleCellRegex = "Not matched"
        End If
    End If
    Set regEx = Nothing
End Function
Place your strings (“12abc”) in cell A1. Enter this formula =simpleCellRegex(A1) in cell B1 and the result will be “abc”. q3RRC
Example 3: Loop Through Range This example is the same as example 1 but loops through a range of cells.
Private Sub simpleRegex()
    Dim strPattern As String: strPattern = "^[0-9]{1,2}"
    Dim strReplace As String: strReplace = ""
    'Dim regEx As New RegExp
    Dim regEx As Object: Set regEx = CreateObject("VBScript.RegExp")
    Dim strInput As String
    Dim Myrange As Excel.Range

    Set Myrange = ActiveSheet.Range("A1:A5")

    For Each cell In Myrange
        If strPattern  "" Then
            strInput = cell.Value

            With regEx
                .Global = True
                .MultiLine = True
                .IgnoreCase = False
                .Pattern = strPattern
            End With

            If regEx.Test(strInput) Then
                MsgBox (regEx.Replace(strInput, strReplace))
            Else
                MsgBox ("Not matched")
            End If
        End If
    Next
    Set regEx = Nothing
End Sub

Example 4: Splitting apart different patterns This example loops through a range (A1, A2 & A3) and looks for a string starting with three digits followed by a single alpha character and then 4 numeric digits. The output splits apart the pattern matches into adjacent cells by using the (). $1 represents the first pattern matched within the first set of ().
Private Sub splitUpRegexPattern()
    'Dim regEx As New RegExp
    Dim regEx As Object: Set regEx = CreateObject("VBScript.RegExp")
    Dim strPattern As String
    Dim strInput As String
    Dim Myrange As Excel.Range

    Set Myrange = ActiveSheet.Range("A1:A3")

    For Each C In Myrange
        strPattern = "(^[0-9]{3})([a-zA-Z])([0-9]{4})"

        If strPattern  "" Then
            strInput = C.Value

            With regEx
                .Global = True
                .MultiLine = True
                .IgnoreCase = False
                .Pattern = strPattern
            End With

            If regEx.test(strInput) Then
                C.Offset(0, 1) = regEx.Replace(strInput, "$1")
                C.Offset(0, 2) = regEx.Replace(strInput, "$2")
                C.Offset(0, 3) = regEx.Replace(strInput, "$3")
            Else
                C.Offset(0, 1) = "(Not matched)"
            End If
        End If
    Next
    Set regEx = Nothing
End Sub
Results: 9eCZ5
Additional Pattern Examples
String   Regex Pattern                  Explanation
a1aaa    [a-zA-Z][0-9][a-zA-Z]{3}       Single alpha, single digit, three alpha characters
a1aaa    [a-zA-Z]?[0-9][a-zA-Z]{3}      May or may not have preceeding alpha character
a1aaa    [a-zA-Z][0-9][a-zA-Z]{0,3}     Single alpha, single digit, 0 to 3 alpha characters
a1aaa    [a-zA-Z][0-9][a-zA-Z]*         Single alpha, single digit, followed by any number of alpha characters

</i8>    \<\/[a-zA-Z][0-9]\>            Exact non-word character except any single alpha followed by any single digit
Finally, there is this version of an UDF to use Regular Expressions, on the same post answer as the one above:
Function regex(strInput As String, matchPattern As String, Optional ByVal outputPattern As String = "$0") As Variant
    Dim inputRegexObj As New VBScript_RegExp_55.RegExp, outputRegexObj As New VBScript_RegExp_55.RegExp, outReplaceRegexObj As New VBScript_RegExp_55.RegExp
    Dim inputMatches As Object, replaceMatches As Object, replaceMatch As Object
    Dim replaceNumber As Integer

    With inputRegexObj
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = matchPattern
    End With
    With outputRegexObj
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = "\$(\d+)"
    End With
    With outReplaceRegexObj
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
    End With

    Set inputMatches = inputRegexObj.Execute(strInput)
    If inputMatches.Count = 0 Then
        regex = False
    Else
        Set replaceMatches = outputRegexObj.Execute(outputPattern)
        For Each replaceMatch In replaceMatches
            replaceNumber = replaceMatch.SubMatches(0)
            outReplaceRegexObj.Pattern = "\$" & replaceNumber

            If replaceNumber = 0 Then
                outputPattern = outReplaceRegexObj.Replace(outputPattern, inputMatches(0).Value)
            Else
                If replaceNumber > inputMatches(0).SubMatches.Count Then
                    'regex = "A to high $ tag found. Largest allowed is $" & inputMatches(0).SubMatches.Count & "."
                    regex = CVErr(xlErrValue)
                    Exit Function
                Else
                    outputPattern = outReplaceRegexObj.Replace(outputPattern, inputMatches(0).SubMatches(replaceNumber - 1))
                End If
            End If
        Next
        regex = outputPattern
    End If
End Function
[/sourcecode]