The following is the code that I use to look up a saved quotation and if any drawings exist for the quote attach it to the e-mail along with the quote. Right now it only attaches the first drawing that it finds. What I need is a way to Array the drawings it finds and then attach them along with the Quote to an e-mail. I have never used Dynamic arrays before and am looking for some help.
Thanks in advance
Private Sub emailq_Click()
Dim objOutlook As New Outlook.Application
Dim objMessage As MailItem
Dim app_str As String
Dim Msg As String, hdr As String, RES As Integer
Dim DwgPath As String, DwgDir As String, d1 As String, d2 As String
Dim DwgName As String, DwgRev As String, DirChk As String, DirChk2 As String
Dim AppID As Long
Dim FS, i As Integer
Dim DwgPathB As String
Dim QPath As String
Dim dwgArray() As String, intC As Integer, intA As Integer
Dim fs2 As String
'**************************************************************************************************************
' Locate Saved Quote File(s)
'**************************************************************************************************************
Quote.SetFocus
d1 = Quote.Text
QPath = "F:\Group\Quotes\" & Environ("Name") & "\" & d1 & "*.rtf"
DirChk = Dir(QPath)
If DirChk = "" Then
Msg = "Quote Not Found."
Msg = Msg & Chr(13) & Chr(13) & " NOTE: Quote was not saved to File."
hdr = " WARNING: CANNOT LOCATE Quote"
RES = MsgBox(Msg, 48, hdr)
Exit Sub
End If
With FileSearch
.NewSearch
.LookIn = "F:\Group\Quotes\" & Environ("Name") & "\"
.FileName = Quote
.FileType = msoFileTypeAllFiles
If .Execute > 1 Then
MsgBox "There were " & .FoundFiles.count & _
" Saved Version(s) to this Quotation." & Chr(13) & Chr(13) & "Click the OK Button to review the Version Number(s). " & _
"Determine the Version you want to Review and Add it to the end of the Quote Number (e.g. 927176v2)."
For i = 1 To .FoundFiles.count
MsgBox .FoundFiles(i)
Next i
Exit Sub
End If
End With
'**************************************************************************************************************
' Check for electronic drawing
'**************************************************************************************************************
QuoteNo.SetFocus
d2 = QuoteNo.Text
DwgPath = "F:\Group\Quotes\" & Environ("Name") & "\" & d2 & "\*set*.dwg"
DwgPathB = "F:\Group\Quotes\" & Environ("Name") & "\" & d2
DirChk2 = Dir(DwgPath)
If DirChk2 = "" Then
DwgPath = "F:\Group\Quotes\" & Environ("Name") & "\" & d2 & "*.dwg"
DwgPathB = "F:\Group\Quotes\" & Environ("Name") & "\"
DirChk2 = Dir(DwgPath)
End If
If DirChk2 <> "" Then
Dim Msg2, Style, Title, Help, Ctxt, Response, AddDrw
Msg2 = "The HT QMS has found a drawing associated with this Quote Number. Do you want to attach it to the E-mail?" ' Define message.
Style = vbYesNo + vbInformation + vbDefaultButton2 ' Define buttons.
Title = "Found Drawing"
Help = "DEMO.HLP"
Ctxt = 1000
Response = MsgBox(Msg2, Style, Title, Help, Ctxt)
If Response = vbYes Then
AddDrw = "Yes"
Else
AddDrw = "No"
End If
End If
If DirChk = "" And DirChk2 = "" Then
Msg = "A Quotation must be <Saved to File> before it can be sent via e-Mail."
Exit Sub
End If
'**************************************************************************************************************
'Send E-mail Routine
'**************************************************************************************************************
Set objMessage = objOutlook.CreateItem(olMailItem)
With objMessage
.To = Me![cust e-mail]
.Subject = "Quote Attached " & Me!Quote
.Body = "Please find attached Quote # " & Me!Quote & "." & Chr(13) & Chr(13)
If DirChk <> "" Then
.Attachments.Add "F:\Group\Quotes\" & Environ("Name") & "\" & DirChk
End If
If AddDrw = "Yes" Then
.Attachments.Add DwgPathB & DirChk2
End If
.Display
End With
'MsgBox "The Quotation " & Quote & " has Been Sent", vbInformation, "Quotation Sent"
End Sub
