The VBA code currently works fine, but it will run continuously within the time period assigned to the code. I wish to add some coding, so that the VBA code will stop, once it has sent the first successful mail but still restart the next day. The VBA code is running for 1 hour, and the mail could be sent whenever within this period. Currently the model is sending several mails per day. The VBA is written as per below:
Sub AutoRefresh4(when As Date)
Application.OnTime when, "VLCC_Report"
End Sub
Sub VLCC_Report()
Dim LastSavedDate As Date
LastSavedDate = Format(FileDateTime("XXX"), "dd.mm.yyyy")
Dim TodaysDate As Date
Dim TimeStart, TimeEnd
TimeStart = TimeSerial(10, 0, 0)
TimeEnd = TimeSerial(11, 0, 0)
TodaysDate = Format(Now(), "dd.mm.yyyy")
If TodaysDate = LastSavedDate Then
Application.DisplayAlerts = False
Workbooks.Open ("YYY")
Workbooks.Open ("XXX")
If Workbooks("YYY").Worksheets(2).Range("F1") = 0 Then
Workbooks("XXX").Worksheets(1).Range("A1:Q71").Copy
Workbooks("YYY").Worksheets(2).Range("A2:Q72").PasteSpecial (xlPasteValues)
Workbooks("YYY").Worksheets(2).Range("A1") = "Last Refreshed:"
Workbooks("YYY").Worksheets(2).Range("C1") = Now
End If
End If
If Workbooks("YYY").Worksheets(2).Range("F1") = 1 Then
Dim EmailApplication As Object
Dim EmailItem As Object
Dim Table As Range
Dim Pic As Picture
Dim Sheet As Worksheet
Dim WordDoc As Word.document
Dim Path As String
Dim Filename As String
Dim SHP As Object
Path = "C:\ "
Filename = "VLCC Report" & ".pdf"
Set Sheet = Workbooks("YYY").Worksheets(1)
Set Table = Sheet.Range("B3:I73")
Table.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & Filename, IgnorePrintAreas:=True
Set EmailApplication = CreateObject("Outlook.Application")
Set EmailItem = EmailApplication.CreateItem(0)
Set Sheet = Workbooks("YYY").Worksheets(1)
Set Table = Sheet.Range("B3:I73")
Sheet.Activate
Table.Copy
Set Pic = Sheet.Pictures.Paste
Pic.Cut
With EmailItem
EmailItem.To = "aaa"
EmailItem.CC = ""
EmailItem.Bcc = ""
EmailItem.Importance = 2
EmailItem.Subject = "VLCC Report " & Format(Date, "DD.MM.YYYY")
EmailItem.Attachments.Add ("C:\")
EmailItem.Display
Set WordDoc = EmailItem.GetInspector.WordEditor
With WordDoc.Range
.PasteAndFormat wdChartPicture
.Application.Selection.Paragraphs.Alignment = wdAlignParagraphCenter
With WordDoc.InlineShapes(1)
.ScaleHeight = 110
End With
End With
EmailItem.HTMLBody = "<Body style = font-size:11pt; font-family:Calibri>" & "Hi, <p>Please see table below: <p>" & .HTMLBody
End With
EmailItem.Send
Set EmailItem = Nothing
Set EmailApplication = Nothing
End If
If Workbooks("YYY ").Worksheets(1).Range("F1") = 1 Then
Dim EmailApplication2 As Object
Dim EmailItem2 As Object
Set EmailApplication2 = CreateObject("Outlook.Application")
Set EmailItem2 = EmailApplication.CreateItem(0)
EmailItem.To = "aaa"
EmailItem.CC = ""
EmailItem.Bcc = ""
EmailItem.Importance = 2
EmailItem.Subject = "ERROR: VLCC Report"
EmailItem.Body = "Hi," & Chr(10) & Chr(10) & "Please check VLCC report" & Chr(10) & Chr(10) & "Best regards" & Chr(10) & "André Blokhus"
EmailItem.Send
Set EmailItem = Nothing
Set EmailApplication = Nothing
End If
Application.CutCopyMode = False
Workbooks("XXX").Save
Workbooks("XXX").Close SaveChanges:=False
Workbooks("YYY ").Save
Workbooks("YYY").SaveAs ("YYY, "DD.MM.YY") & ".xlsx?web=1")
Workbooks("YYY - " & Format(Now(), "DD.MM.YY") & ".xlsx").Save
Workbooks("YYY - " & Format(Now(), "DD.MM.YY") & ".xlsx").Close
Application.DisplayAlerts = True
If Time > TimeStart And Time < TimeEnd Then
AutoRefresh4 Now + TimeSerial(0, 15, 0)
Else
If Time < TimeStart Then AutoRefresh4 Date + TimeStart
If Time > TimeStart Then AutoRefresh4 (Date + 1) + TimeStart
End If
End Sub
I'm trying to loop through all word documents in a folder and put all the comments for each file into an Excel workbook.
When I run my code I get the following error "Run-time error '91' Object variable or With block Variable not set.
The code only gets comments from the first file in the directory, then errors, it's not looping.
I've looked at numerous websites and found plenty of references for extracting comments into excel, but not for all word files in a directory.
https://answers.microsoft.com/en-us/msoffice/forum/all/export-word-review-comments-in-excel/54818c46-b7d2-416c-a4e3-3131ab68809c
https://www.mrexcel.com/board/threads/extracting-comments-from-word-document-to-excel.1126759/
This website looked promising for what I need to do, but no one answered his question
Extracting data from multiple word docs to single excel
I updated the code to open each word file, but I get the following error: Run-time error '5': Invalid procedure call or argument
It appears to open each word document but doesn't populate the excel sheet with the comments.
UPDATED CODE:
'VBA List all files in a folder using Dir
Private Sub LoopThroughWordFiles()
'Variable Declaration
Dim sFilePath As String
Dim sFileName As String
Dim i As Integer, HeadingRow As Integer
Dim objPara As Paragraph
Dim objComment As Comment
Dim strSection As String
Dim strTemp
Dim myRange As Range
'Specify File Path
sFilePath = "C:\CommentTest"
'Check for back slash
If Right(sFilePath, 1) <> "\" Then
sFilePath = sFilePath & "\"
End If
'Create an object for Excel.
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
'Create a workbook
Set xlWB = xlApp.Workbooks.Add
'Create Excel worksheet
With xlWB.Worksheets(1)
' Create Heading
HeadingRow = 1
.Cells(HeadingRow, 1).Formula = "File Name"
.Cells(HeadingRow, 2).Formula = "Comment"
.Cells(HeadingRow, 3).Formula = "Page"
.Cells(HeadingRow, 4).Formula = "Paragraph"
.Cells(HeadingRow, 5).Formula = "Comment"
.Cells(HeadingRow, 6).Formula = "Reviewer"
.Cells(HeadingRow, 7).Formula = "Date"
strSection = "preamble" 'all sections before "1." will be labeled as "preamble"
strTemp = "preamble"
xlRow = 1
sFileName = Dir(sFilePath)
MsgBox ("sFileName: " + sFileName)
MsgBox ("sFilePath: " + sFilePath)
vFile = Dir(sFilePath & "*.*")
Do While sFileName <> ""
Set oDoc = Documents.Open(Filename:=sFilePath & vFile)
For i = 1 To ActiveDocument.Comments.count
Set myRange = ActiveDocument.Comments(i).Scope
strSection = ParentLevel(myRange.Paragraphs(1)) ' find the section heading for this comment
'MsgBox strSection
.Cells(i + HeadingRow, 1).Formula = ActiveDocument.Comments(i).Index
.Cells(i + HeadingRow, 2).Formula = ActiveDocument.Comments(i).Reference.Information(wdActiveEndAdjustedPageNumber)
.Cells(i + HeadingRow, 3).Value = strSection
.Cells(i + HeadingRow, 4).Formula = ActiveDocument.Comments(i).Range
.Cells(i + HeadingRow, 5).Formula = ActiveDocument.Comments(i).Initial
.Cells(i + HeadingRow, 6).Formula = Format(ActiveDocument.Comments(i).Date, "MM/dd/yyyy")
.Cells(i + HeadingRow, 7).Formula = ActiveDocument.Comments(i).Range.ListFormat.ListString
Next i
'- CLOSE WORD DOCUMENT
oDoc.Close SaveChanges:=False
vFile = Dir
'Set the fileName to the next available file
sFileName = Dir
Loop
End With
Set xlApp = Nothing
Set xlApp = CreateObject("Excel.Application")
End Sub
Function ParentLevel(Para As Word.Paragraph) As String
'From Tony Jollans
' Finds the first outlined numbered paragraph above the given paragraph object
Dim sStyle As Variant
Dim strTitle As String
Dim ParaAbove As Word.Paragraph
Set ParaAbove = Para
sStyle = Para.Range.ParagraphStyle
sStyle = Left(sStyle, 4)
If sStyle = "Head" Then
GoTo Skip
End If
Do While ParaAbove.OutlineLevel = Para.OutlineLevel
Set ParaAbove = ParaAbove.Previous
Loop
Skip:
strTitle = ParaAbove.Range.Text
strTitle = Left(strTitle, Len(strTitle) - 1)
ParentLevel = ParaAbove.Range.ListFormat.ListString & " " & strTitle
End Function
This version of the Excel macro outputs all the document comments to the active worksheet(starting at row 1), with the filenames in column A.
Sub ImportComments()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, StrCmt As String, StrTmp As String, i As Long, j As Long
StrCmt = Replace("File,Page,Author,Date & Time,H.Lvl,Commented Text,Comment,Reviewer,Resolution,Date Resolved,Edit Doc,Edit By,Edit Date", ",", vbTab)
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Dim wdApp As New Word.Application, wdDoc As Word.Document
wdApp.DisplayAlerts = False: wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
If .Comments.Count > 0 Then
' Process the Comments
For i = 1 To .Comments.Count
StrCmt = StrCmt & vbCr & Split(strFolder, ".doc")(0) & vbTab
With .Comments(i)
StrCmt = StrCmt & .Reference.Information(wdActiveEndAdjustedPageNumber) & _
vbTab & .Author & vbTab & .Date & vbTab
With .Scope.Paragraphs(1).Range
StrCmt = StrCmt & _
.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel").Paragraphs.First.Range.ListFormat.ListString & vbTab
With .Duplicate
.End = .End - 1
StrCmt = StrCmt & Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<P>") & vbTab
End With
End With
With .Range.Duplicate
.End = .End - 1
StrCmt = StrCmt & Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<P>")
End With
End With
Next
' Update the worksheet
With ActiveSheet
.Columns("E").NumberFormat = "#"
For i = 0 To UBound(Split(StrCmt, vbCr))
StrTmp = Split(StrCmt, vbCr)(i)
For j = 0 To UBound(Split(StrTmp, vbTab))
.Cells(i + 1, j + 1).Value = Split(StrTmp, vbTab)(j)
Next
Next
.Columns("A:M").AutoFit: .Columns("D:E").ColumnWidth = 25
End With
End If
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
wdApp.Quit
' Tell the user we're done.
MsgBox "Finished.", vbOKOnly
' Release object memory
Set wdDoc = Nothing: Set wdApp = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Try the following Excel macro. It loops through all Word documents in the selected folder, adding the comments from each commented document to new worksheets in the active workbook.
Sub ImportComments()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, StrCmt As String, StrTmp As String, i As Long, j As Long
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Dim wdApp As New Word.Application, wdDoc As Word.Document, xlWkSht As Worksheet
wdApp.DisplayAlerts = False: wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With wdDoc
If .Comments.Count > 0 Then
StrCmt = Replace("Page,Author,Date & Time,H.Lvl,Commented Text,Comment,Reviewer,Resolution,Date Resolved,Edit Doc,Edit By,Edit Date", ",", vbTab)
' Process the Comments
For i = 1 To .Comments.Count
With .Comments(i)
StrCmt = StrCmt & vbCr & .Reference.Information(wdActiveEndAdjustedPageNumber) & _
vbTab & .Author & vbTab & .Date & vbTab
With .Scope.Paragraphs(1).Range
StrCmt = StrCmt & _
.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel").Paragraphs.First.Range.ListFormat.ListString & vbTab
With .Duplicate
.End = .End - 1
StrCmt = StrCmt & Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<P>") & vbTab
End With
End With
With .Range.Duplicate
.End = .End - 1
StrCmt = StrCmt & Replace(Replace(.Text, vbTab, "<TAB>"), vbCr, "<P>")
End With
End With
Next
'Add a new worksheet
Set xlWkSht = .Worksheet.Add
' Update the worksheet
With xlWkSht
.Name = Split(strFile, ".doc")(0)
.Columns("D").NumberFormat = "#"
For i = 0 To UBound(Split(StrCmt, vbCr))
StrTmp = Split(StrCmt, vbCr)(i)
For j = 0 To UBound(Split(StrTmp, vbTab))
.Cells(i + 1, j + 1).Value = Split(StrTmp, vbTab)(j)
Next
Next
.Columns("A:L").AutoFit: .Columns("E:F").ColumnWidth = 25
End With
End If
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
wdApp.Quit
' Tell the user we're done.
MsgBox "Finished.", vbOKOnly
' Release object memory
Set wdDoc = Nothing: Set wdApp = Nothing: Set xlWkSht = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
I'm trying to attach three sheets to an email to be sent to a certain email address with a certain subject and content.
I currently attach each sheet in the workbook to an email each.
The two problems I'm looking to solve -
It currently cycles through all sheets, I want to attach sheets labeled "Account", "Subscription", "Users" so I can have another sheet for instructions.
Can I get attach all three to a single email? My research so far has come up blank.
I tried using something like the below, but that created errors in other areas that I don't know.
For Each ws In Sheets(Array("Account", "Subscription", "Users"))
Sub COMEON()
Dim onePublishObject As PublishObject
Dim oneSheet As Worksheet
Dim scriptingObject As Object
Dim outlookApplication As Object
Dim outlookMail As Object
Dim htmlBody As String
Dim htmlFile As String
Dim textStream, fil As String
Dim dummy As Workbook
Dim var As String
var = Range("A1").Value
Today = Format(Now(), "dd-mm-yyyy")
Set dummy = ActiveWorkbook
Set scriptingObject = CreateObject("Scripting.FileSystemObject")
Set outlookApplication = CreateObject("Outlook.Application")
For Each oneSheet In ActiveWorkbook.Worksheets
Dim StrBody As String
StrBody = " THIS IS A TEST" & " " & UCase(oneSheet.Name) & " " & "XYZ," & vbNewLine & _
vbNewLine & _
"Please FIND ATTACHED <B>'XYZ REPORT'<B>"
Application.DisplayAlerts = False
Sheets(oneSheet.Name).Copy
ActiveWorkbook.SaveAs dummy.Path & "\" & oneSheet.Name & ".csv"
ActiveWorkbook.Close
Application.DisplayAlerts = True
Set outlookMail = outlookApplication.CreateItem(0)
With outlookMail
.To = "XXXXX#XXXXX.com"
.htmlBody = StrBody & htmlBody
.attachments.Add dummy.Path & "\" & oneSheet.Name & ".csv"
.Display
.Subject = var & " - " & UCase(oneSheet.Name) & " CSV " & "(" & Today & ")"
End With
Next oneSheet
End Sub
Should be close:
Sub COMEON()
Dim oneSheet As Worksheet
Dim scriptingObject As Object
Dim outlookApplication As Object
Dim outlookMail As Object
Dim htmlBody As String
Dim dummy As Workbook
Dim var As String
Dim StrBody As String, arrSheets, Today
var = Range("A1").Value
Today = Format(Now(), "dd-mm-yyyy")
Set dummy = ActiveWorkbook
Set outlookApplication = CreateObject("Outlook.Application")
Set outlookMail = outlookApplication.CreateItem(0)
With outlookMail
.To = "XXXXX#XXXXX.com"
.bodyformat = 1 'HTML
.Subject = var & " - CSV " & "(" & Today & ")"
.Display
End With
StrBody = "THIS IS A TEST<br><br>Files: <ul>"
arrSheets = Array("Account", "Subscription", "Users")
For Each oneSheet In dummy.Worksheets
If Not IsError(Application.Match(oneSheet.Name, arrSheets, 0)) Then
StrBody = StrBody & "<li>" & oneSheet.Name & "</li>"
Application.DisplayAlerts = False
Sheets(oneSheet.Name).Copy
ActiveWorkbook.SaveAs dummy.Path & "\" & oneSheet.Name & ".csv"
ActiveWorkbook.Close
Application.DisplayAlerts = True
'add attachment
outlookMail.attachments.Add dummy.Path & "\" & oneSheet.Name & ".csv"
End If 'want this sheet
Next oneSheet
With outlookMail
.htmlBody = StrBody & "</ul>" & .htmlBody
End With
End Sub
Basically move stuff out of the loop that doesn't need to be there.
Short explanation: There are 3.Letter Templates and i want them to print per Button. But the main problem here is, that the Code is Printing the Template for every Person in the Worksheet also if the Person already had a Letter. It should look something like this.
-If the selected letter in "G3" is 1. Letter then send them only to People where the Cell Range in "Z" is Empty
-If the selected letter in "G3" is 2. Letter then send them only to People where the Cell in Range "Z" is 1.Letter
-If the selected letter in "G3" is 3. Letter then send them only to People where the Cell in Range "Z" is 2.Letter
What do i need to write right here?
Thank you for your answer in Advance!
https://i.stack.imgur.com/1NRbv.png
Option Explicit
Sub CreateWordDocuments()
Dim CustRow, CustCol, LastRow, TemplRow, DaysSince, FrDays, ToDays As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim OutApp, OutMail As Object
Dim WordContent As Word.Range
Dim WordDoc As Word.Document
Dim WordApp As Word.Application
With Tabelle1
If IsEmpty(Range("G3").Value) = True Then
MsgBox "Bitte wählen sie eine Vorlage aus"
.Range("G3").Select
Exit Sub
End If
TemplRow = .Range("B3").Value
TemplName = .Range("G3").Value
FrDays = .Range("L3").Value
ToDays = .Range("N3").Value
DocLoc = Tabelle2.Range("F" & TemplRow).Value
On Error Resume Next
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
End If
***LastRow = .Range("E9999").End(xlUp).Row
For CustRow = 8 To LastRow
DaysSince = .Range("P" & CustRow).Value
If TemplName <> .Range("Z" & CustRow).Value And DaysSince >= FrDays And DaysSince <= ToDays Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False)
For CustCol = 5 To 26
TagName = .Cells(7, CustCol).Value
TagValue = .Cells(CustRow, CustCol).Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With***
Next CustCol
If .Range("I3").Value = "PDF" Then
FileName = "Filename" & "\" & .Range("H" & CustRow).Value & " " & .Range("G" & CustRow).Value & " " & .Range("G3").Value & ".pdf"
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else:
FileName = ThisWorkbook.Path & "\" & .Range("H" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
.Range("Z" & CustRow).Value = TemplName
.Range("AA" & CustRow).Value = Now
If .Range("P3").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Tabelle1.Range("K" & CustRow).Value
.Subject = "Hallo, " & Tabelle1.Range("F" & CustRow).Value & "Test Test Test"
.Body = "Hallo, " & Tabelle1.Range("F" & CustRow).Value & "Test Test Test Test"
.Attachments.Add FileName
.Display
End With
Else:
WordDoc.PrintOut
WordDoc.Close
End If
Kill False '(FileName)
End If
Next CustRow
WordApp.Quit
End With
End Sub
Try the following: (not tested)
Sub CreateWordDocuments()
Dim CustRow As Long, CustCol As Long, LastRow As Long, TemplRow As Long, DaysSince As Long, FrDays As Long, ToDays As Long
Dim DocLoc As String, TagName As String, TagValue As String, TemplName As String, FileName As String
Dim CurDt As Date, LastAppDt As Date
Dim OutApp As Object, OutMail As Object
Dim WordContent As Word.Range
Dim WordDoc As Word.Document
Dim WordApp As Word.Application
'*~
Dim sLastSentTemplate As String
With Tabelle1
If IsEmpty(Range("G3").Value) = True Then
MsgBox "Bitte wählen sie eine Vorlage aus"
.Range("G3").Select
Exit Sub
End If
TemplRow = .Range("B3").Value
TemplName = .Range("G3").Value
FrDays = .Range("L3").Value
ToDays = .Range("N3").Value
DocLoc = Tabelle2.Range("F" & TemplRow).Value
'*~ workout the last sent template name
'* this is what you'll be searching for in column Z
sLastTemplateTarget = GetLastSentTemplate(TemplName)
On Error Resume Next
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
Err.Clear
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
End If
'***LastRow = .Range("E9999").End(xlUp).Row
'*~
LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
For CustRow = 8 To LastRow
DaysSince = .Range("P" & CustRow).Value
'*~ changed TemplName to sLastSentTemplate
If sLastSentTemplate = .Range("Z" & CustRow).Value And DaysSince >= FrDays And DaysSince <= ToDays Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False)
For CustCol = 5 To 26
TagName = .Cells(7, CustCol).Value
TagValue = .Cells(CustRow, CustCol).Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With '***
Next CustCol
If .Range("I3").Value = "PDF" Then
FileName = "Filename" & "\" & .Range("H" & CustRow).Value & " " & .Range("G" & CustRow).Value & " " & .Range("G3").Value & ".pdf"
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else:
FileName = ThisWorkbook.Path & "\" & .Range("H" & CustRow).Value & "_" & .Range("G" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
.Range("Z" & CustRow).Value = TemplName
.Range("AA" & CustRow).Value = Now
If .Range("P3").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = Tabelle1.Range("K" & CustRow).Value
.Subject = "Hallo, " & Tabelle1.Range("F" & CustRow).Value & "Test Test Test"
.Body = "Hallo, " & Tabelle1.Range("F" & CustRow).Value & "Test Test Test Test"
.Attachments.Add FileName
.Display
End With
Else:
WordDoc.PrintOut
WordDoc.Close
End If
Kill False '(FileName)
End If
Next CustRow
WordApp.Quit
'*~ cleanup after finishing
Set WordApp = Nothing
Set OutApp = Nothing
End With
End Sub
'*~
Function GetLastSentTemplate(sTemplate As String) As String
Dim lPrefixNumber As Long
If Len(sTemplate) > 0 Then
lPrefixNumber = Val(Left(sTemplate, InStr(sTemplate, ".") - 1))
If lPrefixNumber > 1 Then
GetLastSentTemplate = Replace(sTemplate, lPrefixNumber, lPrefixNumber - 1)
End If
End If
End Function
Hi I am using below code to add chart and send email to multiple recipients. It works fine. In my sent item i can see a perfect email created and sent. But all the recipients are not able to see the charts. All they see is two red X
Sub Send_Email_Updated()
Dim olApp As Object
Dim NewMail As Object
Dim NewMail1 As Object
Dim ChartName As String
Dim ChartName1 As String
Dim SendingRng As Range
Dim htmlString As String
Dim OMail As Outlook.MailItem
Set wb = ActiveWorkbook
Set S1 = wb.Worksheets("Incident Tickets")
Set S2 = wb.Worksheets("Assets and Representatives")
Set S3 = wb.Worksheets("Email")
'Set SendingRng = Worksheets("Email").Table("A30:C43")
Set SendingRng = Worksheets("Email").Range("A30:C43")
Set olApp = CreateObject("Outlook.Application")
Set OMail = olApp.CreateItem(olMailItem)
' Group 1
If S3.Cells(7, 2) <> 0 Or S3.Cells(8, 2) <> 0 Or S3.Cells(9, 2) <> 0 Then
OMail.Display
'fill in the file path/name of the gif file app graph
ChartName = Environ$("Temp") & "\Chart 1.gif"
ActiveWorkbook.Worksheets("Email").ChartObjects("Chart 1").Chart.Export _
Filename:=ChartName, FilterName:="GIF"
'fill in the file path/name of the gif file trend graph
ChartName1 = Environ$("Temp") & "\Chart 31.gif"
ActiveWorkbook.Worksheets("Email").ChartObjects("Chart 31").Chart.Export _
Filename:=ChartName1, FilterName:="GIF"
Set NewMail = olApp.CreateItem(0)
With NewMail
.Subject = "Action Required on Incidents and Problem Candidates for GC060.1 - Group 1"
.To = "animesh.das#xyz.com"
.HTMLBody =
"<img src=" & "'" & ChartName1 & "'>" & "<br/>" & "<br/>" & "_
"<img src=" & "'" & ChartName & "'>" & "<br/>" & "<br/>" & _
.Send
End With
ChartName = vbNullString
ChartName1 = vbNullString
End If
End Sub