H
Hanspeter
Dear all,
I would like to be able to also open and Attach PDF's in teh following Macro
I have written. CAn you help.
Sub GetEmailData()
Dim Msg As String
Msg = "Send Emails? " & vbCrLf & vbCrLf _
& "Please make sure that all source files are closed"
If MsgBox(Msg, vbQuestion + vbYesNo, "SEND EMAILS") = vbNo Then
Exit Sub
End If
'COPY MAIL ONLY OPTIONS
Range("M19:M30").Select
Selection.Copy
Range("I19").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Dim SourceFile As String, SourceRoot As String, SourceRef As String,
SourceFileNameOnly As String
Dim I As Integer, SendMailCol As Integer, PriorityCol As Integer, _
ZipCol As Integer, RecptCol As Integer, RefCol As Integer
Dim Row As Integer, Col As Integer, SubCol As Integer, FileNameCol As
Integer
Dim ControlFile, FileOnlyName As String, FileRoot As String, SubFolder
As String
Dim SendMail As String, Priority As String, Zip As String
Dim Recpt As String, Ref As Integer, LoopCounter As Integer
Row = 19
Col = 5
FileNameCol = 6
SubCol = 3
SendMailCol = 7
PriorityCol = 8
ZipCol = 9
RecptCol = 10
RefCol = 11
I = 0
Sheets("Send Mail").Select
FileRoot = Range("C11")
Cells(Row, Col).Select
SourceFile = Cells(Row, Col)
FileOnlyName = Cells(Row, FileNameCol)
SubFolder = Cells(Row, SubCol)
MainRegion = Cells(Row, 1)
SendMail = Cells(Row, SendMailCol)
Priority = Cells(Row, PriorityCol)
Zip = Cells(Row, ZipCol)
Recpt = Cells(Row, RecptCol)
Ref = Cells(Row, RefCol)
SourceFileNameOnly = Cells(Row, 4)
'LOOP THROUGH FILES
Do While SourceFile <> "end of list"
Cells(Row, Col).Select
Application.ScreenUpdating = False
If UCase(SendMail) = "Y" Then
LoopCounter = Ref
ReDim AddArray(20, 7) As String
If Ref <> 0 Then
Do While LoopCounter = Ref
'ZIP FILE AND ASSIGN TO ARRAY
If UCase(Zip) = "Y" Then
I = I + 1
AddArray(I, 1) = FileOnlyName
AddArray(I, 2) = Priority
AddArray(I, 3) = Recpt
AddArray(I, 4) = Ref
AddArray(I, 5) = SubFolder
AddArray(I, 6) = SourceFile
AddArray(I, 7) = SourceFileNameOnly
Else
If UCase(Cells(Row, 12)) = "Y" Then
I = I + 1
AddArray(I, 1) = "MAIL ONLY"
AddArray(I, 2) = Priority
AddArray(I, 3) = Recpt
AddArray(I, 4) = Ref
AddArray(I, 5) = ""
AddArray(I, 6) = ""
AddArray(I, 7) = ""
End If
End If
Application.ScreenUpdating = True
Row = Row + 1
Cells(Row, Col).Select
SourceFile = Cells(Row, Col)
FileOnlyName = Cells(Row, FileNameCol)
SubFolder = Cells(Row, SubCol)
MainRegion = Cells(Row, 1)
SendMail = Cells(Row, SendMailCol)
Priority = Cells(Row, PriorityCol)
Zip = Cells(Row, ZipCol)
Recpt = Cells(Row, RecptCol)
Ref = Cells(Row, RefCol)
SourceFileNameOnly = Cells(Row, 4)
Loop
End If
'CALL SEND MAIL
Call Send_Mail(AddArray)
End If
'NEXT FILE
Application.ScreenUpdating = True
Row = Row + 1
Cells(Row, Col).Select
SourceFile = Cells(Row, Col)
FileOnlyName = Cells(Row, FileNameCol)
SubFolder = Cells(Row, SubCol)
MainRegion = Cells(Row, 1)
SendMail = Cells(Row, SendMailCol)
Priority = Cells(Row, PriorityCol)
Zip = Cells(Row, ZipCol)
Recpt = Cells(Row, RecptCol)
Ref = Cells(Row, RefCol)
SourceFileNameOnly = Cells(Row, 4)
I = 0
Loop
Application.ScreenUpdating = True
Range("A1").Select
MsgBox "Process Complete", vbInformation, "SEND MAIL"
End Sub
Sub Send_Mail(AddArray)
'Microsoft Outlook nn Object Library should be included in
Tools/References
Dim OutApp As Object
Dim OutMail As Object
Dim mSubject As String, mBody As String, mDate As String, mSubFolder As
String, _
mPriority As String, mRecpt As String, mRoot As String, mFileName As
String, _
mFullPath As String, mSourceFile As String, mTo As String, mCC As
String, mBCC As String, _
mSourceFileNameOnly As String
Dim I As Integer, mRef As Integer
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
mPriority = AddArray(1, 2)
mRecpt = AddArray(1, 3)
mRef = AddArray(1, 4)
mSubFolder = AddArray(1, 5)
mRoot = Worksheets("Send mail").Range("C11")
I = 1
mTo = Worksheets("Mail Details").Cells(3, mRef)
mCC = Worksheets("Mail Details").Cells(5, mRef)
mBCC = Worksheets("Mail Details").Cells(7, mRef)
mSubject = Worksheets("Mail Details").Cells(9, mRef)
mBody = Worksheets("Mail Details").Cells(11, mRef)
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = mTo
.cc = mCC
.Bcc = mBCC
.Subject = mSubject
.Body = mBody
If UCase(mRecpt) = "Y" Then
.ReadReceiptRequested = True
Else
.ReadReceiptRequested = False
End If
Select Case UCase(mPriority)
Case "H"
.Importance = olImportanceHigh
Case "L"
.Importance = olImportanceLow
Case Else
.Importance = olImportanceNormal
End Select
Do While AddArray(I, 1) <> ""
mFileName = AddArray(I, 1)
mFullPath = mRoot & mSubFolder
If AddArray(I, 1) = "MAIL ONLY" Then
Else
'ZIP FILE
mSourceFile = AddArray(I, 6)
mSourceFileNameOnly = AddArray(I, 7)
Call ZipIt(mFullPath, mSourceFile, mFileName,
mSourceFileNameOnly)
'ATTACH FILE
mDate = Format(Now, "_dd_mm_yyyy")
mFullPath = mRoot & mSubFolder & Left(mFileName,
Len(mFileName) - 4) & mDate & ".zip"
.Attachments.Add mFullPath
'DELETE ZIP FILE
Call DeleteZip(mFullPath)
End If
I = I + 1
Loop
If Worksheets("Send Mail").Range("E6") = 2 Then
.Send
Else
.Display
End If
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Sub NewZip(sPath)
'Create empty Zip File
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Function Split97(sStr As Variant, sdelim As String) As Variant
Split97 = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") & """}")
End Function
Sub ZipIt(mFullPath As String, mSourceFile As String, mFileName As String, _
mSourceFileNameOnly As String)
Workbooks.Open Filename:=mSourceFile, UpdateLinks:=3
Dim strDate As String, DefPath As String
Dim FileNameZip, FileNamexls
Dim oApp As Object
Dim FileExtStr As String
DefPath = mFullPath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
' 'Create date/time string and the temporary xl* and Zip file name
If Val(Application.Version) < 12 Then
FileExtStr = ".xls"
'Else
' Select Case ActiveWorkbook.FileFormat
' Case 51: FileExtStr = ".xlsx"
' Case 52: FileExtStr = ".xlsm"
' Case 56: FileExtStr = ".xls"
' Case 50: FileExtStr = ".xlsb"
' Case Else: FileExtStr = "notknown"
' End Select
End If
strDate = Format(Now, "_dd_mm_yyyy")
FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - 4) & strDate & ".zip"
FileNamexls = DefPath & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - 4) & strDate & FileExtStr
If Dir(FileNameZip) = "" And Dir(FileNamexls) = "" Then
'Make copy of the activeworkbook
ActiveWorkbook.SaveCopyAs FileNamexls
'Create empty Zip File
NewZip (FileNameZip)
'Copy the file in the compressed folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameZip).CopyHere FileNamexls
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
'Delete the temporary xls file
Kill FileNamexls
End If
Windows(mSourceFileNameOnly).Activate
ActiveWorkbook.Close savechanges = False
End Sub
Sub DeleteZip(mFilePath)
Kill mFilePath
End Sub
I would like to be able to also open and Attach PDF's in teh following Macro
I have written. CAn you help.
Sub GetEmailData()
Dim Msg As String
Msg = "Send Emails? " & vbCrLf & vbCrLf _
& "Please make sure that all source files are closed"
If MsgBox(Msg, vbQuestion + vbYesNo, "SEND EMAILS") = vbNo Then
Exit Sub
End If
'COPY MAIL ONLY OPTIONS
Range("M19:M30").Select
Selection.Copy
Range("I19").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Dim SourceFile As String, SourceRoot As String, SourceRef As String,
SourceFileNameOnly As String
Dim I As Integer, SendMailCol As Integer, PriorityCol As Integer, _
ZipCol As Integer, RecptCol As Integer, RefCol As Integer
Dim Row As Integer, Col As Integer, SubCol As Integer, FileNameCol As
Integer
Dim ControlFile, FileOnlyName As String, FileRoot As String, SubFolder
As String
Dim SendMail As String, Priority As String, Zip As String
Dim Recpt As String, Ref As Integer, LoopCounter As Integer
Row = 19
Col = 5
FileNameCol = 6
SubCol = 3
SendMailCol = 7
PriorityCol = 8
ZipCol = 9
RecptCol = 10
RefCol = 11
I = 0
Sheets("Send Mail").Select
FileRoot = Range("C11")
Cells(Row, Col).Select
SourceFile = Cells(Row, Col)
FileOnlyName = Cells(Row, FileNameCol)
SubFolder = Cells(Row, SubCol)
MainRegion = Cells(Row, 1)
SendMail = Cells(Row, SendMailCol)
Priority = Cells(Row, PriorityCol)
Zip = Cells(Row, ZipCol)
Recpt = Cells(Row, RecptCol)
Ref = Cells(Row, RefCol)
SourceFileNameOnly = Cells(Row, 4)
'LOOP THROUGH FILES
Do While SourceFile <> "end of list"
Cells(Row, Col).Select
Application.ScreenUpdating = False
If UCase(SendMail) = "Y" Then
LoopCounter = Ref
ReDim AddArray(20, 7) As String
If Ref <> 0 Then
Do While LoopCounter = Ref
'ZIP FILE AND ASSIGN TO ARRAY
If UCase(Zip) = "Y" Then
I = I + 1
AddArray(I, 1) = FileOnlyName
AddArray(I, 2) = Priority
AddArray(I, 3) = Recpt
AddArray(I, 4) = Ref
AddArray(I, 5) = SubFolder
AddArray(I, 6) = SourceFile
AddArray(I, 7) = SourceFileNameOnly
Else
If UCase(Cells(Row, 12)) = "Y" Then
I = I + 1
AddArray(I, 1) = "MAIL ONLY"
AddArray(I, 2) = Priority
AddArray(I, 3) = Recpt
AddArray(I, 4) = Ref
AddArray(I, 5) = ""
AddArray(I, 6) = ""
AddArray(I, 7) = ""
End If
End If
Application.ScreenUpdating = True
Row = Row + 1
Cells(Row, Col).Select
SourceFile = Cells(Row, Col)
FileOnlyName = Cells(Row, FileNameCol)
SubFolder = Cells(Row, SubCol)
MainRegion = Cells(Row, 1)
SendMail = Cells(Row, SendMailCol)
Priority = Cells(Row, PriorityCol)
Zip = Cells(Row, ZipCol)
Recpt = Cells(Row, RecptCol)
Ref = Cells(Row, RefCol)
SourceFileNameOnly = Cells(Row, 4)
Loop
End If
'CALL SEND MAIL
Call Send_Mail(AddArray)
End If
'NEXT FILE
Application.ScreenUpdating = True
Row = Row + 1
Cells(Row, Col).Select
SourceFile = Cells(Row, Col)
FileOnlyName = Cells(Row, FileNameCol)
SubFolder = Cells(Row, SubCol)
MainRegion = Cells(Row, 1)
SendMail = Cells(Row, SendMailCol)
Priority = Cells(Row, PriorityCol)
Zip = Cells(Row, ZipCol)
Recpt = Cells(Row, RecptCol)
Ref = Cells(Row, RefCol)
SourceFileNameOnly = Cells(Row, 4)
I = 0
Loop
Application.ScreenUpdating = True
Range("A1").Select
MsgBox "Process Complete", vbInformation, "SEND MAIL"
End Sub
Sub Send_Mail(AddArray)
'Microsoft Outlook nn Object Library should be included in
Tools/References
Dim OutApp As Object
Dim OutMail As Object
Dim mSubject As String, mBody As String, mDate As String, mSubFolder As
String, _
mPriority As String, mRecpt As String, mRoot As String, mFileName As
String, _
mFullPath As String, mSourceFile As String, mTo As String, mCC As
String, mBCC As String, _
mSourceFileNameOnly As String
Dim I As Integer, mRef As Integer
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
mPriority = AddArray(1, 2)
mRecpt = AddArray(1, 3)
mRef = AddArray(1, 4)
mSubFolder = AddArray(1, 5)
mRoot = Worksheets("Send mail").Range("C11")
I = 1
mTo = Worksheets("Mail Details").Cells(3, mRef)
mCC = Worksheets("Mail Details").Cells(5, mRef)
mBCC = Worksheets("Mail Details").Cells(7, mRef)
mSubject = Worksheets("Mail Details").Cells(9, mRef)
mBody = Worksheets("Mail Details").Cells(11, mRef)
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = mTo
.cc = mCC
.Bcc = mBCC
.Subject = mSubject
.Body = mBody
If UCase(mRecpt) = "Y" Then
.ReadReceiptRequested = True
Else
.ReadReceiptRequested = False
End If
Select Case UCase(mPriority)
Case "H"
.Importance = olImportanceHigh
Case "L"
.Importance = olImportanceLow
Case Else
.Importance = olImportanceNormal
End Select
Do While AddArray(I, 1) <> ""
mFileName = AddArray(I, 1)
mFullPath = mRoot & mSubFolder
If AddArray(I, 1) = "MAIL ONLY" Then
Else
'ZIP FILE
mSourceFile = AddArray(I, 6)
mSourceFileNameOnly = AddArray(I, 7)
Call ZipIt(mFullPath, mSourceFile, mFileName,
mSourceFileNameOnly)
'ATTACH FILE
mDate = Format(Now, "_dd_mm_yyyy")
mFullPath = mRoot & mSubFolder & Left(mFileName,
Len(mFileName) - 4) & mDate & ".zip"
.Attachments.Add mFullPath
'DELETE ZIP FILE
Call DeleteZip(mFullPath)
End If
I = I + 1
Loop
If Worksheets("Send Mail").Range("E6") = 2 Then
.Send
Else
.Display
End If
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Sub NewZip(sPath)
'Create empty Zip File
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Function Split97(sStr As Variant, sdelim As String) As Variant
Split97 = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") & """}")
End Function
Sub ZipIt(mFullPath As String, mSourceFile As String, mFileName As String, _
mSourceFileNameOnly As String)
Workbooks.Open Filename:=mSourceFile, UpdateLinks:=3
Dim strDate As String, DefPath As String
Dim FileNameZip, FileNamexls
Dim oApp As Object
Dim FileExtStr As String
DefPath = mFullPath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
' 'Create date/time string and the temporary xl* and Zip file name
If Val(Application.Version) < 12 Then
FileExtStr = ".xls"
'Else
' Select Case ActiveWorkbook.FileFormat
' Case 51: FileExtStr = ".xlsx"
' Case 52: FileExtStr = ".xlsm"
' Case 56: FileExtStr = ".xls"
' Case 50: FileExtStr = ".xlsb"
' Case Else: FileExtStr = "notknown"
' End Select
End If
strDate = Format(Now, "_dd_mm_yyyy")
FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - 4) & strDate & ".zip"
FileNamexls = DefPath & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - 4) & strDate & FileExtStr
If Dir(FileNameZip) = "" And Dir(FileNamexls) = "" Then
'Make copy of the activeworkbook
ActiveWorkbook.SaveCopyAs FileNamexls
'Create empty Zip File
NewZip (FileNameZip)
'Copy the file in the compressed folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameZip).CopyHere FileNamexls
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
'Delete the temporary xls file
Kill FileNamexls
End If
Windows(mSourceFileNameOnly).Activate
ActiveWorkbook.Close savechanges = False
End Sub
Sub DeleteZip(mFilePath)
Kill mFilePath
End Sub