Using FileSystemObject (VBA) with filter - vba

With my code I have to write a file name to search : "test.txt" . It works fine, returns as many as test.txt exist in the selected path.
I want it to work searching : "txt" and get all the .txt files in the selected path.
My code :
Option Explicit
Dim fso As New FileSystemObject
Dim fld As Folder
Private Sub Command1_Click()
Dim nDirs As Long, nFiles As Long, lSize As Currency
Dim sDir As String, sSrchString As String
sDir = InputBox("Type the directory that you want to search for", _
"FileSystemObjects example", "C:\")
sSrchString = InputBox("Type the file name that you want to search for", _
"FileSystemObjects example", "")
' MousePointer = vbHourglass
' Label1.Caption = "Searching " & vbCrLf & UCase(sDir) & "..."
lSize = FindFile(sDir, sSrchString, nDirs, nFiles)
' MousePointer = vbDefault
MsgBox Str(nFiles) & " files found in" & Str(nDirs) & _
" directories", vbInformation
MsgBox "Total Size = " & lSize & " bytes"
End Sub
Private Function FindFile(ByVal sFol As String, sFile As String, _
nDirs As Long, nFiles As Long) As Currency
Dim tFld As Folder, tFil As File, FileName As String
On Error GoTo Catch
Set fld = fso.GetFolder(sFol)
FileName = Dir(fso.BuildPath(fld.path, sFile), vbNormal Or _
vbHidden Or vbSystem Or vbReadOnly)
While Len(FileName) <> 0
FindFile = FindFile + FileLen(fso.BuildPath(fld.path, _
FileName))
nFiles = nFiles + 1
' List1.AddItem fso.BuildPath(fld.Path, FileName) ' Load ListBox
FileName = Dir() ' Get next file
DoEvents
Wend
' Label1 = "Searching " & vbCrLf & fld.Path & "..."
nDirs = nDirs + 1
If fld.SubFolders.Count > 0 Then
For Each tFld In fld.SubFolders
DoEvents
FindFile = FindFile + FindFile(tFld.Path, sFile, nDirs, nFiles)
Next
End If
Exit Function
Catch: FileName = ""
Resume Next
End Function
and a tip, I've found something like :
For Each file In files
If Right(file, 3) = "pdf" Then
myMailItem.Attachments.Add CStr(file)
found = True
End If
But I couldn't get it working in my code.
Thanks!

Related

Move files automatically to date folder

from the below mentioned VBA code i am able to move files from Source to destination, however after moving the files i need to change the folder name by date everyday, is there anyway we can move the files directly to the updated date folder, the pattern of the folder name/folder date is
01102022
02102022
03102022
the code i have is
Option Explicit
Sub MoveFilesTEST()
Const sFolderPath As String = "E:\Asianet2"
Const dFolderPath As String = "E:\Asianet3"
Const FilePattern As String = "*.*"
MoveFiles sFolderPath, dFolderPath, FilePattern
End Sub
Sub MoveFiles( _
ByVal SourceFolderPath As String, _
ByVal DestinationFolderPath As String, _
Optional ByVal FilePattern As String = "*.*")
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(SourceFolderPath) Then
MsgBox "The source folder path '" & SourceFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
If Not fso.FolderExists(DestinationFolderPath) Then
MsgBox "The destination folder path '" & DestinationFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
Dim apSep As String: apSep = Application.PathSeparator
Dim sPath As String: sPath = SourceFolderPath
If Left(sPath, 1) <> apSep Then sPath = sPath & apSep
Dim sFolder As Object: Set sFolder = fso.GetFolder(sPath)
If sFolder.Files.Count = 0 Then
Exit Sub
End If
Dim dPath As String: dPath = DestinationFolderPath
If Left(dPath, 1) <> apSep Then dPath = dPath & apSep
Dim dFolder As Object: Set dFolder = fso.GetFolder(dPath)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim sFile As Object
Dim dFilePath As String
Dim ErrNum As Long
Dim MovedCount As Long
Dim NotMovedCount As Long
For Each sFile In sFolder.Files
dFilePath = dPath & sFile.Name
If fso.FileExists(dFilePath) Then
dict(sFile.Path) = Empty
NotMovedCount = NotMovedCount + 1
Else
On Error Resume Next
fso.MoveFile sFile.Path, dFilePath
ErrNum = Err.Number
' e.g. 'Run-time error '70': Permission denied' e.g.
' when the file is open in Excel
On Error GoTo 0
If ErrNum = 0 Then
MovedCount = MovedCount + 1
Else
dict(sFile.Path) = Empty
NotMovedCount = NotMovedCount + 1
End If
End If
Next sFile
Dim Msg As String
End Sub
screenshot
Please, use the next code. It creates the folder (as ddmmyyyy) in "dFolderPath" and moves all files existing in "sFolderPath":
Sub moveAllFilesInDateFolder()
Dim DateFold As String, fileName As String
Const sFolderPath As String = "E:\Asianet2"
Const dFolderPath As String = "E:\Asianet3"
DateFold = dFolderPath & "\" & Format(Date, "ddmmyyyy")' create the folder if it does not exist
If Dir(DateFold, vbDirectory) = "" Then MkDir DateFold
fileName = Dir(sFolderPath & "\*.*")
If fileName = "" Then MsgBox "No any file in " & sFolderPath & "...": Exit Sub
Do While fileName <> ""
Name sFolderPath & "\" & fileName As DateFold & "\" & fileName
fileName = Dir
Loop
End Sub
Please, send some feedback after testing it...
You probably would need previously checking if there are no files in "dateFold", to avoid asking for overwriting in case of running the code twice (in the same day, by mistake)...

How to convert multiple word docs (incl subfolders) from .doc to .docx?

Is there a way to edit the following VBA code in a way that it can also convert all .doc documents in sub folders and delete the original .doc?
I have quite many of them and I am not quite familiar with VBA code. Any help would be much appreciated!
Sub ConvertBatchToDOCX()
Dim sSourcePath As String
Dim sTargetPath As String
Dim sDocName As String
Dim docCurDoc As Document
Dim sNewDocName As String
' Looking in this path
sSourcePath = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015"
sTargetPath = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015"
' Look for first DOC file
sDocName = Dir(sSourcePath & "*.doc")
Do While sDocName <> ""
' Repeat as long as there are source files
'Only work on files where right-most characters are ".doc"
If Right(sDocName, 4) = ".doc" Then
' Open file
Set docCurDoc = Documents.Open(FileName:=sSourcePath & sDocName)
sNewDocName = Replace(sDocName, ".doc", ".docx")
With docCurDoc
.SaveAs FileName:=sTargetPath & sNewDocName, _
FileFormat:=wdFormatDocumentDefault
.Close SaveChanges:=wdDoNotSaveChanges
End With
End If
' Get next source file name
sDocName = Dir
Loop
MsgBox "Finished"
End Sub
Please use the next solution:
Add the next API function on top of the module (in the declarations area):
Private Declare PtrSafe Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As LongPtr)
Use the next adapted Sub:
Sub ConvertBatchToDOCX()
Dim mainFolderPath As String, sDoc, arrDocs, boolProblematic As Boolean
Dim docCurDoc As Document, sNewDocName As String, strMsg As String
' Looking in this path
mainFolderPath = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015\"
strMsg = "Problematic files: " & vbCrLf
arrDocs = getAllDocs(mainFolderPath & "*.doc")
If arrDocs(0) = "" Then MsgBox "No appropriate documents have been found...": Exit Sub
For Each sDoc In arrDocs
sNewDocName = Left(sDoc, InStrRev(sDoc, ".") - 1) & ".docx": ' Stop
boolProblematic = False
On Error Resume Next
Set docCurDoc = Documents.Open(FileName:=sDoc)
If Err.Number = 5174 Then
Err.Clear: boolProblematic = True
strMsg = strMsg & sDoc & vbCrLf
End If
If Not boolProblematic Then
docCurDoc.SaveAs FileName:=sNewDocName, FileFormat:=wdFormatDocumentDefault
docCurDoc.Close False
Kill sDoc
Sleep 1000
End If
Next
If strMsg <> "Problematic files: " & vbCrLf Then MsgBox strMsg
MsgBox "Finished"
End Sub
The function has also been adapted, in order to handle the case of not document with extension ".doc" has been found:
Private Function getAllDocs(strFold As String, Optional strExt As String = "*.*") As Variant
Dim arrD, arrExt, arrFin, sDoc, i As Long
arrD = Filter(Split(CreateObject("wscript.shell").Exec("cmd /c dir """ & strFold & strExt & """ /b /s").StdOut.ReadAll, vbCrLf), "\")
ReDim arrFin(UBound(arrD))
For Each sDoc In arrD
arrExt = Split(sDoc, ".")
If LCase(arrExt(UBound(arrExt))) = "doc" Then
arrFin(i) = sDoc: i = i + 1
End If
Next
If i > 0 Then
ReDim Preserve arrFin(i - 1)
Else
ReDim arrFin(0)
End If
getAllDocs = arrFin
End Function
Maybe this could get you on the right track? (Untested)
Sub saveDOCsAsDOCXs()
ChDir "C:\myFolderName\"
Dim fIn As String, fOut As String, doc As Document
fIn = Dir("*.doc") 'list first `doc` files in current folder (includes `docx`)
Do
If Right(fIn, 4) = ".doc" Then 'only process `doc` files
Debug.Print "Opening " & fIn
Set doc = Documents.Open(fIn) 'open the `doc`
fOut = fIn & "x" 'output filename
If Dir(fOut) <> "" Then
Debug.Print fOut & " already exists." 'could instead delete existing like `Kill fOut`
Else
doc.SaveAs fOut, wdFormatXMLDocument 'save as `docx`
Debug.Print "Saved " & fOut
End If
doc.Close 'close the file
End If
fIn = Dir() 'get next `doc` file
Loop While fIn <> ""
End Sub
Documentation: Open, SaveAs2, Dir

Compile error: Type mismatch (converting 32bit to 64bit VBA coding)

This is my first time using VBA so I need help. This is a macro in Excel to convert a file from one Excel extension to another. I have starting converting this code from 32 bit to work in 64 bit and found online most the key parts to change but now it is giving me Compile Errors: Type mismatch and I have no idea what to change. Any help is appreciated.
The Error shows the yellow arrow at Sub loopConvert() and the cntToConvert as the blue highlighted section. Picture included.
Picture of Error
Option Explicit
'Created by David Miller (dlmille on E-E October, 2011)
'Feel free to use and share, please maintain appropriate acknowledgements the author and link where you found this code.
Sub loopConvert()
Dim fPath As String
Dim fName As String, fSaveAsFilePath As String, fOriginalFilePath As String
Dim wBook As Workbook, fFilesToProcess() As String
Dim numconverted As LongPtr, cntToConvert As LongPtr, i As LongPtr
Dim killOnSave As Boolean, xMsg As LongPtr, overWrite As Boolean, pOverWrite As Boolean
Dim silentMode As Boolean
Dim removeMacros As Boolean
Dim fromFormat As String, toformat As String
Dim saveFormat As LongPtr
Dim wkb As Workbook, wks As Worksheet
Set wkb = ThisWorkbook
Set wks = wkb.Sheets("Control Panel")
removeMacros = IIf(wks.CheckBoxes("Check Box 1").Value = 1, True, False)
silentMode = IIf(wks.CheckBoxes("Check Box 2").Value = 1, True, False)
killOnSave = IIf(wks.CheckBoxes("Check Box 3").Value = 1, True, False)
fromFormat = wkb.Names("fromFormat").RefersToRange
toformat = wkb.Names("toFormat").RefersToRange
saveFormat = IIf(toformat = ".XLS", xlExcel8, IIf(toformat = ".XLSX", xlOpenXMLWorkbook, xlOpenXMLWorkbookMacroEnabled))
Application.DisplayAlerts = False 'no user prompting, taking all defaults
Application.ScreenUpdating = False
fPath = GetFolderName("Select Folder for " & fromFormat & " to " & toformat & " conversion")
If fPath = "" Then
MsgBox "You didn't select a folder", vbCritical, "Aborting!"
Exit Sub
Else
fName = Dir(fPath & "\*" & fromFormat)
If fName = "" Then
MsgBox "There aren't any " & fromFormat & " files in the " & fPath & " directory", vbCritical, "Aborting"
Exit Sub
Else 'get a file count of files to be processed, then process them in the next step
Do
If UCase(Right(fName, Len(fromFormat))) = UCase(fromFormat) Then 'to differentiate between dir *.xls and inadvertently get *.xls???
ReDim Preserve fFilesToProcess(cntToConvert) As String
fFilesToProcess(cntToConvert) = fName
cntToConvert = cntToConvert + 1
End If
fName = Dir
Loop Until fName = ""
If cntToConvert = 0 Then 'we were looking for .XLS and there was only .XLS??? or nothing, then abort
MsgBox "There aren't any " & fromFormat & " files in the " & fPath & " directory", vbCritical, "Aborting"
Exit Sub
End If
If Not silentMode Then
xMsg = MsgBox("There are " & cntToConvert & " " & fromFormat & " files to convert to " & toformat & ". Do you want to delete the " & fromFormat & " files as they are processed?", vbYesNoCancel, "Select an Option")
killOnSave = False 'already false, but just a reminder this is in here!
If xMsg = vbYes Then
killOnSave = True
ElseIf xMsg = vbCancel Then
GoTo processComplete
End If
Else
pOverWrite = True
End If
Application.EnableEvents = False 'turn off events so macros don't fire on excel file opens
For i = 0 To cntToConvert - 1 'process each file for conversion, displaying status as progress...
Application.StatusBar = "Processing: " & i + 1 & " of " & cntToConvert & " file: " & fName
fName = fFilesToProcess(i)
'open and convert file
On Error GoTo errHandler
fOriginalFilePath = fPath & "\" & fName
'you could also check to see if the save as file already exists, before you open convert and save on top!
overWrite = False
fSaveAsFilePath = fPath & "\" & Mid(fName, 1, Len(fName) - Len(fromFormat)) & toformat
If Not pOverWrite Then
If FileFolderExists(fSaveAsFilePath) Then
xMsg = MsgBox("File: " & fSaveAsFilePath & " already exists, overwrite?", vbYesNoCancel, "Hit Yes to Overwrite, No to Skip, Cancel to quit")
If xMsg = vbYes Then
overWrite = True
ElseIf xMsg = vbCancel Then
GoTo processComplete
End If
Else
overWrite = True
End If
Else
overWrite = pOverWrite
End If
If overWrite Then
Set wBook = Application.Workbooks.Open(fOriginalFilePath)
If removeMacros And (toformat = ".XLS" Or toformat = ".XLSM") And (fromFormat <> ".XLSX") Then
'use Remove Macro Helper
Call RemoveAllMacros(wBook)
End If
wBook.SaveAs Filename:=fSaveAsFilePath, FileFormat:=saveFormat
wBook.Close savechanges:=False
numconverted = numconverted + 1
'optionally, you can delete the file you converted from
If killOnSave And fromFormat <> toformat Then
Kill fOriginalFilePath
End If
End If
Next i
End If
End If
processComplete:
On Error GoTo 0
MsgBox "Completed " & numconverted & " " & fromFormat & " to " & toformat & " conversions", vbOKOnly
Application.EnableEvents = True 'uncomment if doing other conversions where macros are involved in source workbooks
Application.StatusBar = False
Application.DisplayAlerts = True
Application.ScreenUpdating = False
Exit Sub
errHandler:
Application.StatusBar = False
MsgBox "For some reason, could not open/save the file: " & fPath & "\" & fName, vbCritical, "Aborting!"
Resume processComplete
End Sub
Squidx3 helped me figure out that I needed to just change it. It works now Thanks!
From this:
Dim numconverted As LongPtr, cntToConvert As LongPtr, i As LongPtr
To this:
Dim numconverted As LongPtr, cntToConvert As Long, i As Long
GetFolderName isn't a native function. You copied this code from another place? Verify if getFolderName is there.

Regex for VBA Excel macro for new folder chars

I have a function which is Boolean, and returns whether is the cell OK for creating a New Folder based on its value or its not (if it posses following chars:<,>,|,\,*,?)
But from some weird reason, it returns always false, either is a cell OK or not.
So, I have a sub which creates a loop for all rows and creates some .txt files and puts it in auto-generated folders.
Here is my code:
Sub CreateTxtSrb()
Dim iRow As Long
Dim iFile As Integer
Dim sPath As String
Dim sFile As String
Dim iEnd As Range
'iEnd = Cells(Rows.Count, "B").End(xlUp).Row
For iRow = 1 To Cells(Rows.Count, "B").End(xlUp).Row
iFile = FreeFile
With Rows(iRow)
If IsValidFolderName(.Range("B2").Value) = False Or IsValidFolderName(.Range("D2").Value) = False Or IsValidFolderName(.Range("F2").Value) = False Then
MsgBox ("Check columns B,D or F, it cannot contains chars: <,>,?,|,\,/,*,. or a space at the end")
Exit Sub
Else
strShort = IIf(InStr(.Range("E2").Value, vbCrLf), Left(.Range("E2").Value, InStr(.Range("E2").Value, vbCrLf) - 2), .Range("E2").Value)
sPath = "E:\" & .Range("B2").Value & "\"
If Len(Dir(sPath, vbDirectory)) = 0 Then MkDir sPath
sFile = .Range("D2").Value & ".txt"
Open sPath & sFile For Output As #iFile
Print #iFile, .Range("E2").Value
Close #iFile
End If
End With
Next iRow
End Sub
Function IsValidFolderName(ByVal sFolderName As String) As Boolean
'http://msdn.microsoft.com/en- us/library/windows/desktop/aa365247(v=vs.85).aspx#file_and_directory_names
'http://msdn.microsoft.com/en-us/library/ie/ms974570.aspx
On Error GoTo Error_Handler
Dim oRegEx As Object
'Check to see if any illegal characters have been used
Set oRegEx = CreateObject("vbscript.regexp")
oRegEx.Pattern = "[<>:""/\\\|\?\*]"
IsValidFolderName = Not oRegEx.test(sFolderName)
'Ensure the folder name does end with a . or a blank space
If Right(sFolderName, 1) = "." Then IsValidFolderName = False
If Right(sFolderName, 1) = " " Then IsValidFolderName = False
Error_Handler_Exit:
On Error Resume Next
Set oRegEx = Nothing
Exit Function
Error_Handler:
MsgBox ("test")
' MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
' "Error Number: " & Err.Number & vbCrLf & vbCrLf & _
' "Error Source: IsInvalidFolderName" & vbCrLf & _
' "Error Description: " & Err.Description, _
' vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Function
How can I make it return true if need be?
You don't need the external reference you can simply:
hasInvalidChars = sFolderName like "*[<>|\/:*?""]*"
I added " and : which are also illegal.
(In your example you have HTML entities (E.g. <) - these have no meaning in your RegEx string and are interpreted as 4 characters in the class)
That's a mess. Use a separate function
Public Function IsInvalid(ByVal name As String) As Boolean
Dim regex As Object
Set regex = VBA.CreateObject("VBScript.RegExp")
regex.Pattern = "[\\/:\*\?""<>\|]" 'the disallowed characters
IsInvalid = (regex.Execute(name).Count > 0)
End Function
instead, and call it when appropriate.

VBA To send mail using Filesearch

I have this code to send mail to multiple recipients using Lotus Notes. Right now I need to mention the entire file path for the attachments. My requirement is to use FileSearch method - mention any part of the name of the attachment within * * - so that the files get attached.
Sub Send()
Dim oSess As Object
Dim oDB As Object
Dim oDoc As Object
Dim oItem As Object
Dim direct As Object
Dim Var As Variant
Dim flag As Boolean
Dim cell As Range
Dim r As Excel.Range
Dim Name As String
Dim Annex As String
Dim recp As Variant
Dim cc As Variant
Dim Resp As Long
Resp = MsgBox(prompt:="Do you wish to send to the mail?", Buttons:=vbYesNo + vbInformation + vbDefaultButton2, Title:=AppHeader)
If Resp = vbYes Then
Sheets("Sheet2").Activate
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "E").Value) = "yes" Then
Set oSess = CreateObject("Notes.NotesSession")
Set oDB = oSess.GETDATABASE("", "")
Call oDB.OPENMAIL
flag = True
If Not (oDB.IsOpen) Then flag = oDB.Open("", "")
If Not flag Then
MsgBox "Can't open mail file: " & oDB.SERVER & " " & oDB.FILEPATH
GoTo exit_SendAttachment
End If
On Error GoTo err_handler
'Building Message
recp = Cells(cell.Row, "B").Value
cc = Cells(cell.Row, "C").Value
Set oDoc = oDB.CREATEDOCUMENT
Set oItem = oDoc.CREATERICHTEXTITEM("BODY")
oDoc.Form = "Memo"
oDoc.Subject = "HI" & "-" & Cells(cell.Row, "D").Value
oDoc.sendto = Split(recp, ",")
oDoc.copyto = Split(cc, ",")
oDoc.body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please find attached "
oDoc.postdate = Date
oDoc.SaveMessageOnSend = True
Name = Cells(cell.Row, "F").Value
Annex = Cells(cell.Row, "G").Value
Call oItem.EmbedObject(1454, "", Name)
Call oItem.EmbedObject(1454, "", Annex)
oDoc.Send False
End If
Next cell
MsgBox prompt:="Mail Sent", Buttons:=vbOKOnly + vbInformation, Title:=AppHeader
Exit Sub
'Attaching DATABASE
For Each r In Range("Fpath") '// Change to suit
If r.Value <> vbNullString Then
Call Send
End If
Next
oDoc.visable = True
'Sending Message
exit_SendAttachment:
On Error Resume Next
Set oSess = Nothing
Set oDB = Nothing
Set oDoc = Nothing
Set oItem = Nothing
'Done
err_handler:
If Err.Number = 7225 Then
MsgBox "File doesn't exist"
Else
MsgBox Err.Number & " " & Err.Description
End If
On Error GoTo exit_SendAttachment
Else
Sheets("Sheet1").Activate
End If
End Sub
Any thoughts will be highly appreciated.
It's been years since I have worked with Lotus notes. The last question that I answered on Lotus notes was way back in July 26, 2011 So be gentle on me if I miss any syntax. :p
Application.FileSearch method is no longer supported from XL2007+
Reference: Error message when you run a macro to search for a file in an Office 2007 program: "Run-time error 5111"
In case the above link dies, here is the screenshot.
As mentioned in that link You can use the FileSystemObject object to recursively search directories and to find specific files. Here is how we do that
In case the above link dies, here is the code from that link.
'~~> COURTESY: http://support.microsoft.com/kb/185601
Option Explicit
Dim fso As New FileSystemObject
Dim fld As Folder
Private Sub Command1_Click()
Dim nDirs As Long, nFiles As Long, lSize As Currency
Dim sDir As String, sSrchString As String
sDir = InputBox("Type the directory that you want to search for", _
"FileSystemObjects example", "C:\")
sSrchString = InputBox("Type the file name that you want to search for", _
"FileSystemObjects example", "vb.ini")
MousePointer = vbHourglass
Label1.Caption = "Searching " & vbCrLf & UCase(sDir) & "..."
lSize = FindFile(sDir, sSrchString, nDirs, nFiles)
MousePointer = vbDefault
MsgBox Str(nFiles) & " files found in" & Str(nDirs) & _
" directories", vbInformation
MsgBox "Total Size = " & lSize & " bytes"
End Sub
Private Function FindFile(ByVal sFol As String, sFile As String, _
nDirs As Long, nFiles As Long) As Currency
Dim tFld As Folder, tFil As File, FileName As String
On Error GoTo Catch
Set fld = fso.GetFolder(sFol)
FileName = Dir(fso.BuildPath(fld.Path, sFile), vbNormal Or _
vbHidden Or vbSystem Or vbReadOnly)
While Len(FileName) <> 0
FindFile = FindFile + FileLen(fso.BuildPath(fld.Path, _
FileName))
nFiles = nFiles + 1
List1.AddItem fso.BuildPath(fld.Path, FileName) ' Load ListBox
FileName = Dir() ' Get next file
DoEvents
Wend
Label1 = "Searching " & vbCrLf & fld.Path & "..."
nDirs = nDirs + 1
If fld.SubFolders.Count > 0 Then
For Each tFld In fld.SubFolders
DoEvents
FindFile = FindFile + FindFile(tFld.Path, sFile, nDirs, nFiles)
Next
End If
Exit Function
Catch: FileName = ""
Resume Next
End Function
Once you are able to select the files you can use the below code in a loop to add the attachments
stAttachment = "Blah Blah.Txt"
Set obAttachment = oDoc.CreateRichTextItem("stAttachment")
Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)