I'm using Ron de Bruins code for emailing many different files to different people, as shown below. But the issue I have is, if an email address exists in column B and the corresponding workbook doesn't exist it still creates an email but with no attachment, as there isn't one. Would anyone know how to modify the code so that if a workbook didn't exist it doesn't create the email?
Sub Send_Files()
'Working in Excel 2000-2013
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
You can set a flag to go to the next item if the file does not exist:
Dim noFile as Boolean
noFile = True
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
noFile = False
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
if Not noFile then .Send
There are other ways to do this (see for example Sidharth Rout's suggestion which checks for the existence of files before even starting to create the email); I chose the above because it minimizes the amount of change needed in your existing code (just three lines, easy to see what they do).
Some people would prefer to invert the logic, with a hasFile boolean:
Dim hasFile as Boolean
hasFile = False
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
hasFile = True
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
if hasFile then .Send
Related
I use the following code assigned to a CommandButton to automatically attach the workbook to an email so users can send it out. Is there a way to attach the workbook without the code, so the people receiving the email do not have the full code, but the sender keeps it in their copy? (The recipients only need to see the data, they do not interact with the form, but the sender interacts with it several times a day.) When I save the Workbook as .xlsx, it gives me an yes/no/help MsgBox that I would like to avoid during the sending - to keep it as a "one-click" operation.
Source_File = ThisWorkbook.FullName
myMail.Attachments.Add Source_File
Option Explicit
Sub CDO_Mail_Workbook()
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant
Dim MyDate
MyDate = Format(Now(), "dd-mmm-yy")
Set wb = ActiveWorkbook
If Val(Application.Version) >= 12 Then
If wb.FileFormat = 51 And wb.HasVBProject = True Then
MsgBox "There is VBA code in this xlsx file, there will be no VBA code in the file you send." & vbNewLine & _
"Save the file first as xlsm and then try the macro again.", vbInformation
Exit Sub
End If
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Make a copy of the file/Mail it/Delete it
'If you want to change the file name then change only TempFileName
TempFilePath = Environ$("temp") & "\"
'TempFileName = wb.Name & " " & Format(Now, "yyyy-mmm-dd")
TempFileName = "Test" & "-" & Format(Now, "yyyy-mmm-dd")
'FileExtStr = "." & LCase(Right(wb.Name, Len(wb.Name) - InStrRev(wb.Name, ".", , 1)))
FileExtStr = ".xlsm"
Application.DisplayAlerts = False
' wb.SaveAs Filename:=TempFilePath & TempFileName & FileExtStr, FileFormat:=51, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
ActiveWorkbook.SaveCopyAs Filename:=TempFilePath & TempFileName & "Copy" & FileExtStr
Workbooks.Open (TempFilePath & TempFileName & "Copy" & FileExtStr)
ActiveWorkbook.SaveAs Filename:=TempFilePath & TempFileName & "-email" & ".xlsx", FileFormat:=51, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
ActiveWorkbook.Close False
'wb.SaveCopyAs TempFilePath & TempFileName & FileExtStr
Application.DisplayAlerts = True
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "noone#noone.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
With iMsg
Set .Configuration = iConf
'.To = "noone#noone.com"
'.CC = ""
.BCC = ""
.From = "noone#noone.com"
.Subject = "Test - " & MyDate
.TextBody = ""
.AddAttachment TempFilePath & TempFileName & "-email" & ".xlsx"
.Send
End With
'If you not want to delete the file you send delete this line
Kill TempFilePath & TempFileName & "-email" & ".xlsx"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Application.DisplayAlerts = False
Set wb = Nothing
For Each wb In Application.Workbooks
wb.Save
Next wb
Application.Quit
End Sub
To send a single worksheet with the vba code removed, I've used this:
Option Explicit
'This procedure will send the ActiveSheet in a new workbook
'For more sheets use : Sourcewb.Sheets(Array("Sheet1", "Sheet3")).Copy
Sub CDO_Mail_ActiveSheet_Or_Sheets()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim iMsg As Object
Dim iConf As Object
Dim sh As Worksheet
Dim Flds As Variant
Dim MyDate
MyDate = Format(Now(), "dd-mmm-yy")
Dim wb As Workbook
Set wb = ActiveWorkbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
'Or if you want to copy more then one sheet use:
'Sourcewb.Sheets(Array("Sheet1", "Sheet3")).Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
'We exit the sub when your answer is NO in the security dialog that you only
'see when you copy a sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
'Change all cells in Destwb to values if you want
For Each sh In Destwb.Worksheets
sh.Select
With sh.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
Next sh
Destwb.Worksheets(1).Select
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Test" & "-" & Format(Now, "yyyy-mmm-dd")
Application.DisplayAlerts = False
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
.Close savechanges:=False
End With
Application.DisplayAlerts = True
Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "noone#noone.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "password"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update
End With
With iMsg
Set .Configuration = iConf
.To = "noone#noone.com"
'.CC = ""
'.BCC = ""
.From = "noone#noone.com"
.Subject = "Test-" & MyDate
.TextBody = ""
.AddAttachment TempFilePath & TempFileName & FileExtStr
.Send
End With
'If you not want to delete the file you send delete this line
Kill TempFilePath & TempFileName & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Application.DisplayAlerts = False
Set wb = Nothing
For Each wb In Application.Workbooks
wb.Save
Next wb
Application.Quit
End Sub
objJSO.GetField(strField).Value = (strFieldVal) - That is the line I'm recieving a 'type mismatch' error on.
I've found the code base from "My Engineering World". It is an old post.
I'm selecting a static PDF form and trying to write values from an excel doc to the PDF form which contains the same field names. The excel doc has the field names in column c20-149 with the values for those fields in d20-149. I'm trying to write the values for those fields into the selected PDF form.
Option Explicit
Sub btnToPDF_Click()
Dim objAcroApp As Object
Dim objAcroAVDoc As Object
Dim objAcroPDDoc As Object
Dim objJSO As Object
Dim fd As Office.FileDialog
Dim strFile As String
Dim strField As String
Dim strFieldVal As String 'Used to hold the field value
Dim r As Long 'Used to increase row number for strfield name
'Disable screen flickering.
Application.ScreenUpdating = False
'Choose the Onsite Survey form you want to fill
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Please select the On-site survey PDF."
.Filters.Clear
.Filters.Add "PDF", "*.PDF"
'.Filters.Add "All Files", "*.*"
'If the .Show method returns False, the user clicked Cancel.
If .Show = True Then
strFile = .SelectedItems(1)
MsgBox (strFile)
End If
End With
'Initialize Acrobat by creating the App object.
Set objAcroApp = CreateObject("AcroExch.App")
'Check if the object was created.
If Err.Number <> 0 Then
MsgBox "Could not create the App object!", vbCritical, "Object error"
'Release the object and exit.
Set objAcroApp = Nothing
Exit Sub
End If
'Create the AVDoc object.
Set objAcroAVDoc = CreateObject("AcroExch.AVDoc")
'Check if the object was created.
If Err.Number <> 0 Then
MsgBox "Could not create the AVDoc object!", vbCritical, "Object error"
'Release the objects and exit.
Set objAcroAVDoc = Nothing
Set objAcroApp = Nothing
Exit Sub
End If
On Error GoTo 0
'Open the PDF file.
If objAcroAVDoc.Open(strFile, "") = True Then
'Set the PDDoc object.
Set objAcroPDDoc = objAcroAVDoc.GetPDDoc
'Set the JS Object - Java Script Object.
Set objJSO = objAcroPDDoc.GetJSObject
On Error GoTo 0
'Fill the form fields.
For r = 20 To 149
strField = Cells(r, 3)
strFieldVal = Cells(r, 4)
objJSO.GetField(strField).Value = CStr(strFieldVal)
If Err.Number <> 0 Then
'Close the form without saving the changes.
objAcroAVDoc.Close True
'Close the Acrobat application.
objAcroApp.Exit
'Inform the user about the error.
MsgBox "The field """ & strField & """ could not be found!", vbCritical, "Field error"
'Release the objects and exit.
Set objJSO = Nothing
Set objAcroPDDoc = Nothing
Set objAcroAVDoc = Nothing
Set objAcroApp = Nothing
Exit Sub
End If
Next r
'Save the form
objAcroPDDoc.Save 1, strFile
'Close the form without saving the changes.
'objAcroAVDoc.Close True
'Close the Acrobat application.
objAcroApp.Exit
'Release the objects.
Set objJSO = Nothing
Set objAcroPDDoc = Nothing
Set objAcroAVDoc = Nothing
Set objAcroApp = Nothing
'Enable the screen.
Application.ScreenUpdating = True
'Inform the user that forms were filled.
MsgBox "All forms were created successfully!", vbInformation, "Finished"
End If
MsgBox "Something bad happend :(...."
End Sub
OK... found my problem but I'm not sure how to trap the problem. I may not need to as I'm hoping I won't run into this problem. Hoping isn't the best strategy though... :)
My PDF form has fields of type numeric. All my test data in my value cells were alpha-numeric. Once I changed my quantity and cost cells to numeric values in my excel doc the form was written correctly.
Perhaps I can test for the PDF form field type. If it is numeric I'll log the field name and present a msgbox at the end of the operation that displays fields that could not be filled.
I did need to correct my objJSO line to '=strFieldVal'
I'm fairly certain you want...
strField = Cells(r, 3).Value
strFieldVal = Cells(r, 4).Value
objJSO.GetField(strField).Value = strFieldVal
...instead of the three corresponding lines you have.
Below is my final code. It includes basic error handling (more like logging). One problem I did have in this; If I was writing an alpha numeric string to the PDF field and the PDF field was numeric AND there wasn't a default value in the PDF field the PDF would throw and error that my code couldn't catch. As long as there was a default value in the PDF numeric field the error handler worked as planned. Feel free to make any comments. I'm guessing this looks like kindergarten work (maybe 1st grade??)
`Option Explicit
Sub btnToPDF_Click()
Dim objAcroApp As Object
Dim objAcroAVDoc As Object
Dim objAcroPDDoc As Object
Dim objJSO As Object
Dim fd As Office.FileDialog
Dim myWB As Workbook
Set myWB = ThisWorkbook
Dim ToPDFsh As Worksheet
Set ToPDFsh = myWB.Sheets("OSSDataDump")
Dim strFile As String
Dim strField As String
Dim strFieldVal As String 'Used to hold the field value
Dim msgFail As String
Dim colVal As Variant
Dim r As Integer 'Used to increase row number for strfield name
Dim e As Integer 'Used to track the number of errors
Dim colFail As Collection
Set colFail = New Collection
e = 0
'Disable screen flickering.
Application.ScreenUpdating = False
'Choose the Onsite Survey form you want to fill
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Please select the On-site survey PDF."
.Filters.Clear
.Filters.Add "PDF", "*.PDF"
'If the .Show method returns False, the user clicked Cancel.
If .Show = True Then
strFile = .SelectedItems(1)
End If
End With
'Initialize Acrobat by creating the App object.
Set objAcroApp = CreateObject("AcroExch.App")
'Check if the object was created.
If Err.Number <> 0 Then
MsgBox "Could not create the App object!", vbCritical, "Object error"
'Release the object and exit.
Set objAcroApp = Nothing
Exit Sub
End If
'Create the AVDoc object.
Set objAcroAVDoc = CreateObject("AcroExch.AVDoc")
'Check if the object was created.
If Err.Number <> 0 Then
MsgBox "Could not create the AVDoc object!", vbCritical, "Object error"
'Release the objects and exit.
Set objAcroAVDoc = Nothing
Set objAcroApp = Nothing
Exit Sub
End If
'Open the PDF file.
If objAcroAVDoc.Open(strFile, "") = True Then
'Set the PDDoc object.
Set objAcroPDDoc = objAcroAVDoc.GetPDDoc
'Set the JS Object - Java Script Object.
Set objJSO = objAcroPDDoc.GetJSObject
'Fill the form fields.
For r = 20 To 149
strField = ToPDFsh.Cells(r, 3).Value
strFieldVal = ToPDFsh.Cells(r, 4).Value
If strFieldVal = "" Then GoTo BlankVal
objJSO.GetField(strField).Value = strFieldVal
On Error GoTo ErrHandler
BlankVal:
Next r
'Save the form
objAcroPDDoc.Save 1, strFile
'Close the form without saving the changes.
'objAcroAVDoc.Close True
'Close the Acrobat application.
objAcroApp.Exit
'Release the objects.
Set objJSO = Nothing
Set objAcroPDDoc = Nothing
Set objAcroAVDoc = Nothing
Set objAcroApp = Nothing
'Enable the screen.
Application.ScreenUpdating = True
'Inform the user that forms were filled.
If e <> 0 Then
For Each colVal In colFail
msgFail = msgFail & colVal & vbNewLine
Next colVal
MsgBox "Not all fields were filled" & vbNewLine & "The follwoing fields failed:" & vbNewLine & msgFail, vbExclamation, "Finished"
Exit Sub
End If
MsgBox "On site survey was filled successfully!", vbInformation, "Finished"
End If
Exit Sub
ErrHandler:
e = e + 1
If e > 7 Then
MsgBox "Something Bad happend... :(" & vbNewLine & "Form not filled", vbCritical, "Failed"
GoTo ErrHandlerExit
End If
colFail.Add strField
Resume Next
Exit Sub
ErrHandlerExit:
'Close the form without saving the changes.
objAcroAVDoc.Close True
'Close the Acrobat application.
objAcroApp.Exit
'Release the objects and exit.
Set objJSO = Nothing
Set objAcroPDDoc = Nothing
Set objAcroAVDoc = Nothing
Set objAcroApp = Nothing
'Enable the screen.
Application.ScreenUpdating = True
Exit Sub
End Sub`
I got a question, a couple in fact. (sorry for not formatting correctly, i tried but it just doesnt "work")
I've designed a template for my job application processes, got the content controls working fine pushing data from my form to the document.
Now i wonder, how to retrieve such data back into the form when i open the document again?
Working short word code:
Option Explicit
'Coded by Etrola Limited-Now terminated /Erik L Thoresen
'Pending change
'Revision 1 CC and form
Private Sub cmdFillForm_Click()
'Fill letter elements (content controls) from userform, works fine to fill text in controls
Dim cc As ContentControl
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccCompany" Then
cc.Range.Text = Me.txtCompany
Exit For
End If
Next cc
End Sub
How should I then best place code to place this?
Debug.Print cc.Range.text to keep my form "live to data in doc?"
And now for my second question: In my Excel database, a log of different activities performed, i got the urge of creating my application from a range of declared cells as filename, and the data from those shall also be entered into content controls when calling the form to create a new application with a filename given by these ranged cells. Lets say:
I have an active line in a table in that sheet, the last row with 5 or more cells in a row.
I can also have entered any number of interesting jobs for a date, and by a click of a floating or other form of way to create these applications type of menu, all are created with the desired data.
How do i call that template?
How do i define either ranged cells (by date would be nice, but also ActiveRow)?
Excel code:
Option Explicit
Sub TransferDataToWord()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim strDocName As String
Dim MyRange As Range
Dim fNamePt1 As String
Dim fNamePt2 As String
Dim fNamePt3 As String
Dim fNamePt4 As String
Dim fNamePt5 As String
fNamePt1 = Range.Count '?
fNamePt2 = Range.Count '?
fNamePt3 = Range.Count '?
fNamePt4 = Range.Count '?
fNamePt5 = Range.Count '?
On Error Resume Next
Set wdApp = GetObject(, "word.application")
Set wdDoc = wdApp.Documents.Add
wdDoc.Content.InsertAfter Range
If Err.Number = 429 Then
Err.Clear
Set wdApp = CreateObject("word.application")
End If
wdApp.Visible = True
strDocName = "C:\Myfolder\" 'Søknad' "&fNamePt1 &fNamePt2 &fNamePt3 &fNamePt4)
If Dir(strDocName) = "" Then
MsgBox "The file " & strDocName & vbCrLf & "wasn't found " & vbCrLf & "C:\MyFolder\.", vbExclamation, " The document doesn't exist "
End Sub
End If
wdApp.Activate
Set wdDoc = wdApp.Documents(strDocName)
If wdDoc Is Nothing Then
Set wdDoc = Documents(strDocName)
wdDoc.Activate
wdDoc.MyRange.Paste
wdDoc.Save
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
Application.CutCopyMode = False
Thank you for your reply.
Now, for calling this word template from a embedded button in my excel sheet =EMBED("Forms.CommandButton.1";"") named cmdCreateApplication, should i better use like this:
`oWord.Documents.Add "<Path to my template>\MyTemplate.dot"`
or your example?
My code now looks like this:(Yet to make it work) I know i have gotten something wrong. Since i've forgotten too much.
Private Sub cmdCreateApplication_Click(ByVal oRng As Range)
'
'Opens desired template to fill in data form range of cells
'Dim wApp As Word.Application
Set wApp = CreateObject(, "Word.Application")
wApp.DisplayAlerts = False
'Opens template to create document
Documents.Add Template:="C:\myfolder\Norwegian Application Template 2.dotm"
'Below Tells to keep values in memory
Dim MyDate As String
Dim MyJobTitle As String
Dim MyDocType As String
Dim MyJobRefNo As String
Dim TheirRefNo As String
Dim JobWebSite As String
Dim Company As String
Dim AttName As String
Dim AttTitle As String
Dim AttEmail As String
Dim RecFirm As String
Dim Address As String
'Below Describes what to extract from Excel and keep in memory to fill into word document objects
MyDate = oRng.Offset(0, 1).Text 'Date of application /first contact
MyDocType = oRng.Offset(0, 5).Text 'File name part 1 Identifier of doc type, if application, e-mail or CV
MyJobTitle = oRng.Offset(0, 6).Text 'File name part 2 Job title
RecFirm = oRng.Offset(0, 15).Text 'File name part 3 Recruitment agancy, if exist
Company = oRng.Offset(0, 16).Text 'File name part 4 Hiring Company, if exist
MyJobRefNo = oRng.Offset(0, 8).Text 'File name part 5 Reference number (if website)
AttName = oRng.Offset(0, 11).Text 'Contact name
AttEmail = oRng.Offset(0, 13).Text 'Contact e-mail
AttTitle = oRng.Offset(0, 12).Text 'Contact title
JobWebSite = oRng.Offset(0, 10).Text 'Link to job board
TheirRefNo = oRng.Offset(0, 9).Text 'Their reference nr if any
Address = oRng.Offset(0, 17).Text 'Company Adress
On Error Resume Next
'
Set wdApp = GetObject(, "Word.Application")
If Err.Number = 429 Then
Err.Clear
Set wdApp = CreateObject("Word.Application")
End If
strDocName = "C:\myfolder\ MyDocType &wdKeySpacebar &MyJobTitle &wdKeySpacebar &RecFirm &wdKeySpacebar &Company &wdKeySpacebar &MyJobRefNo"
'Below describes where stored data shall be placed before assigning file name and save
Dim cc As ContentControl
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccCompany" Then
Company = Me.txtCompany 'Fills data into form
Company = cc.Range.Text 'Fills data into content controls
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccDate" Then
MyDate = Me.txtApplicationDate
MyDate = cc.Range.Text
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccJobTitle" Then
MyJobTitle = Me.txtJobTitle
MyJobTitle = cc.Range.Text
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccRecFirm" Then
RecFirm = Me.txtRecFirm
RecFirm = cc.Range.Text
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccJobWebSite" Then
JobWebSite = cc.Range.Text
JobWebSite = Me.txtJobPostWeb
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccAttEmail" Then
AttEmail = cc.Range.Text
AttEmail = Me.txtAttEmail
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccAttTitle" Then
AttTitle = cc.Range.Text
AttTitle = Me.txtAttTitle
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccAttName" Then
AttName = cc.Range.Text
AttName = Me.txtAttName
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccTheirRefNo" Then
TheirRefNo = cc.Range.Text
TheirRefNo = Me.txtTheirRefNo
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccMyRefNo" Then
MyJobRefNo = cc.Range.Text
MyJobRefNo = Me.txtMyJobRefNo
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccAddress" Then
Address = cc.Range.Text
Address = Me.txtCompanyStreetAddress
Exit For
End If
Next cc
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccRequirements" Then
Requirements = cc.Range.Text
Requirements = Me.txtRequirements
Exit For
End If
Next cc
End Sub
To keep the form synchronized with the document, I would place some code in the forms Open() event, doing exactly the opposite assignment:
Private sub Form_open()
Dim cc As ContentControl
For Each cc In ActiveDocument.ContentControls
If cc.Title = "ccCompany" Then
Me.txtCompany = cc.Range.Text
Exit For
End If
Next cc
End Sub
I'm afraid I don't fully understand your second question, but I think in this case I would pass the Range object as a parameter to the function that creates the Word document. This way you divide the responsibilities between different procedures.
Sub TransferDataToWord(byval oRng as Range)
...
fNamePt1 = oRng.Offset(0,1).Text
fNamePt2 = oRng.Offset(0,2).Text
...
On error resume next
Set wdApp = GetObject(,"Word.Application")
If Err.Number = 429 Then
Err.Clear
Set wdApp = CreateObject("Word.Application")
End If
...
Hope you find what you're looking for.
Regards.
Wondering if someone might be able to help me solve this issue. Have an Access database where I want to send an email for each "Submit" box that is checked is checked. Have tried several thing and either get 1 record processed before the code stops or will give me several emails for the same record without moving on. Any help with where I am missing the boat would be much appreciated. Below is what I have for the code:
Dim r As DAO.Recordset
Set r = CurrentDb.OpenRecordset("SELECT * FROM [CIs_All_Statuses] WHERE [Submit] = True")
If r.RecordCount = 0 Then
MsgBox ("No records selected")
GoTo Done
Else
End If
r.MoveFirst
i = 1
Begin:
Do Until r.EOF = True
product = r![Product Name]
serial = r![Serial Number]
agency = r![Company]
User = r![Used By]
Submit = r![Submit]
Processed = r![Processed]
If Processed = True Then
r.Edit
r("Submit").Value = False
r.Update
r.MoveNext
GoTo Begin
Else
End If
r.Edit
r("Processed").Value = True
r.Update
r.Edit
r("Submit").Value = False
r.Update
r.MoveNext
Dim oOutlook As Outlook.Application
Dim oEmailItem As MailItem
' prevent 429 error, if outlook not open
On Error Resume Next
Err.Clear
Set oOutlook = GetObject(, "Outlook.application")
If Err.Number <> 0 Then
Set oOutlook = New Outlook.Application
End If
Set oEmailItem = oOutlook.CreateItem(olMailItem)
With oEmailItem
.To = "#email.com"
.CC = Me.Used_By
.Subject = "EmailTicket: [Subject]"
.Body = "Equipment to be verified:" & Space(2) & product & vbCrLf & "Serial Number:" & Space(2) & serial & vbCrLf & "Agency:" & Space(2) & agency & vbCrLf & "User Name:" & Space(2) & User & vbCrLf & vbCrLf & "By inserting the user name in the CC line the Customer Information on the Incident Customer tab will be auto-completed. ONLY append information to the end of the SUBJECT LINE"
.Display
End With
r.MoveNext
Check:
Do While r.EOF = False
NextComputer = r![Serial Number]
If (serial = NextComputer) Then
r.Edit
r("Submit").Value = False
r.Update
r.Edit
r("Processed").Value = True
r.Update
r.MoveNext
GoTo Check
Else
r.MovePrevious
End If
Loop
r.MovePrevious
Loop
r.Close
Set r = Nothing
Done:
End Sub
It is - among other things - the GoTo Check.
Remove that and rebuild your loop.
Also, you only need one .Edit and .Update for each record.
Basically what I am trying to do is, sending an email for every used row on the target worksheet, each row has the details of the addresses, subject line, table with values etc.
So I can't seem to get it working, as it only dispatches one email from the first target row (2nd row).
I have tried using a combination of For Each and For i = 1 to LR which aren't working. I suspect it is to do with the cell references.
Here is the code:
Sub TestEmail1()
Application.ScreenUpdating = False
Dim aOutlook As Object
Dim aEmail As Object
Dim rngeAddresses As Range, rngeCell As Range, strRecipients As String
Dim ccAddresses As Range, ccCell As Range, ccRecipients As String
Dim rngeSubject As Range, SubjectCell As Range, SubjectContent As Variant
Dim rngeBody As Range, bodyCell As Range, bodyContent As Variant
Dim Table1 As Range
Dim i As Integer
For Each c In ActiveSheet.UsedRange.Columns("A").Cells
Set rng = ActiveSheet.UsedRange
LRow = rng.Rows.Count
For i = 2 To LRow
Set Table1 = Worksheets(1).Range("K1:R1")
Set Table2 = Worksheets(2).Range("K" & i & ":" & "R" & i)
Set aOutlook = CreateObject("Outlook.Application")
Set aEmail = aOutlook.CreateItem(0)
'set sheet to find address for e-mails as I have several people to
'mail to
Set rngeAddresses = ActiveSheet.Range("B" & i)
For Each rngeCell In rngeAddresses.Cells
strRecipients = strRecipients & ";" & rngeCell.Value
Next
Set ccAddresses = ActiveSheet.Range("C" & i)
For Each ccCell In ccAddresses.Cells
ccRecipients = ccRecipients & ";" & ccCell.Value
Next
Set rngeSubject = ActiveSheet.Range("D" & i)
For Each SubjectCell In rngeSubject.Cells
SubjectContent = SubjectContent & SubjectCell.Value
Next
Set rngeBody = ActiveSheet.Range("E" & i)
For Each bodyCell In rngeBody.Cells
bodyContent = bodyContent & bodyCell.Value
Next
'set Importance
'aEmail.Importance = 2
'Set Subject
aEmail.Subject = rngeSubject
'Set Body for mail
'aEmail.Body = bodyContent
aEmail.HTMLBody = bodyContent & "<br><br><br>" & RangetoHTML_ (Table1)
aEmail.To = strRecipients
aEmail.CC = ccRecipients
aEmail.Send
Exit Sub
Next i
Next c
End Sub
There is an Exit Sub at the end of your inner loop that makes the code exit from the procedure after the first iteration:
Sub TestEmail1()
...
For Each c In ActiveSheet.UsedRange.Columns("A").Cells
...
For i = 2 To LRow
...
Exit Sub
Next i
Next c
End Sub
Remove it and processing should continue as desired.