I tried to paste the link of my sharepoint in the destination URL
but I am having this error:
The link I pasted is my Sharepoint link ("https://fujitsu.sharepoint.com/teams/Global-9f53b187/Migration/Forms/AllItems.aspx")
This is the code for the 'Migration Start' button
Private Sub btnMigrate_Click()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim answer As Integer
FromPath = txtPath.Value
ToPath = txtURL.Value
txtPath.BackColor = vbWhite
txtURL.BackColor = vbWhite
If txtPath.Value = "" Then
MsgBox "Enter the migration source path", vbOKOnly + vbInformation, "WARNING!"
txtPath.BackColor = vbRed
ElseIf txtURL.Value = "" Then
MsgBox "Enter the destination URL", vbOKOnly + vbInformation, "WARNING!"
txtURL.BackColor = vbRed
ElseIf Not IsEmpty(txtPath.Value) And Not IsEmpty(txtURL.Value) Then
Me.Hide
Set FSO = CreateObject("scripting.filesystemobject")
FSO.CopyFolder Source:=FromPath, Destination:=ToPath
txtPath.Value = ""
txtPath.BackColor = vbWhite
txtURL.Value = ""
txtURL.BackColor = vbWhite
MsgBox "The migration was successful!", vbOKOnly + vbInformation, "SUCCESSFUL!"
answer = MsgBox("Would you like to migrate again?", vbQuestion + vbYesNo + vbDefaultButton2, "QUESTION")
If answer = vbYes Then
txtPath.Value = ""
txtPath.BackColor = vbWhite
txtURL.Value = ""
txtURL.BackColor = vbWhite
Migration.Show
Else
Me.Hide
End If
End If
End Sub
Related
I am using excel 2016., I used a form to fill data in access, but when click refresh I start getting "run time error 3251" on this one. If can someone help me to find out. please.
I am fetching data from access to excel VBA user form & then doing some updates & deleting as per requirement.
Error
Msg=> "Run-time error '3251': Current Recordset does not support
updating. This may be a limitation of the provider, or of the
selected locktype."
Code
Private Sub CommandButton1_Click()
''''''''Add Validation here '''''''''''''
If IsDate(Me.txtdate1.Value) = False Then
MsgBox "Please enter the correct Transaction_Date", vbCritical
Exit Sub
End If
If Me.txtcampany1.Value = "" Then
MsgBox "Please enter the Campany", vbCritical
Exit Sub
End If
If Me.txttrans1.Value = "" Then
MsgBox "Please enter the Type_Transaction", vbCritical
Exit Sub
End If
If Me.txtdebit.Value <> "" Then
If IsNumeric(Me.txtdebit.Value) = False Then
MsgBox "Please enter the correct Debit", vbCritical
Exit Sub
End If
End If
If Me.txtcredit.Value <> "" Then
If IsNumeric(Me.txtcredit.Value) = False Then
MsgBox "Please enter the correct credit", vbCritical
Exit Sub
End If
End If
If Me.txtbank1.Value = "" Then
MsgBox "Please enter the By_Bank", vbCritical
Exit Sub
End If
If Me.txtStuff1.Value = "" Then
MsgBox "Please enter the Stuff", vbCritical
Exit Sub
End If
If Me.Texremr1.Value = "" Then
MsgBox "Please enter the Comment", vbCritical
Exit Sub
End If
If Me.Textdenu.Value = "" Then
MsgBox "Please enter the Deposits_Number", vbCritical
Exit Sub
End If
If Me.Textattech.Value = "" Then
MsgBox "Please enter the Attchment_File", vbCritical
Exit Sub
End If
If Me.bra1.Value = "" Then
MsgBox "Please enter the Branch", vbCritical
Exit Sub
End If
If Me.depf.Value = "" Then
MsgBox "Please enter the Deposits_For", vbCritical
Exit Sub
End If
'''''''''''''''''''''''''''''''''''''''''
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim qry As String
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\Database.accdb"
If Me.txtId.Value <> "" Then
qry = "SELECT * FROM Public_Deposits WHERE ID = " & Me.txtId.Value
Else
qry = "SELECT * FROM Public_Deposits Where ID = 0"
End If
rst.Open qry, cnn, adOpenKeyset, adLockOptimistic
If rst.RecordCount = 0 Then
rst.AddNew
End If
rst.Fields("Transaction_Date").Value = VBA.CDate(Me.txtdate1.Value)
rst.Fields("Campany").Value = Me.txtcampany1.Value
rst.Fields("Type_Transaction").Value = Me.txttrans1.Value
If Me.txtdebit.Value <> "" Then rst.Fields("Debit").Value = Me.txtdebit.Value
If Me.txtcredit <> "" Then rst.Fields("credit").Value = Me.txtcredit
rst.Fields("By_Bank").Value = Me.txtbank1.Value
rst.Fields("Stuff").Value = Me.txtStuff1.Value
rst.Fields("Comment").Value = Me.Texremr1.Value
rst.Fields("Deposits_Number").Value = Me.Textdenu.Value
rst.Fields("Branch").Value = Me.bra1.Value
rst.Fields("Deposits_For").Value = Me.depf.Value
rst.Fields("UpdateTimestamp").Value = VBA.Now
rst.Update
Me.txtdate1.Value = ""
Me.txtcampany1.Value = ""
Me.txttrans1.Value = ""
Me.txtdebit.Value = ""
Me.txtcredit.Value = ""
Me.txtbank1.Value = ""
Me.txtStuff1.Value = ""
Me.Texremr1.Value = ""
Me.Textdenu.Value = ""
Me.bra1.Value = ""
Me.depf.Value = ""
MsgBox "Updated Successfully", vbInformation
Call Me.List_box_Data
End Sub
I am a beginner in Excel VBA but I would like to create a file where I can select certain worksheets by means of a userform with checkboxes. In principle, it is then intended that only the check boxes where the value is true should be exported.
Below I have 2 codes that work well separately from each other but I have not yet been able to get them to work together.
Note: both codes come from the internet.
If possible I would like to write a loop to keep the overview.
the code to export sheets as pdf and put them in a outlook
Sub Saveaspdfandsend1()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xArrShetts As Variant
Dim xPDFNameAddress As String
Dim xStr As String
xArrShetts = Array("test", "Sheet1", "Sheet2") 'Enter the sheet names you will send as pdf files enclosed with quotation marks and separate them with comma. Make sure there is no special characters such as \/:"*<>| in the file name.
For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
Exit Sub
End If
Next
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard
Else
End If
xArrShetts(I) = xStr
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
.Attachments.Add xArrShetts(I)
Next
If DisplayEmail = False Then
'.Send
End If
End With
End Sub
the other code i tried I can see which checkbox is checked unfortunately I can't rewrite it so only the checked boxes will be exported to pdf.
Private Sub CommandButton100_Click()
For i = 100 To 113
If UserForm2.Controls("CheckBox" & i).Value = True Then
a = a + 1
End If
Next i
k = 1
For i = 100 To 113
If UserForm2.Controls("CheckBox" & i).Value = True And a = 1 Then
b = UserForm2.Controls("CheckBox" & i).Caption & "."
ElseIf UserForm2.Controls("CheckBox" & i).Value = True And k <> a Then
b = b & UserForm2.Controls("CheckBox" & i).Caption & ", "
k = k + 1
ElseIf UserForm2.Controls("CheckBox" & i).Value = True And k = a Then
b = b & "and " & UserForm2.Controls("CheckBox" & i).Caption & "."
End If
Next i
MsgBox ("You have selected " & b)
End Sub
Can someone help me please I am struggling for some time now?
Please, try the next function:
Private Function sheetsArr(uF As UserForm) As Variant
Dim c As MSForms.Control, strCBX As String, arrSh
For Each c In uF.Controls
If TypeOf c Is MSForms.CheckBox Then
If c.value = True Then strCBX = strCBX & "," & c.Caption
End If
Next
sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function
It will return an array composed from the ticked check boxes caption.
It can be used demonstratively, in this way:
Sub testSheetsArrFunction()
Debug.Print Join(sheetsArr(UserForm2), ",")
End Sub
The above code will return in Immediate Window a string containing the checked check boxes caption (separated by comma). It may be run from a standard module, too. Of course, the function must be copied in that module. And the form to be loaded, having some check boxes ticked.
Now, you have to change a single code line in your (working) code:
Replace:
xArrShetts = Array("test", "Sheet1", "Sheet2")
with:
xArrShetts = sheetsArr(UserForm2)
It should use the array built in the above function. Of course the function have to be copied in the module where to be called. If placed in the form code module, it can be simple called as:
xArrShetts = sheetsArr(Me)
Edited:
You should only paste the next code in the form code module and show the form:
Private Sub CommandButton1_Click()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xArrShetts As Variant
Dim xPDFNameAddress As String
Dim xStr As String
'xArrShetts = Array("test", "Sheet1", "Sheet2") 'Enter the sheet names you will send as pdf files enclosed with quotation marks and separate them with comma. Make sure there is no special characters such as \/:"*<>| in the file name.
xArrShetts = sheetsArr(Me)
For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
Exit Sub
End If
Next
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard
End If
xArrShetts(I) = xStr
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
.Attachments.Add xArrShetts(I)
Next
If DisplayEmail = False Then
'.Send
End If
End With
End Sub
Private Function sheetsArr(uF As UserForm) As Variant
Dim c As MSForms.Control, strCBX As String, arrSh
For Each c In uF.Controls
If TypeOf c Is MSForms.CheckBox Then
If c.Value = True Then strCBX = strCBX & "," & c.Caption
End If
Next
sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function
I have the following code and the YesNoCancel options don't do anything. What am I doing wrong please?
Option Explicit
Sub wwb()
'lists each book that's OPEN
Dim wb As Workbook, ws As Workbook, wd As Workbook
Set wd = ThisWorkbook
MsgBox wd.Name
Dim output As Integer
Dim msgValue
For Each wb In Application.Workbooks
If wb.Name = wd.Name Then
MsgBox "The destination WorkBook is :" & wd.Name
Else
output = MsgBox("Is " & wb.Name & " your source file to import data?", vbYesNoCancel, "Please confirm source file")
If msgValue = vbYes Then
MsgBox "test yes"
ElseIf msgValue = vbNo Then
MsgBox "test No"
ElseIf msgValue = vbCancel Then
MsgBox "Test cancel"
End If
End If
Next wb
End Sub
You need to check output instead of msgValue
output = MsgBox("Is " & wb.Name & " your source file to import data?", vbYesNoCancel, "Please confirm source file")
If output = vbYes Then
MsgBox "test yes"
ElseIf output = vbNo Then
MsgBox "test No"
ElseIf output = vbCancel Then
MsgBox "Test cancel"
End If
Below code is working fine and doing what I want to do. But when I use it as Add-In to run on all other workbooks it says subscript out of range.
There may be object related confusion or the add-in gets confused which workbook to refer.
I'm new to vba and request all of you to help.
Sub mac_3()
Dim xlsname As String
Dim d As VbMsgBoxResult: d = MsgBox("Would you like to add record?" & vbNewLine & vbNewLine & "(Esc/Cancel to add something.)", vbYesNoCancel + vbQuestion, "Details!")
If d = vbNo Then
Sheets("MPSA").Range("a13").Value = "Record is not available."
Sheets("MPSA").Range("a13").Font.Bold = True
ActiveWorkbook.Save
GoTo savefile
Exit Sub
End If
If d = vbCancel Then
Dim myValue As Variant
myValue = Application.InputBox("Non-Transactional number!", "Please paste number[separate with comma ,]:")
If myValue = False Then
Exit Sub
Else
Sheets("MPSA").Range("a13").Value = "Dataot available for : " & myValue
Sheets("MPSA").Range("a13").Font.Bold = True
ActiveWorkbook.Save
GoTo savefile
Exit Sub
End If
End If
On Error GoTo Cleanup
Application.DisplayAlerts = False: Application.EnableEvents = False: Application.ScreenUpdating = False
Sheets("MPSA").Range("a14:ac14").Value = Array( _
"ACCOUNT NAME", " ACCOUNT NUMBER", "AGE", "ENTITY NAME", "GROUP", _
"ITEM NUMBER", "ITEM NAME", "COMPONENT", "QUANTITY", "SUBSCRIPTIONS", _
"QUANTITY", "QUANTITY", "NUMBER", "ITEM NAME", _
"PART NUMBER", "PART NAME", "EDITION", "TYPE", "VERSION", "USAGE", _
"LIMIT", "NAME", "TART DATE", "END DATE", "ASSET STATUS", _
"CATEGORY", "ACCOUNT TYPE", "METHOD", "CENTER")
Sheets("MPSA").Range("a14:ac14").Font.Name = "Calibri"
Sheets("MPSA").Range("a14:ac14").Interior.ColorIndex = 24
Sheets("MPSA").Range("a14:ac14").Font.Bold = True
Sheets("MPSA").Range("a14:ac14").Borders.LineStyle = xlContinuous
Sheets("MPSA").Columns.AutoFit
Dim Target_Path: Target_Path = Application.GetOpenFilename
Do While Target_Path <> False ' <-- loop until user cancels
Dim Target_Workbook As Workbook: Set Target_Workbook = Workbooks.Open(Target_Path)
Target_Workbook.Sheets(1).Cells.WrapText = True
Target_Workbook.Sheets(1).Cells.WrapText = False
Target_Workbook.Sheets(1).Range("A1").CurrentRegion.Offset(1).Copy _
ThisWorkbook.Sheets("MPSA").Range("a1000000").End(xlUp).Offset(1)
Target_Workbook.Close False
ActiveWorkbook.Save
Dim e As VbMsgBoxResult: e = MsgBox("Another Record?", vbYesNo + vbQuestion, "Next details!")
If e = vbNo Then
ThisWorkbook.Save
GoTo savefile
Exit Sub
End If
'If e = vbYes Then
Target_Path = Application.GetOpenFilename
Loop
GoTo savefile
savefile:
Application.DisplayAlerts = False
xlsname = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5)ActiveWorkbook.SaveAs Filename:="C:\Users\" & Environ$("username") & "\Desktop\New Folder\" & xlsname & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Cleanup:
If Err.Number <> 0 Then MsgBox "Something went wrong: " & vbCrLf & Err.Description
Application.DisplayAlerts = True: Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub
The problem is solved now. As suggested by #Tom, Add-In was confused about which worksheet to paste values in.
Well I defined another variable using Dim Source_Workbook as Workbook Set Source_Workbook as ActiveWorkbook
Thanks to all of you :)
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)