VBA – Remove HTML Tags from a String

I needed to clean some webpage texts for a private project I was working on and created the following function. Today, in a forum question, the subject resurfaced so I dug up my function and am posting it here should it might serve someone else.

So here is a simple function utilizing Regular Expressions to remove/sanitize/extract HTML Tags from the passed string. So you get returned the text and nothing else.

'---------------------------------------------------------------------------------------
' Procedure : RemoveHTML
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Remove any HTML tags and/or comments from a string
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sString   : String to sanitize (remove HTML tags from)
'
' Usage:
' ~~~~~~
' RemoveHTML("<html><b>And</b><!-- some comment --> <p>then<br/> some</p></html>")
'           Returns: And then some
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2009-Aug-26             Initial Release
' 2         2009-Oct-30             Changed pattern to include comments
'---------------------------------------------------------------------------------------
Function RemoveHTML(sString As String) As String
    On Error GoTo Error_Handler
    Dim oRegEx          As Object
 
    Set oRegEx = CreateObject("vbscript.regexp")
 
    With oRegEx
        'Patterns see: http://regexlib.com/Search.aspx?k=html%20tags
        '.Pattern = "<[^>]+>"    'basic html pattern
        .Pattern = "<!*[^<>]*>"    'html tags and comments
        .Global = True
        .IgnoreCase = True
        .MultiLine = True
    End With
 
    RemoveHTML = oRegEx.Replace(sString, "")
 
Error_Handler_Exit:
    On Error Resume Next
    Set oRegEx = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: RemoveHTML" & vbCrLf & _
           "Error Description: " & Err.Description, _
           vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

VBA – Split/Break a Camel Case String

I was having a recent discussion with a fellow MVP and came across a function I developed a while back and thought it could be useful to others.  Below is a very simple function which uses a RegEx pattern to break apart a Came Case string into a legible string.

'---------------------------------------------------------------------------------------
' Procedure : SplitCamelCase
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Split/Break a Camel Case string
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sString   : Camel Case string to break/split
' sDelim    : Character to use as a spcaer, if omitted will use a space
'
' Usage:
' ~~~~~~
' ?SplitCamelCase("SplitCamelCase")
'       Returns Split Camel Case
' ?SplitCamelCase("SplitCamelCase", "_")
'       Returns Split_Camel_Case
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2008-May-03             Initial Release
'---------------------------------------------------------------------------------------
Function SplitCamelCase(sString As String, Optional sDelim As String = " ") As String
On Error GoTo Error_Handler
    Dim oRegEx          As Object
 
    Set oRegEx = CreateObject("vbscript.regexp")
    With oRegEx
        .Pattern = "([a-z](?=[A-Z])|[A-Z](?=[A-Z][a-z]))"
        .Global = True
        SplitCamelCase = .Replace(sString, "$1" & sDelim)
    End With
 
Error_Handler_Exit:
    On Error Resume Next
    Set oRegEx = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
            "Error Number: " & Err.Number & vbCrLf & _
            "Error Source: SplitCamelCase" & vbCrLf & _
            "Error Description: " & Err.Description, _
            vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Trusted Location Editor by CARDA Consultants Inc.

Tired of battling with Microsoft’s never ending changing layouts, navigating through an endless maze of menus, and the fact that the Trust Center is inaccessible on the runtime version of MS Access, I recently created the Trusted Location Editor. A very lightweight application which put the user back in the driver’s seat to manage all the various MS Office application Trusted Locations from one single screen! In essence, what Microsoft should have provided users 8 years ago!

Simplicity was the order of the day, so everything is straightforward and no more than 1 click of a button away!

Trusted Location Editor - Overview

For all the details on this application, please use the following link:

MS Office Trusted Location Editor

VBA – CDO Mail

Although I often refer people to use CDO mail and have briefly discussed it in prior postings, I never gave examples. Today that changes!

So what exactly is CDO mail and when is it useful?

CDO mail is one of many technique available to developer to send e-mails.

If you are an MS Access developer you are surely aware of the SendObject method, but it will only allow one attachment and that attahcment has to be an Access object (Not an external file).

Another very common approach is to use Outlook automation, but with new security impositions by Microsoft it has become unreliable and now requires workarounds. Furthermore, after a recent discussion with fellow MVPs, we find out that having an outdated virus definition can stop longstanding code from working! As such, although powerful, outlook automation simply is not reliable for true production. For production tools, one must then look at integrating Outlook Redemption, but the down side to this solution is that it requires registering a COM library for it to work.

Which brings us to CDO Mail!
CDO Mail is a technique that binds you directly to your e-mail server to send out email(s).

Pros

  • No e-mail client (outlook, thunderbird, …) need be installed
    • Hence you bypass any e-mail client limitations and/or security restrictions
  • Permits multiple attachments to be included
  • Permits external documents as attachments
  • Accepts both plain text and HTML formatted content
  • Can be used in any programs which uses VBA (MS Access, Excel, Word, PowerPoint, MS Project, …)
  • Can even be used in VBScript

Cons

  • Requires knowledge of all the server settings (port, username, password, authentication, …)
  • Does not keep a copy of sent e-mails so CCing or BCCing yourself becomes useful for archive pruposes
  • Does not permit attaching database objects directly, but you can export them or print them as PDFs and attach those

Below is a sample CDO Mail function

Const cdoSendUsingPickup = 1 'Send message using the local SMTP service pickup directory.
Const cdoSendUsingPort = 2 'Send the message using the network (SMTP over the network).

Const cdoAnonymous = 0 'Do not authenticate
Const cdoBasic = 1 'basic (clear-text) authentication
Const cdoNTLM = 2 'NTLM

Function SendCDOMail(sTo As String, sSubject As String, sBody As String, _
                     Optional sBCC As Variant, Optional AttachmentPath As Variant)
    On Error GoTo Error_Handler
    Dim objCDOMsg       As Object
 
    Set objCDOMsg = CreateObject("CDO.Message")
 
    'CDO Configuration
    With objCDOMsg.Configuration.Fields
        '
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
        'Server port (typically 25, 587)
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        'SMTP server IP or Name
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.hitterslongrun.com"
        'Type of authentication, NONE, Basic (Base64 encoded), NTLM
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
        'SMTP Account User ID
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "accounts@hitterslongrun.com"
        'SMTP Account Password
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "Uhdje!@@0#"
        'Use SSL for the connection (False or True)
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
        .Update
    End With
 
    'CDO Message
    objCDOMsg.Subject = sSubject
    objCDOMsg.From = "accounts@hitterslongrun.com"
    objCDOMsg.To = sTo
    objCDOMsg.TextBody = sBody
    ' Add attachments to the message.
    If Not IsMissing(AttachmentPath) Then
        If IsArray(AttachmentPath) Then
            For i = LBound(AttachmentPath) To UBound(AttachmentPath)
                If AttachmentPath(i) <> "" And AttachmentPath(i) <> "False" Then
                    objCDOMsg.AddAttachment AttachmentPath(i)
                End If
            Next i
        Else
            If AttachmentPath <> "" And AttachmentPath(i) <> "False" Then
                objCDOMsg.AddAttachmentAttachmentPath
            End If
        End If
    End If
    objCDOMsg.Send
 
Error_Handler_Exit:
    On Error Resume Next
    Set objCDOMsg = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf &amp; _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: SendCDOMail" & vbCrLf & _
           "Error Description: " & Err.Description, _
           vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Now that we have a function to call, we can now send out an e-mail by making a single call to the function along the lines of:

Call SendCDOMail("RecipientEmail", "Subject", "EmailBody", , array("C:\Users\Test\Documents\sample.pdf", "C:\Users\Test\Documents\ballons.gif"))

Other references on CDO Mail

Sending mail from Excel with CDO
VBScript To Send Email Using CDO ‘Information directly applies to VBA as well

MS Access List Table Indexes

Once again, trying to help someone in a forum (see Brent Spaulding’s tweak to my code), I quickly put together the following to enumerate a list of indexes for a given table.

'---------------------------------------------------------------------------------------
' Procedure : ListIndexes
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : List the names of the indexes in the specified table
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sTbl      : Name of the table to list the names of the Indexes from
'
' Usage:
' ~~~~~~
' Call ListIndexes("tbl_Appointments")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2014-Nov-20                 Initial Release
'---------------------------------------------------------------------------------------
Function ListTblIndexes(sTbl As String)
On Error GoTo Error_Handler
    Dim db              As DAO.Database
    Dim tdf             As TableDef
    Dim myIndex         As Index
 
    Set db = CurrentDb
    Set tdf = db.TableDefs(sTbl)
 
    For Each myIndex In tdf.Indexes
        Debug.Print myIndex.Name
    Next
 
Error_Handler_Exit:
    On Error Resume Next
    Set tdf = Nothing
    Set db = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
            "Error Number: " & Err.Number & vbCrLf & _
            "Error Source: ListTblIndexes" & vbCrLf & _
            "Error Description: " & Err.Description, _
            vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Enumerate a List of Open but Hidden Forms

Once again, in trying to help someone in an Access forum, I came up with the following procedure(s) to be able to identify currently open, but hidden forms.

Option 1 – Print the results to the immediate window

'---------------------------------------------------------------------------------------
' Procedure : ListHiddenOpenFrms
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Generate a list of current open, but hidden forms and print their names to
'             the immediate window.
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Usage:
' ~~~~~~
' Call ListHiddenOpenFrms
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2014-Nov-19                 Initial Release
'---------------------------------------------------------------------------------------
Function ListHiddenOpenFrms()
On Error GoTo Error_Handler
    Dim DbF     As Form
    Dim DbO     As Object
 
    Set DbO = Application.Forms 'Collection of all the open forms
    
    For Each DbF In DbO    'Loop all the forms
        If DbF.Visible = False Then
            Debug.Print DbF.Name
        End If
    Next DbF
 
Error_Handler_Exit:
    On Error Resume Next
    Set DbF = Nothing
    Set DbO = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
            "Error Number: " & Err.Number & vbCrLf & _
            "Error Source: ListHiddenOpenFrms" & vbCrLf & _
            "Error Description: " & Err.Description, _
            vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Option 2 – Return a delimited listing which can be used elsewhere

'---------------------------------------------------------------------------------------
' Procedure : ListHiddenOpenFrms
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Generate a list of current open, but hidden forms and return a delimited listing which 
'             can be used elsewhere.
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Usage:
' ~~~~~~
' Call ListHiddenOpenFrms
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2014-Nov-19                 Initial Release
'---------------------------------------------------------------------------------------
Function ListHiddenOpenFrms()
On Error GoTo Error_Handler
    Dim DbF     As Form
    Dim DbO     As Object
    Dim Frms   As Variant
 
    Set DbO = Application.Forms 'Collection of all the open forms
    
    For Each DbF In DbO    'Loop all the forms
        If DbF.Visible = False Then
            Frms = Frms & ";" & DbF.Name
        End If
    Next DbF
 
    If Len(Frms) > 0 Then
        Frms = Right(Frms, Len(Frms) - 1)   'Truncate initial ;
    End If
 
    ListHiddenOpenFrms = Frms
 
Error_Handler_Exit:
    On Error Resume Next
    Set DbF = Nothing
    Set DbO = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
            "Error Number: " & Err.Number & vbCrLf & _
            "Error Source: ListHiddenOpenFrms" & vbCrLf & _
            "Error Description: " & Err.Description, _
            vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Hopefully this can help someone else out.

CreateObject(“Outlook.Application”) Does Not Work, Now What?

As most developers know, when automating MS Office applications you always start by binding to an existing instance, or creating a new instance if one is not already running. As such, you’d commonly use something like:

    Dim oExcel          As Object
 
    On Error Resume Next
    Set oExcel = GetObject(, "Excel.Application")    'Bind to existing instance of Excel

    If Err.Number <> 0 Then    'Could not get instance of Excel, so create a new one
        Err.Clear
        On Error GoTo Error_Handler
        Set oExcel = CreateObject("excel.application")
    End If
    On Error GoTo Error_Handler

Now for Excel, Word, PowerPoint, … this works beautifully. However, if you wish to automate Outlook, you will quickly realize that this approach does not work!

Below is my solution to this problem.

'---------------------------------------------------------------------------------------
' Procedure : StartOutlook
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Demonstration of how one can start outlook if it isn't already started
'             considering CreateObject("Outlook.Application") not longer works!
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Usage:
' ~~~~~~
'
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2014-Oct-31                 Initial Release
'---------------------------------------------------------------------------------------
Function StartOutlook()
    On Error GoTo Error_Handler
    Dim oOutlook        As Object
    Dim sAPPPath        As String
 
    If IsAppRunning("Outlook.Application") = True Then    'Outlook was already running
        Set oOutlook = GetObject(, "Outlook.Application")    'Bind to existing instance of Outlook
    Else    'Could not get instance of Outlook, so create a new one
        sAPPPath = GetAppExePath("outlook.exe")    'determine outlook's installation path
        Shell (sAPPPath)    'start outlook
        Do While Not IsAppRunning("Outlook.Application")
            DoEvents
        Loop
        Set oOutlook = GetObject(, "Outlook.Application")    'Bind to existing instance of Outlook
    End If
 
    '    MsgBox "Outlook Should be running now, let's do something"
    Const olMailItem = 0
    Dim oOutlookMsg     As Object
    Set oOutlookMsg = oOutlook.CreateItem(olMailItem)    'Start a new e-mail message
    oOutlookMsg.Display    'Show the message to the user

Error_Handler_Exit:
    On Error Resume Next
    Set oOutlook = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: StartOutlook" & vbCrLf & _
           "Error Description: " & Err.Description _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function
 
'---------------------------------------------------------------------------------------
' Procedure : IsAppRunning
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Determine is an App is running or not
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sApp      : GetObject Application to verify if it is running or not
'
' Usage:
' ~~~~~~
' IsAppRunning("Outlook.Application")
' IsAppRunning("Excel.Application")
' IsAppRunning("Word.Application")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2014-Oct-31                 Initial Release
'---------------------------------------------------------------------------------------
Function IsAppRunning(sApp As String) As Boolean
    On Error GoTo Error_Handler
    Dim oApp            As Object
 
    Set oApp = GetObject(, sApp)
    IsAppRunning = True
 
Error_Handler_Exit:
    On Error Resume Next
    Set oApp = Nothing
    Exit Function
 
Error_Handler:
    Resume Error_Handler_Exit
End Function
 
'---------------------------------------------------------------------------------------
' Procedure : GetAppExePath
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Determine the path for a given exe installed on the local computer
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sEXEName  : Name of the exe to locate
'
' Usage:
' ~~~~~~
' Call GetAppExePath("msaccess.exe")
' GetAppExePath("firefox.exe")
' GetAppExePath("outlook.exe")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2014-Oct-31                 Initial Release
'---------------------------------------------------------------------------------------
Function GetAppExePath(ByVal sExeName As String) As String
    On Error GoTo Error_Handler
    Dim WSHShell        As Object
 
    Set WSHShell = CreateObject("Wscript.Shell")
    GetAppExePath = WSHShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\" & sExeName & "\")
 
Error_Handler_Exit:
    On Error Resume Next
    Set WSHShell = Nothing
    Exit Function
 
Error_Handler:
    If Err.Number = -2147024894 Then
        'Cannot locate requested exe????
    Else
        MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
               "Error Number: " & Err.Number & vbCrLf & _
               "Error Source: " & sModName & "/GetAppExePath" & vbCrLf & _
               "Error Description: " & Err.Description, _
               vbCritical, "An Error has Occured!"
    End If
    Resume Error_Handler_Exit
End Function

Other Resources:

Ron de Bruin has another solution to this problem, see: Test if Outlook is open and open Outlook with VBA

MS Access – VBA – Change the Application Printer to a Given Printer Name

Once again trying to help someone in a thread who needed to set the Application Printer to a specific printer name. Now the issue being, and if you are here you are already ware of the problem, is that when you try and set the application printer it is expecting the printer No, not its name! So what is one to do? Below is a simple function which basically loops through the printer collection and checks for the printer name being called, and once it find that one, it sets the application printer to that printer.

'---------------------------------------------------------------------------------------
' Procedure : SwicthAppPrinter
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Change the application printer
' Copyright : The following may be altered and reused as you wish so long as the
'             copyright notice is left unchanged (including Author, Website and
'             Copyright).  It may not be sold/resold or reposted on other sites (links
'             back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sPinterName   : Name of the printer to set the application to use by default
'
' Usage:
' ~~~~~~
' Call SwicthAppPrinter("Snagit 10")
' Call SwicthAppPrinter("Brother MFC-240C")
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2014-Oct-23                 Initial Release
'---------------------------------------------------------------------------------------
Function SwicthAppPrinter(sPinterName As String)
On Error GoTo Error_Handler
    Dim prtAvailPrinters As Printer
 
    For Each prtAvailPrinters In Application.Printers
        If prtAvailPrinters.DeviceName = sPinterName Then
            Set Application.Printer = prtAvailPrinters
            Exit For
        End If
    Next prtAvailPrinters
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
            "Error Number: " & Err.Number & vbCrLf & _
            "Error Source: SwicthAppPrinter" & vbCrLf & _
            "Error Description: " & Err.Description, _
            vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

It is a simple workaround to Microsoft not having given us any direct way to set the application printer to a given printer name, which let’s be serious, it the way we need to work! Who knows what No a printer is from one system to another. Setting a printer based on an arbitrary No is moronic! Yes I said it!!!

I should also specify that it would probably be a good idea to initially capture the active default printer and set it back once you are done. As such, you can determine the active default printer with a couple simple lines of code:

Dim sDefaultPrnt As Printer
Set sDefaultPrnt = Application.Printer

Other Resources:

If you are looking for more printer functions, pere_de_chipstick was kind enough to share some of his code in the UtterAccess Code Archive, see:
Select Printers, Configuration, Paper Sizes And Paper Bins For Reports, Any Version