I have email addresses in column A, and a chart object in the same sheet.
For each email address, I want to create a new mail in Outlook and paste the Excel chart into the email body.
The problem with my attempt (below) is that the chart does not get pasted into the mail body. How do I fix this?
This my code:
Sub smail()
Dim r As Integer
Dim o As Outlook.Application
Dim m As Outlook.MailItem
Set o = New Outlook.Application
r = 1
Do While Cells(r, 1) <> ""
Set m = o.CreateItem(olMailItem)
m.To = Cells(r, 1)
m.CC = "xyz#anc.com"
m.BCC = "abc#xyz.com"
m.Subject = "Test"
ActiveChart.ChartArea.Copy
Set wEditor = o.ActiveInspector.WordEditor
'm.Body = Paste
wEditor.Application.Selection.Paste
m.Send
r = r + 1
Set m = Nothing
Loop
End Sub
I think the problem with this line
wEditor.Application.Selection.Paste
is that nothing is selected, i.e. .Selection returns Nothing, as long as the message is not visible. To solve this, make it visible before pasting:
m.Display
That worked for me.
Also, you should always declare all your variables using Dim, including wEditor:
Dim wEditor As Word.Document
Related
i have a excel list and and i want to make a button to send an email in the list using template, the target email address is in column K, but i only want to send it if column A is showing YES.
I wrote a script to loop every row i want and see if column A has "YES" or not, if yes then refer to another macro.
but i got stuck in anther macro, i cant specify .to = column K
Here is the loop script to find if column A has YES:
sub agreement2 ()
dim startrow as integer
startrow = 9
dim mylastrow3 as integer
lastrow3 = activesheet.cells(rows.count, 1).end(xlup).row
dim i as integer
for i = 9 to lastrow3
if (cells(i, 1).value = "YES") then
send_letter
end if
end sub
Here is my send_letter script
Sub send_letter()
Dim Subject
Dim Body
Dim otlapp As Object
Dim olMail2 As Object
Dim ws As Object
Set otlapp = CreateObject("Outlook.Application")
Set olMail2 = otlapp.CreateItemFromTemplate("\\cpadm001.corp.ocalwa.com\clk\DEPT\CLKDEPT6\IMT\SAO\SSC\Team\Team1\New Joiner Script\agreement.oft")
Set doc2 = olMail2.GetInspector.WordEditor
Set ws = ThisWorkbook.Worksheets("Send Letters")
vTemplateBody2 = olMail2.HTMLBody
Subject2 = "Agreement Letter"
HTMLBody2 = vTemplateBody2
With olMail2
.To = ????????????????.Value
.Subject = Subject2
Set WrdRng = doc2.Range
WrdRng.Paste
.Send
End With
End Sub
Could anyone help with the column K thing. thank you so much.
Change send_letter to send_letter(r)
Alter call from send_letter to send_letter i
Your final code will be: .To = Cells(r, "K").Value
I want to create an Excel file where people can enter their E-Mail address and as soon as 5 People added their E-Mail an Message is sent to all those E-Mails.
To execute the VBA-Makro when saving i do the following:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'My Code is here
End Sub
I try to loop over one column but didn't found a good solution for this - currently I have set a Rage from B2 to B99
I need to get the E-Mail from the cell, ignore empty/null cells and I need to somehow check the E-Mail if its valid (RegEx?)
Dim eMailList As String
Dim eMailCount As Integer
eMailCount = 0
eMailList = ""
Dim eMail As String
Dim rng As Range: Set rng = ThisWorkbook.Worksheets("Tabelle1").Range("B2:B99")
Dim i As Integer
For i = 1 To rng.Rows.Count
eMail = rng.Cells(RowIndex:=i, ColumnIndex:="B").Text
eMailList = eMailList & eMail & "; "
Next
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = eMailList
.Subject = "DummyText"
.Body = "DummyText"
.send
End With
My Questions are:
How can I easy iterate over the cells in one specific Column?
How can I get the eMail from the cell - .Text .Value?
How to use Regular Expressions in VBA/Excel to validate Email?
How can I list the EMails and send a message to each E-Mail
Im glad for any help/tip/recommendation
Thanks in Advance
The code below will get you started, explanations inside the codes comments:
Dim Rng As Range, C As Range
Set Rng = ThisWorkbook.Worksheets("Tabelle1").Range("B2:B99")
' loop through all cells in Range (Column "B")
For Each C In Rng
If Trim(C.Value2) <> "" Then ' <-- check that cell isn't empty
' --- Add Here another IF criteria to validate your E-Mail ---
eMail = Rng.Value2 ' <-- read the value2 of the cell (without the cell's format)
eMailList = eMailList & eMail & "; "
End If
Next C
I want to make an editable email template where everyone can update the email and assign to which user they want to sent which email. The email templates are from another sheet. Every template has its own email ID.
I want to match the template with the table that contain all of the information needed. So, whenever user input the email ID, it will mapped the value with thee placeholder in the email template.
So far, here is what I have been working on with the email template. But right now it just grab all of the value from the cell. Which is breakable whenever I add columns or rows.
Sub Mail_with_outlook2()
Dim mainWB As Workbook
Dim otlApp As Object
Dim olMail As Object
Dim olMailItem As Object
Dim Doc As Object
Dim SendID
Dim CCID
Dim Subject
Dim Body
Dim WrdRng As Object
Dim result
Dim i As Long
Set otlApp = CreateObject("Outlook.Application")
Set olMail = otlApp.CreateItem(0)
Set mainWB = ActiveWorkbook
SendID = mainWB.Sheets("Email Template").Range("C3").Value
CCID = mainWB.Sheets("Email Template").Range("D3").Value
Subject = mainWB.Sheets("Email Template").Range("E3").Value
Body = mainWB.Sheets("Email Template").Range("F3").Value
Dim splitBody
splitBody = Split(Body, "<%")
For i = 0 To UBound(splitBody)
result = Replace(Body, ">", "K")
Next i
With olMail
.to = SendID
If CCID <> "" Then
.CC = CCID
End If
.Subject = Subject
.Display
End With
Set Doc = olMail.GetInspector.WordEditor
Set WrdRng = Doc.Range(Start:=0, End:=0)
WrdRng.Select
mainWB.Sheets("Email Template").Range("F3").Copy
WrdRng.Paste
MsgBox ("you Mail has been sent to " & SendID)
End Sub
Table + Match function
Consider turning your template sheet data into Excel Table. Then you can use the "table object" aka. ListObject to refer to it's columns by their name (column headings).
To find the relative position of the ID inside the table, you can use WorksheetFunction.Match.
Code with examples
In my code, the sheet where the parameters for the mail template are is called "IssueTemplates".
The table is called "IssueTemplatesTable".
Sub GetDataFromTable()
Dim IssueTemplatesTable As ListObject
Dim ID_Searched As Integer 'Input variable
Dim ID_RelativeRow As Integer 'Input relative row inside the table
Dim Var1 As String 'Output variable
Set IssueTemplatesTable = ThisWorkbook.Sheets("IssueTemplates").ListObjects("IssueTemplatesTable")
'''''''''''''''''EXAMPLE 1'''''''''''''''''''''''''
ID_Searched = 17 'Input: "No" of template
With IssueTemplatesTable
ID_RelativeRow = WorksheetFunction.Match(ID_Searched, .ListColumns("No").DataBodyRange, 0)
Var1 = .DataBodyRange(ID_RelativeRow, .ListColumns("Issue Type").Index)
End With 'IssueTemplatesTable
MsgBox Var1 'Output: "Others"
'''''''''''''''''EXAMPLE 2'''''''''''''''''''''''''
ID_Searched = 25 'Input: "No" of template
With IssueTemplatesTable
ID_RelativeRow = WorksheetFunction.Match(ID_Searched, .ListColumns("No").DataBodyRange, 0)
Var1 = .DataBodyRange(ID_RelativeRow, .ListColumns("Issue Type").Index)
End With 'IssueTemplatesTable
MsgBox Var1 'Output: "Mapping"
End Sub
I'm trying to make a code in which to copy charts from a xls file into a word document using the PasteSpecial property (picture(enhanced metafile). I would like to change the existing charts of the document to new ones. So, I thought that using bookmarks for the existing charts would be OK. I'm using OFFICE 2007.
I've written the following code:
Dim YMApp As Word.Application
Dim YMDoc As Word.Document
Dim B as Bookmark
paaath = "D:\"
dime = "NameOld.doc"
dime2 = "NameNew.doc"
Set YMApp = New Word.Application
YMApp.Visible = True
Set YMDoc = YMApp.Documents.Open(paaath & dime)
Word.Documents(dime).SaveAs (paaath + dime2)
For k = 1 To 6
Windows("New.xls").Activate
Sheets("graph").Select
Range("L" + Trim(Str(br(k))) + ":V" + Trim(Str(br(k) + 24))).Select
Selection.Copy
ddd = "bm" + Trim(Str(k))
Set B = YMDoc.Bookmarks(ddd)
YMApp.Selection.PasteSpecial DataType:=wdPasteMetafilePicture, Placement:=B
Next k
YMDoc.Close
YMApp.Quit
Application.CutCopyMode = False
ActiveWorkbook.Close
End
End Sub
The problem is that by this code the bookmarks which are already created are not recognized. How to cope with the problem?
The Placement argument of PasteSpecial does not accept a Bookmark object:
Set B = YMDoc.Bookmarks(ddd)
YMApp.Selection.PasteSpecial DataType:=wdPasteMetafilePicture, Placement:=B
Instead, it takes a WdOLEPlacement constant.
I think you'll need to select the bookmark before you do the PasteSpecial. You may need to delete existing chart (if any), also.
Untested, but I think you need something like this:
Dim wdRange as Word.Range
Set B = YMDoc.Bookmarks(ddd)
Set wdRange = B.Range
YMApp.Selection.GoTo What:=wdGoToBookMark, Name:=B.Name
' Delete existing shapes & bookmark if any:
On Error Resume Next
YMDoc.ShapeRange(1).Delete
wdRange.Delete
On Error GoTo 0
YMApp.Selection.PasteSpecial DataType:=wdPasteMetafilePicture, Placement:=0 'Or 1
'Add the bookmark back in place:
MDoc.Selection.Bookmarks.Add Name:=ddd, wdRange
All right, this is my second attempt at a code, and the second VBA macro project I've been assigned to work on. I've been working to learn VBA as my first coding language for the last week and a half, so I apologize for silly mistakes. That said, straight to business. Here's what I put together for a word document macro:
Sub MacroToUpdateWordDocs()
'the following code gets and sets a open file command bar for word documents
Dim Filter, Caption, SelectedFile As String
Dim Finalrow As String
Dim FinalrowName As String
Filter = "xlsx Files (*.xlsx),*.xlsx"
Caption = "Please Select A .xlsx File, " & TheUser
SelectedFile = Application.GetOpenFilename(Filter, , Caption)
'check if value is blank if it is exit
Finalrow = Cells(Rows.Count, 1).End(xlUp).Row
FinalrowName = Finalrow + 1
If (Trim(SelectedFile) = "") Then
Exit Sub
Else
'setting up the inital word application object
Set auditmaster = CreateObject("excel.sheet")
'opening the document that is defined in the open file dialog
auditmaster.Application.Workbooks.Open (SelectedFile)
'ability to change wether it needs to burn cycles updating the UI
auditmaster.Visible = False
'declare excel sheet
Dim wdoc As Document
'set active sheet
Set wdoc = Application.ActiveDocument
Dim i As Integer
Dim u As Integer
Dim ColumnAOldAddy As String
Dim ColumnCNewAddy As String
u = 1
i = 1
'MsgBox (wordapp.ActiveDocument.Hyperlinks.Count)
'Sets up a loop to go through the Excel Audit file rows.
For i = 1 To auditmaster.ActiveSheet.Rows.Count
'Identifies ColumnAOldAddy and ColumnCNewAddy as columns A and C for each row i. Column A is the current hyperlink.address, C is the updated one.
ColumnAOldAddy = auditmaster.Cells(i, 1)
ColumnCNewAddy = auditmaster.Cells(i, 3)
'If C has a new hyperlink in it, then scan the hyperlinks in wdoc for a match to A, and replace it with C
If ColumnCNewAddy = Not Nothing Then
For u = 1 To doc.Hyperlinks.Count
'If the hyperlink matches.
If doc.Hyperlinks(u).Address = ColumnAOldAddy Then
'Change the links address.
doc.Hyperlinks(u).Address = ColumnCNewAddy
End If
'check the next hyperlink in wdoc
Next
End If
'makes sure the macro doesn't run on into infinity.
If i = Finalrow + 1 Then GoTo Donenow
'Cycles to the next row in the auditmaster workbook.
Next
Donenow:
'Now that we've gone through the auditmaster file, we close it.
auditmaster.ActiveSheet.Close SaveChanges:=wdDoNotSaveChanges
auditmaster.Quit SaveChanges:=wdDoNotSaveChanges
Set auditmaster = Nothing
End If
End Sub
So, this code is suppose to take a hyperlink audit file created by my first macro (The last bugs fixed and functioning wonderfully thanks to the Stack Overflow community!). The audit file has 3 columns and a row for each hyperlink it found in the target .docx: A = hyperlink address, B = Hyperlink displaytext, and C = the new Hyperlink address
When the code runs from the .docx file to be updated, it allows the user to choose the audit file. From there, it goes row by row to check if an updated hyperlink address has been written into the C column by the older audited address/display name, then searches the .docx file for the old hyperlink address and replaces it with the new hyperlink address. At that point, it finishes searching the document then moves on to the next row in the audit excel file.
My problem is that much of this code is copy/pasted out of code from an excel macro. I have been having a hell of a time figuring out how translate that code into something that identifies/references the word/excel documents appropriately. I'm hoping someone with more experience can take a peek at this macro and let me know where I've completely buggered up. It keeps giving me "Method or data member not found" errors all over the place currently, primarily concerning where I attempt to reference the audit excel file. I'm pretty sure that this is a relatively easy fix, but I don't have the vocabulary to figure out how to Google the answer!
Compiled OK, but not tested:
Sub MacroToUpdateWordDocs()
Dim Filter, Caption, SelectedFile As String
Dim Finalrow As String
Dim appXL As Object
Dim oWB As Object
Dim oSht As Object
Dim wdoc As Document
Dim ColumnAOldAddy As String
Dim ColumnCNewAddy As String
Dim i As Long
Dim h As Word.Hyperlink
Dim TheUser As String
Filter = "xlsx Files (*.xlsx),*.xlsx"
Caption = "Please Select A .xlsx File, " & TheUser
Set appXL = CreateObject("excel.application")
appXL.Visible = True
SelectedFile = appXL.GetOpenFilename(Filter, , Caption)
appXL.Visible = False
If Trim(SelectedFile) = "" Then
appXL.Quit
Exit Sub
Else
Set oWB = appXL.Workbooks.Open(SelectedFile)
Set oSht = oWB.worksheets(1)
Finalrow = oSht.Cells(oSht.Rows.Count, 1).End(-4162).Row '-4162=xlUp
End If
Set wdoc = Application.ActiveDocument
For i = 1 To Finalrow
ColumnAOldAddy = oSht.Cells(i, 1).Value
ColumnCNewAddy = oSht.Cells(i, 3).Value
If ColumnCNewAddy <> ColumnAOldAddy Then
For Each h In wdoc.Hyperlinks
If h.Address = ColumnAOldAddy Then
h.Address = ColumnCNewAddy
End If
Next h
End If
Next i
oWB.Close False
appXL.Quit
End Sub