Useful VBA file functions - Microsoft Scripting Runtime

Some example functions for finding out the last modified date of a file, copying a file and deleting a file using VBA.

Public Sub File_Last_Modified_Date()
' Use a function to return the last modified date of a file
    MsgBox f_File_Last_Modified_Date("C:\Put\the\full\file\address\here.xlsx")
End Sub

Private Function f_File_Last_Modified_Date(FileName As String) As String
' In the VBE, set a reference to Microsoft Scripting runtime
' Tools -> References... ->
    Dim fso As Scripting.FileSystemObject
    Dim fsof As Scripting.File
    Dim strPath As String

    Set fso = New FileSystemObject
    strPath = FileName
    Set fsof = fso.GetFile(strPath)
    With fsof
        f_File_Last_Modified_Date = .DateLastModified
    End With

    Set fso = Nothing
    Set fsof = Nothing
End Function

---

Public Sub CopyFile()
' Copy a file, the file cannot be open when the copy is attempted

    Dim SourceFile As String
    Dim DestFile As String

    SourceFile = "C:\Put\the\full\file\address\here.doc"
    DestFile = "C:\Put\the\new\file\address\here.doc"

    FileCopy SourceFile, DestFile
End Sub

Public Sub DeleteFile()
' Delete a file

    Dim FileName As String

    FileName = "C:\Put\the\full\file\address\here.txt"

    ' Check the file exists
    If Dir(FileName) = "" Then
        ' File does not exist
    Else
        ' Delete the file
        Kill FileName
    End If

End Sub

As always, any questions or comments please let us know via the comments section.

Application.Filesearch Replacement For Office 2007

If you have ever used completed a search for files using VBA you probably made use of Application.Filesearch.  However, if you’ve updated to Office 2007 or 2010 you may have noticed that Filesearch has been removed… but the (very) old Dir remains, so you can use this instead, an example of which follows:

Sub FileSearch()
    Dim fso As Object
    Dim FileName As String
    Dim strArr(1 To 65536, 1 To 1) As String
    Dim i As Long

    ' Set the directory / filename you are looking for
    Const strDir As String = "C:\Your\File\Path"
    Const SearchTerm As String = "YourFileNameTerm"

    ' Complete the search
    Let FileName = Dir$(strDir & "\*" & SearchTerm & "*.xls")
    Do While FileName <> vbNullString
        ' For each file found load to the array
        Let i = i + 1
        Let strArr(i, 1) = strDir & "\" & FileName
        Let FileName = Dir$()
    Loop

    ' Search within sub-folders
    Set fso = CreateObject("Scripting.FileSystemObject")
    Call RecurseSubFolders(fso.GetFolder(strDir), strArr(), i, SearchTerm)

    ' Tidy up and copy the results to the active worksheet
    Set fso = Nothing
    If i > 0 Then
        Range("A1").Resize(i).Value = strArr
    End If

End Sub

Private Sub RecurseSubFolders( _
    ByRef Folder As Object, _
    ByRef strArr() As String, _
    ByRef i As Long, _
    ByRef SearchTerm As String)

    Dim SubFolder As Object
    Dim FileName As String

    ' Search sub folders
    For Each SubFolder In Folder.SubFolders
        Let FileName = Dir$(SubFolder.Path & "\*" & SearchTerm & "*.xls")
        Do While FileName <> vbNullString
            Let i = i + 1
            Let strArr(i, 1) = SubFolder.Path & "\" & FileName
            Let FileName = Dir$()
        Loop
        Call RecurseSubFolders(SubFolder, strArr(), i, SearchTerm)
    Next
End Sub

Using VBA to Truncate Decimal Values

Recently I have needed to truncate a decimal value to a set number of decimal places. 

For example; If you wanted the number 55.446 to two decimal places rounding the number would return 55.45.  Truncating the number to two decimal places returns 55.44. 

To do this I created the function below.  Pass in a decimal value and the number of decimal places you want the number truncated too and the function returns the value as a ‘Double’.

Public Function TruncTo(dblValue As Double, lngPlaces As Long) As Double
'-------------------------------------------------------------------------
' Procedure : TruncTo
' Author    : Matthew Sims
' Date      : 08-Oct-2010
' Purpose   : Truncate a decimal value to the requested number of decimal places
'-------------------------------------------------------------------------
'
    On Error GoTo TruncTo_Error

    If IsNumeric(dblValue) Then
        TruncTo = Int(dblValue * 10 ^ lngPlaces) / 10 ^ lngPlaces
    Else
        TruncTo = 0
    End If

    On Error GoTo 0
    Exit Function

TruncTo_Error:
    ' Add some error handling code here
End Function

VBA Version Property

It is sometimes useful to know which version of Excel your user is using.  An example of when this would be useful is knowing whether the user is in Excel 2007/2010 or and older version.  Excel 2007 was the first release that allowed over 65535 rows and 255 columns.  Excel 2007 has over 1 million rows (1048576) and 16384 columns.

This can make a big difference to what you can do with the data available to you.  If your user is in Excel 2003 for example your code could crash if it attempts to copy too much data into the active workbook.  The function below can be used within your code to confirm the Excel version, you can then call a different routine depending on it’s results.

Private Function ReturnExcelVersion() As String
'-----------------------------------------------------------------
' Procedure : ReturnExcelVersion
' Author    : Matthew - Zypher.co.uk
' Purpose   : return a string value denoting the version of Excel
'             Check the first two characters as Excel 97 has
'             several different releases and patches
'             http://support.microsoft.com/kb/232652
'-----------------------------------------------------------------
'
    Select Case Left(Application.Version, 2)

         Case Is = "14"
            ReturnExcelVersion = "2010" 
        Case Is = "12"
            ReturnExcelVersion = "2007"
        Case Is = "11"
            ReturnExcelVersion = "2003"
        Case Is = "10"
            ReturnExcelVersion = "2002"
        Case Is = "9."
            ReturnExcelVersion = "2000"
        Case Is = "8."
            ReturnExcelVersion = "97"
        Case Is = "7."
            ReturnExcelVersion = "95"
        Case Else
            ReturnExcelVersion = "Unknown"
    End Select
End Function

Excel 2010 is version 14. The version number 13 was skipped because of the aversion to the number 13.  Another relevant link is XL97: Overview and History of Excel Patches.

You may also want to look into Application.OperatingSystem.

As always, if you have any questions do let us know via the comments section.

Using VBA to get a File’s Last Modified Date

It is sometimes useful to know the date and time a file was last modified.  this is particularly useful if you have a folder full of similar files and need to use the latest copy.

Today the code I’m going to share below enables you to pass a file address into a function which will return the date and time it was last saved.  The example below passes a file address to the function, which returns the modified date, this is then displayed in a message box.

The function requires a reference to Microsoft Scripting Runtime within the VBE.

Sub MyMacroRoutine()
    Dim ModDate As Date
    ModDate = FileLastModDate("C:\YourFileAddressGoesHere")
    MsgBox ModDate
End Sub

Function FileLastModDate(strFileAddress As String) As Date
' In the VBE, set a reference to Microsoft Scripting runtime

    Dim fso As Scripting.FileSystemObject
    Dim fsof As Scripting.File
    Dim strPath As String

    Set fso = New FileSystemObject
    strPath = strFileAddress
    Set fsof = fso.GetFile(strPath)
    With fsof
        FileLastModDate = .DateLastModified
    End With

    Set fso = Nothing
    Set fsof = Nothing

End Function

As always, if you have any questions do let us know via the comments section.

Transpose an array

If you have ever used the paste special transpose option within an Excel worksheet you will know how handy it is.  The transpose option allows you copy a list, for example 10 rows with 2 columns, and turn it sideways, leaving you with 2 rows and 10 columns.

 

Well below is a simple function you can copy straight into any VBA module.  It allows you to pass in an array of any size and passes back the ‘transposed’ array results.

Public Function TransposeArray(v As Variant) As Variant
' Custom Function to Transpose a 0-based array (v)

    Dim x As Long, y As Long, Xupper As Long, Yupper As Long
    Dim tempArray As Variant

    Xupper = UBound(v, 2)   'rows
    Yupper = UBound(v, 1)   'columns

    ReDim tempArray(Xupper, Yupper)
    For x = 0 To Xupper
        For y = 0 To Yupper
            tempArray(x, y) = v(y, x)
        Next y
    Next x

    TransposeArray = tempArray

End Function

I hope it proves useful.  If you have any questions or ideas for future blog posts please let us know via the comments section.

I’d like to add a thank you to a possible future Zypher-Blog colleague Niall for the example code.

Current User and Current PC

In this post I thought I'd show two very useful functions which use Windows API calls, the username and PC name functions.  Windows API calls allow you to get information or features from the operating system which Excel and Access do not have.
The first step in using an API call is to tell VBA the function exists, where to find it, what arguments it takes and what data type it returns. This is done using the Declare statement, such as the example below.

Private Declare Function GetUserNameA _
  Lib "advapi32.dll" _
  (ByVal lpBuffer As String, nSize As Long) As Long

This statement tells the VBA interpreter that there is a function called GetUserNameA located in the file advapi32.dll that takes two arguments, the first a string and the second a Long value and returns a Long value. Once defined, we can call GetUserNameA in exactly the same way as if it is the VBA function:

  lng = GetUserNameA(strUserName, intLength)

The Function below uses the GetUserNameA API function and turns the results into a string which shows the current users Windows login.

Public Function CurrentUser() As String
'-- used to get current user's login id --
    Dim strUserName As String
    Dim lngLength As Long
    Dim lngResult As Long
    ' Set up the buffer
    strUserName = VBA.String(255, 0) 
    lngLength = 255
    ' Make the call 
    lngResult = GetUserNameA(strUserName,  lngLength)
    ' Assign the value
    CurrentUser = Left(strUserName, _
        InStr(1, strUserName, VBA.Chr(0)) - 1)
End Function

You can add this this code to any normal VBA module within either Excel or Access.  The API ‘Private Declare Function’ should be placed at the top of the module, before any other Sub Routines or Functions.
The current PC function, below, works in much the same way.

Private Declare Function GetComputerNameA Lib "kernel32" _
    (ByVal lpBuffer As String, nSize As Long) As Long

Public Function CurrentPC() As String
'-- used to get current user's login id --
    Dim strPCName As String
    Dim lngLength As Long
    Dim lngResult As Long
    ' Set up the buffer
    strPCName = VBA.String(255, 0)
    lngLength = 255
    ' Make the call
    lngResult = GetComputerNameA(strPCName, lngLength)
    ' Assign the value
    CurrentPC = Left(strPCName, _
        InStr(1, strPCName, VBA.Chr(0)) - 1)
End Function

Google / Yahoo as always will be able to provide more information on using API calls, this site is also probably worth a read.
I’ll add a sorry about the colour scheme, guess that’s what happens when you choose black as a background.