Posts tagged ‘MS Word VBA’

May 14th, 2012

VBA – Read File into Memory

The following function enable you to read in, for instance a text file, into memory to use within your routines.

'---------------------------------------------------------------------------------------
' Procedure : ReadFile
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Faster way to read text file all in RAM rather than line by line
' 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:
' ~~~~~~~~~~~~~~~~
' strFile - name of the file that is to be read
'
' Usage Example:
' ~~~~~~~~~~~~~~~~
' MyTxt = ReadText("c:\tmp\test.txt")
' MyTxt = ReadText("c:\tmp\test.sql")
' MyTxt = ReadText("c:\tmp\test.csv")
'---------------------------------------------------------------------------------------
Function ReadFile(ByVal strFile As String) As String
On Error GoTo Error_Handler
    Dim FileNumber  As Integer
    Dim sFile       As String 'Variable contain file content

    'If FileExist(strFile) = False Then
    '    MsgBox "The specified file could not be found!"
    '    Exit Function
    'End If
    
    FileNumber = FreeFile
    Open strFile For Binary Access Read As FileNumber
    sFile = Space(LOF(FileNumber))
    Get #FileNumber, , sFile
    Close FileNumber
 
    ReadFile = sFile
 
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: ReadFile" & vbCrLf & _
            "Error Description: " & Err.Description, _
            vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

c

May 14th, 2012

MS Access – VBA – Convert Excel XLS to CSV

I was asked in a support forum how to convert an Excel *.xls, *.xlsx file to *.csv format. I didn’t readily have an answer so I created a custom function to help the user out. So here are the fruits on my labors should it help someone else out. What is also nice about the way it is written, is that it will run in any MS Office application (MS Access, MS Word, MS PowerPoint, MS Outlook, …) without requiring any modifications (copy & paste, that’s it)!

'---------------------------------------------------------------------------------------
' Procedure : ConvertXls2CSV
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Converts a standard Excel file to csv format
' Requirements: Requires MS Excel be installed
'               Uses late binding, so no libraries need be declared
' 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:
' ~~~~~~~~~~~~~~~~
' sXlsFile  : Fully qualified path and filename with extension of the Excel workbook
'
' Usage:
' ~~~~~~
' ConvertXls2CSV "C:\Users\Daniel\Desktop\Contact_E-mail listing.xls"
'       Will output a file C:\Users\Daniel\Desktop\Contact_E-mail listing.csv
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2012-May-11             Initial Release - Answer to forum question
'---------------------------------------------------------------------------------------
Function ConvertXls2CSV(sXlsFile As String)
    On Error Resume Next
    Dim oExcel          As Object
    Dim oExcelWrkBk     As Object
    Dim bExcelOpened    As Boolean    'Was Excel already open or not
    'Review 'XlFileFormat Enumeration' for more formats
    Const xlCSVWindows = 23 'Windows CSV Format
    Const xlCSV = 6 'CSV
    Const xlCSVMac = 22 'Macintosh CSV
    Const xlCSVMSDOS = 24 'MSDOS CSV

    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")
        bExcelOpened = False
    Else    'Excel was already running
        bExcelOpened = True
    End If
 
    On Error GoTo Error_Handler
    oExcel.ScreenUpdating = False
    oExcel.Visible = False   'Keep Excel hidden from the user
    oExcel.Application.DisplayAlerts = False
 
    Set oExcelWrkBk = oExcel.Workbooks.Open(sXlsFile)
    'Note: you may wish to change the file format constant for another type declared
    '      above based on your usage/needs in the following line.
    oExcelWrkBk.SaveAs Left(sXlsFile, InStrRev(sXlsFile, ".")) & "csv", xlCSVWindows
    oExcelWrkBk.Close False
 
    If bExcelOpened = False Then
        oExcel.Quit
    End If
 
Error_Handler_Exit:
    On Error Resume Next
    Set oExcelWrkBk = Nothing
    Set oExcel = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
            "Error Number: " & Err.Number & vbCrLf & _
            "Error Source: ConvertXls2CSV" & vbCrLf & _
            "Error Description: " & Err.Description, _
            vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Now this could be further improved by extending the error handling further to trap specific errors such as 1004 – file not found, etc… but it definitely illustrates the basic principle in using late binding to utilize Excel to open the file and convert it to *.csv format.

I hope this helps.

September 16th, 2011

VBA – Determine if a Folder/Directory Exists or Not

It can often come handy to be able to quick determine if a Folder/Directory exists or not. Below is a function I created some time ago to do exactly that.

'---------------------------------------------------------------------------------------
' Procedure : FolderExist
' DateTime  : 2009-Oct-02 13:51
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Test for the existance of a Folder/Directory
' 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:
' ~~~~~~~~~~~~~~~~
' sFolder - Full path of the folder to be tested for
'---------------------------------------------------------------------------------------
Function FolderExist(sFolder As String) As Boolean
On Error GoTo Error_Handler
 
    If sFolder = vbnullsring Then GoTo Error_Handler_Exit
    If Dir(sFolder, vbDirectory) <> vbNullString Then
        FolderExist = True
    End If
 
Error_Handler_Exit:
    On Error Resume Next
    Exit Function
 
Error_Handler:
    If Err.Number &lt;&gt; 52 Then
        MsgBox "The following error has occured" &amp; vbCrLf &amp; vbCrLf &amp; _
           "Error Number: " &amp; Err.Number &amp; vbCrLf &amp; _
           "Error Source: FolderExist" &amp; vbCrLf &amp; _
           "Error Description: " &amp; Err.Description, vbCritical, "An Error has Occured
    End If
    Resume Error_Handler_Exit
End Function
September 15th, 2011

VBA – Create Directory Structure/Create Multiple Directories/Create Nested Directories

One of he most common methods for creating directories/folders in VBA is to use the MkDir statement. For instance:

MkDir "C:\databases\"

One quickly learns the limitations of this technique the minute they have to create a directory structure with multiple sub-folders. MkDir can only create 1 directory at a time and cannot create a sub-directory. Hence, assuming that C:\databases does not already exist, the following would not work and will return an error!

MkDir "C:\databases\msaccess\"

If you absolutely want to create such a structure using the MkDir statement you’d have to do so using 2 MkDir statement. For instance:

MkDir "C:\databases\"
MkDir "C:\databases\msaccess\"

Now if you need to merely create 1 or 2 sub-folder MkDir may still be acceptable, but there are cases where this is simply impracticle and another solution needs to be found. Well, I found two possible solutions!

One possible approach can be found at Creating Nested Directories.

The second I found searching through the net and I no longer know the original source of the code (if someone knows e-mail me and I will put credit where it is due). It is a simple API which can create multiple directories in 1 call.

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
 
Public Sub MakeFullDir(strPath As String)
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\" 'Optional depending upon intent
    MakeSureDirectoryPathExists strPath
End Sub

Another possible solution, if someone wanted to tinker a little would be to merely parse the path into it’s directories and the using the DIR statement evaluate and create the directories where need be. Shouldn’t be that hard, but I haven’t taken the time to do this (maybe one day I will and will update this post then).

Okay, so it bothered me and I had to quickly put something together to stop my brain from churning! Below is what I pieced together rapidly. It is missing proper variable definitions (DIM statements) and error handling, but from my very brief testing, it does appear to work and doesn’t require any APIs! 100% VBA.

Public Sub MyMkDir(sPath As String)
    Dim iStart          As Integer
    Dim aDirs           As Variant
    Dim sCurDir         As String
    Dim i               As Integer
 
    If sPath <> "" Then
        aDirs = Split(sPath, "\")
        If Left(sPath, 2) = "\\" Then
            iStart = 3
        Else
            iStart = 1
        End If
 
        sCurDir = Left(sPath, InStr(iStart, sPath, "\"))
 
        For i = iStart To UBound(aDirs)
            sCurDir = sCurDir & aDirs(i) & "\"
            If Dir(sCurDir, vbDirectory) = vbNullString Then
                MkDir sCurDir
            End If
        Next i
    End If
End Sub

As you can see, there are numerous way to handles this issue. Hopefully this helped answer a question for a few of you out there!

August 17th, 2011

VBA – Open a Password Protected Excel WorkBook

I recently helped an individual in an Access Forum who wanted to know how to open a password protected Excel workbook/spreadsheet. Although the question was Access specific, the code can easily be used in Word, PowerPoint,…

'---------------------------------------------------------------------------------------
' Procedure : OpenPwdXLS
' Author    : Daniel Pineault, CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Open a password protected Excel Workbook
' 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:
' ~~~~~~~~~~~~~~~~
' strWrkBk  : Full path and Filename of the Excel Workbook to open
' sPwd      : Password to unlock/open the Workbook in question
'
' Usage:
' ~~~~~~
' OpenPwdXLS "C:\Testing\book1.xls", "MyPassword"
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2009-Jun-11             Initial Release
'---------------------------------------------------------------------------------------
Function OpenPwdXLS(strWrkBk As String, sPwd As String)
'Use late binding so no reference libraries are required
On Error GoTo Error_Handler
    Dim xlApp       As Object
    Dim xlWrkBk     As Object
 
    On Error Resume Next
    Set xlApp = 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 xlApp = CreateObject("excel.application")
    Else
        On Error GoTo Error_Handler
    End If
 
    xlApp.Visible = True 'make excel visible to the user
    Set xlWrkBk = xlApp.Workbooks.Open(strWrkBk, , , , sPwd)
 
    '... the rest of your code goes here
    
Error_Handler_Exit:
   On Error Resume Next
   Set xlWrkBk = Nothing
   Set xlApp = Nothing
   Exit Function
 
Error_Handler:
   MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
          "Error Number: " & Err.Number & vbCrLf & _
          "Error Source: OpenPwdXLS" & vbCrLf & _
          "Error Description: " & Err.Description _
          , vbOKOnly + vbCritical, "An Error has Occured!"
   Resume Error_Handler_Exit
End Function

June 22nd, 2011

VBA – List Application Command Bars

I ran into a particular problem with an associate of mine not too long ago and thaught I’d share the problem & solution with everyone. He had been given an .accdb database that evidently came from an mdb originally as it contained a custom command bar. The problem being that 2007/2010 support such command bars by simply placing them in the Add-Ins tab. However, this issue lies with the fact that 2007/2010 no longer offer the general user/developer a method to edit such command bars as they are considered to be deprecated. My associate wanted to merely delete this command bar and replace it with a proper custom Ribbon Tab. So how do you delete a command bar? Good question! In 2007/2010 the only solution is to use VBA. The actual code to delete a command bar is very simple, as shown below.

Application.CommandBars("CommandBarName").Delete

Sound simple you say. Sadly, no! Once again because MS has decided no longer provide any tools to work with these ‘elements’, you cannot identify the name of the Add-Ins toolbars. if you can’t identify it, you can’t delete it! So what to do? Well, I came up with another simple solution and created a procedure that merely listed all the command bars within the current database. then we could go through the list and identify the one that we needed to delete. Below are two slightly different procedures. The first one is a more general version which merely lists all of the command bars within the database, the second is a slightly more refined version that only lists open command bars. Since the Add-Ins Tab was active, the 2nd procedure was a better option in our case and thus reduce the list we had to sift through (our list went from 202 items to 4 – from there it was easy to determine which one we needed to eliminate).

'---------------------------------------------------------------------------------------
' Procedure : ListCmdBars
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Lists all the command bars within the current database
' Compatibility: Works with MS Access, Word, Excel, PowerPoint, ...
' 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).
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2011-June-22            Initial Release
'---------------------------------------------------------------------------------------
Function ListCmdBars()
On Error GoTo Error_Handler
    Dim i           As Long
    Dim sCmdBar     As CommandBar
 
    Debug.Print "Number", "Name", "Visible", "Built-in"
    For i = 1 To Application.CommandBars.Count
        Set sCmdBar = Application.CommandBars(i)
        Debug.Print i, sCmdBar.Name, sCmdBar.Visible, sCmdBar.BuiltIn
    Next i
Error_Handler_Exit:
    On Error Resume Next
    Set sCmdBar = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: ListCmdBars" & vbCrLf & _
           "Error Description: " & Err.Description, vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

'---------------------------------------------------------------------------------------
' Procedure : ListVisibleCmdBars
' Author    : CARDA Consultants Inc.
' Website   : http://www.cardaconsultants.com
' Purpose   : Lists all the visible command bars within the current database
' Compatibility: Works with MS Access, Word, Excel, PowerPoint, ...
' 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).
'
' Revision History:
' Rev       Date(yyyy/mm/dd)        Description
' **************************************************************************************
' 1         2011-June-22            Initial Release
'---------------------------------------------------------------------------------------
Function ListVisibleCmdBars()
On Error GoTo Error_Handler
    Dim i           As Long
    Dim j           As Long
    Dim sCmdBar     As CommandBar
 
    Debug.Print "Number", "Name", "Visible", "Built-in"
    For i = 1 To Application.CommandBars.Count
        Set sCmdBar = Application.CommandBars(i)
        If sCmdBar.Visible = True Then
            j = j + 1
            Debug.Print j, sCmdBar.Name, sCmdBar.Visible, sCmdBar.BuiltIn
        End If
    Next i
Error_Handler_Exit:
    On Error Resume Next
    Set sCmdBar = Nothing
    Exit Function
 
Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: ListVisibleCmdBars" & vbCrLf & _
           "Error Description: " & Err.Description, vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

So as you can see, it is still possible to manipulate command bars in MS Access 2007/2010, but it can now only be done through the use of VBA code!

Thanks to a post by Albert Kallal, a fellow MVP, we also found out that it could be necessary to execute the following

CurrentDb.Properties.Delete("StartUpMenuBar")

and in our case it was required as even after deleting the commandbar in question we were still receiving the error message

… can’t find the object ‘MyCommandBarName.’
If ‘MyCommandBarName’ is a new macro or macro group, make sure you have saved it and that you have type its name correctly