Loop through all files within a directory

Another thing I see a lot is where someone wants to loop through a directory (and/or subfolders). There are a number of ways to do this, such as VB's Dir() method, FileSystemObject, FindFirstFile/FindNextFile APIs, even Application.FileSearch (up through excel 2003, I believe). I have done a few speed tests for various threads, and usually find Dir() to be the quickest (usually true for local disks; network shares seem to vary). Dir is also the one I go with the most, as it doesn't require and early/late binding for FSO, and needs no API declare statements.

Note that if you're working in VBScript, you will have to use FileSystemObject, as Dir() doesn't exist in VBS and APIs are more trouble than they're worth if you want to use them (you'd have to create a container class in vb to use them in vbs).

Here is an example of looping through all the files within a specific directory; my calling subroutine just sends a message box with the number of files contained, but it can obviously do much more. I'm also including a simple routine called DesktopAddress, should anyone ever want to know the desktop's location via code (I use this is many of my distributed projects at work, actually). Run the LoopThroughAllFilesInDirectory to return a filecount of files on your desktop, and change as needed!

Sub LoopThroughAllFilesInDirectory()
 Dim vFiles() As String, i As Long
 ReDim vFiles(1, 0)
 GetFilesWithDir DesktopAddress, vFiles 'all files desktop + below
 MsgBox "You have " & CStr(UBound(vFiles, 2) + 1) & " files on your desktop"
End Sub
Function DesktopAddress() As String
 Dim vShell As Object, vDesktop As String
 Set vShell = CreateObject("WScript.Shell")
 vDesktop = vShell.SpecialFolders("Desktop")
 If Right(vDesktop, 1) <> "\" Then vDesktop = vDesktop & "\"
 DesktopAddress = vDesktop
 Set vShell = Nothing
End Function

Function GetFilesWithDir(ByVal vPath As String, ByRef vsArray() _
  As String, Optional IncludeSubfolders As Boolean = True) As Boolean
 'You must send this a string array, ReDim'med to (1,0)
 ' (0,x) = path of file
 ' (1,x) = file name
 Dim TempStr As String, vDirs() As String, Cnt As Long, dirCnt As Long
 dirCnt = 0
 If Len(vsArray(0, 0)) = 0 Then
  Cnt = 0
 Else
  Cnt = UBound(vsArray, 2) + 1
 End If
 If Right(vPath, 1) <> "\" Then vPath = vPath & "\"
 
 If IncludeSubfolders Then
  On Error GoTo BadDir
  TempStr = Dir(vPath, 31)
  Do Until Len(TempStr) = 0
   If Asc(TempStr) <> 46 Then
    If GetAttr(vPath & TempStr) And vbDirectory Then
     ReDim Preserve vDirs(dirCnt)
     vDirs(dirCnt) = TempStr
     dirCnt = dirCnt + 1
    End If
BadDirGo:
   End If
   TempStr = Dir
SkipDir:
  Loop
 End If
 
 On Error GoTo BadFile
 TempStr = Dir(vPath, 15)
 Do Until Len(TempStr) = 0
  ReDim Preserve vsArray(1, Cnt)
  vsArray(0, Cnt) = vPath
  vsArray(1, Cnt) = TempStr
  Cnt = Cnt + 1
  TempStr = Dir
 Loop
BadFileGo:
 On Error GoTo 0
 If dirCnt > 0 Then
  For dirCnt = 0 To UBound(vDirs)
   If Len(Dir(vPath & vDirs(dirCnt))) = 0 Then
    GetFilesWithDir vPath & vDirs(dirCnt), vsArray
   End If
  Next
 End If
 Exit Function
BadDir:
 If TempStr = "pagefile.sys" Or TempStr = "???" Then
  Debug.Print "DIR: Skipping: " & vPath & TempStr
  Resume BadDirGo
 ElseIf Err.Number = 52 Then
  Debug.Print "No read dir rights: " & vPath & TempStr
  Resume SkipDir
 End If
 Debug.Print "Error with DIR Dir: " & Err.Number & " - " & Err.Description
 Exit Function
BadFile:
 If Err.Number = 52 Then
  Debug.Print "No read file rights: " & vPath & TempStr
 Else
  Debug.Print "Error with DIR File: " & Err.Number & " - " & Err.Description
 End If
 Resume BadFileGo
End Function

VBA/VB6/VBS word replace - Regular expressions

Did you ever wish you could replace entire words within a string? Maybe you're changing names within a document and want to change "Mark" to "Horace", but don't want to have "market" turn into "Horaceet". Or maybe you want to insert a word, but only in relation to another specific word? Then use regular expressions!

Make sure to escape any regexp special characters, and use the \b word boundaries around the 'Find what' portion. Occasionally I'll even use my "rxPatt = ..." line in other routines when I need to escape a search string for regexp. Works well, though I find myself using this less and less nowadays. Unless you have long strings within cells, it isn't that useful for Excel unfortunately. I have found a couple uses here and there, but not too many.

Anyways.. on to the code!

Function RegExWordReplace(ByVal rxFull As String, ByVal rxWhat As String, ByVal _
  rxRepl As String, Optional ByVal rxIgnoreCase As Boolean = True) As String
 'rxFull = Full string that you will be doing your find/replace within
 'rxWhat = What to find within the full string
 'rxRepl = What to replace the found string with
 'rxIgnoreCase = You can make the search case-sensitive by specifying this = false
 Dim RegEx As Object, rxPatt As String
 Set RegEx = CreateObject("vbscript.regexp")
 rxPatt = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
  Replace(Replace(Replace(Replace(rxWhat, "\", "\\"), "^", "\^"), "$", "\$"), "*", _
  "\*"), "+", "\+"), "?", "\?"), ".", "\."), "(", "\("), ")", "\)"), "|", "\|"), _
  "{", "\{"), "}", "\}"), ",", "\,")
 With RegEx
  .Pattern = "\b" & rxPatt & "\b"
  .Global = True
  .IgnoreCase = rxIgnoreCase
  .MultiLine = True
 End With
 If RegEx.Test(rxFull) Then rxFull = RegEx.Replace(rxFull, rxRepl)
 RegExWordReplace = rxFull
 Set RegEx = Nothing
End Function

And to test it:

Sub WordReplaceExample()
 Dim OrigStr As String, NewStr As String
 OrigStr = "Our normal products were found to have no side effects."
 NewStr = RegExWordReplace(OrigStr, "no", "no adverse")
 MsgBox OrigStr & vbCrLf & vbCrLf & NewStr
End Sub

Working with the recycling bin

Now, if you've ever tried to interact with the recycling bin in VBA (or VB6) you probably know it can get a bit complicated at times. pIDLs, IShellFolder interfaces, lots of fun stuff. Did you know you can do some basic tasks without using any of that? Some examples:

Send a file to the recycling bin rather than just deleting it

Option Explicit
Private Type SHFILEOPTSTRUCT
 hWnd As Long
 wFunc As Long
 pFrom As String
 pTo As String
 fFlags As Integer
 fAnyOperationsAborted As Long
 hNameMappings As Long
 lpszProgressTitle As Long
End Type
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" ( _
  lpFileOp As SHFILEOPTSTRUCT) As Long
Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40
Public Sub DeleteFileToRecycleBin(vFilename As String)
 Dim vFileOp As SHFILEOPTSTRUCT
 With vFileOp
  .wFunc = FO_DELETE
  .pFrom = vFilename
  .fFlags = FOF_ALLOWUNDO
 End With
 SHFileOperation vFileOp
End Sub

Empty the recycling bin

Option Explicit
Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" Alias "SHEmptyRecycleBinA" _
 (ByVal hWnd As Integer, ByVal pszRootPath As String, ByVal dwFlags As Integer) As Integer
Private Declare Function SHUpdateRecycleBinIcon Lib "shell32.dll" () As Long
Private Const SHERB_NOCONFIRMATION = &H1
Private Const SHERB_NOPROGRESSUI = &H2
Private Const SHERB_NOSOUND = &H4
Private Sub EmptyRecycleBin()
 SHEmptyRecycleBin 0, vbNullString, SHERB_NOCONFIRMATION
 SHUpdateRecycleBinIcon
End Sub

Restore from the recycling bin

Option Explicit
Sub RestoreFromRecyclingBin()
 Dim vShell As Object, vRecycler As Object
 Const ssfBITBUCKET As Long = 10 'the BitBucket is the recycling bin
 Set vShell = CreateObject("Shell.Application")
 Set vRecycler = vShell.NameSpace(ssfBITBUCKET)
 RestoreRecycledItems vRecycler
 Set vRecycler = Nothing
 Set vShell = Nothing
End Sub
Private Sub RestoreRecycledItems(vObj As Object)
 Dim vItem As Object
 For Each vItem In vObj.Items
  'Remove this next line if you don't want to iterate through a deleted folder
  If vItem.IsFolder Then Call RestoreRecycledItems(vItem)
   
  'You can use   vObj.GetDetailsOf(vItem, x)   where x is a number from 0 to 4, to return
  '   string information about the recycled item. Definition of x:
  ' 0 = Filename
  ' 1 = Path
  ' 2 = Deleted Date/Time
  ' 3 = File type (long name, not extension)
  ' 4 = Size (in KB, or whatever your windows explorer uses as default size)
  
  'Here I will check the deleted date, and if it was deleted today, restore it
  ' Since   .GetDetailsOf(vItem ,2)   returns deleted date and time, I cut off the time
  If Int(CDate(vObj.GetDetailsOf(vItem, 2))) = Date Then
   'use the folderitem's InvokeVerb method to restore it
   Call vItem.InvokeVerb("R&estore")
  End If
 Next
 Set vItem = Nothing
 Set vObj = Nothing
End Sub

Fun, huh?