Push and pull word content control data to and from Designed VBA form - forms

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.

Related

Excel values to PDF form fields

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`

Export Table in Query to email VBA

I'm trying to export one of my queries to email using VBA in a table format. Similar to when you go to external data and click and E-Mail and it adds an attachment to outlook. Except I want it in the body. I put the following code in a button.
I found and made some changes to some code. This is what I have.
Private Sub Command5_Click()
Dim olApp As Object
Dim olItem As Variant
Dim db As DAO.Database
Dim rec As DAO.Recordset
Dim strQry As String
Dim aHead(1 To 4) As String
Dim aRow(1 To 4) As String
Dim aBody() As String
Dim lCnt As Long
'Create the header row
aHead(1) = "Part"
aHead(2) = "Description"
aHead(3) = "Qty"
aHead(4) = "Price"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th> <th>") & "</th></tr>"
'Create each body row
strQry = "SELECT * From qry_email"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
If Not (rec.BOF And rec.EOF) Then
Do While Not rec.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rec("Part")
aRow(2) = rec("Description")
aRow(3) = rec("Qty")
aRow(4) = rec("Price")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
End If
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
'create the email
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(0)
olItem.Display
olItem.To = "email#email.com"
olItem.Subject = "Test E-mail"
olItem.HTMLBody = Join(aBody, vbNewLine)
olItem.Display
End Sub
When I run the code, I get a "Run-time error '3061' too few parameters. Expected 1."
If i click debug i get this highlighted in yellow. Anybody help would be greatly appreciated!
Edit
I tried a different approach which actually gave me the list in the body of the email. But it does it for the whole table instead of just the one record I want. This is what the SQL looks like of the query.
SELECT tblePMParts.[Part#], tblePMParts.PartDescription, tblePMParts.Qty, tblePMParts.Price
FROM tblePMParts
WHERE (((tblePMParts.WOID)=[Forms]![fmremail]![Text1]));
How would I go about adding the WHERE to the code below.
Private Sub Command4_Click()
'On Error GoTo Errorhandler
Dim olApp As Object
Dim olItem As Variant
Dim olatt As String
Dim olMailTem As Variant
Dim strSendTo As String
Dim strMsg As String
Dim strTo As String
Dim strcc As String
Dim rst As DAO.Recordset
Dim rs As DAO.Recordset
Dim db As DAO.Database
Dim qry As DAO.QueryDef
Dim fld As Field
Dim varItem As Variant
Dim strtable As String
Dim rec As DAO.Recordset
Dim strQry As String
strQry = "SELECT tblePMParts.[Part#], tblePMParts.PartDescription, tblePMParts.Qty, tblePMParts.Price " & _
"FROM tblePMParts; "
strSendTo = "test#email.com"
strTo = ""
strcc = ""
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(olMailTem)
olItem.Display
olItem.To = strTo
olItem.CC = strcc
olItem.Body = ""
olItem.Subject = "Please Quote the Following!"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
If Not (rec.BOF And rec.EOF) Then
rec.MoveLast
rec.MoveFirst
intCount = rec.RecordCount
For intLoop = 1 To intCount
olItem.Body = olItem.Body & rec("[Part#]") & " - " & rec("PartDescription") & " - " & rec("Qty") & " - " & rec("Price")
rec.MoveNext
Next intLoop
End If
MsgBox "Completed Export"
Set olApp = Nothing
Set olItem = Nothing
Exit_Command21_Click:
Exit Sub
ErrorHandler:
MsgBox Err.Description, , Err.Number
Resume Exit_Command21_Click
End Sub
I got it working. Here is the code in case anybody needs it.
Private Sub Command5_Click()
Dim olApp As Object
Dim olItem As Variant
Dim db As DAO.Database
Dim rec As DAO.Recordset
Dim strQry As String
Dim aHead(1 To 3) As String
Dim aRow(1 To 3) As String
Dim aBody() As String
Dim lCnt As Long
'Create the header row
aHead(1) = "Part#"
aHead(2) = "Description"
aHead(3) = "Qty"
lCnt = 1
ReDim aBody(1 To lCnt)
aBody(lCnt) = "<HTML><body><table border='2'><tr><th>" & Join(aHead, "</th><th>") & "</th></tr>"
'Create each body row
strQry = "SELECT tblePMParts.[Part#], tblePMParts.PartDescription, tblePMParts.Qty, tblePMParts.Price " & _
"FROM tblePMParts " & _
"WHERE (((tblePMParts.WOID)=" & [Forms]![fmremail]![Text1] & "));"
Set db = CurrentDb
Set rec = CurrentDb.OpenRecordset(strQry)
If Not (rec.BOF And rec.EOF) Then
Do While Not rec.EOF
lCnt = lCnt + 1
ReDim Preserve aBody(1 To lCnt)
aRow(1) = rec("[Part#]")
aRow(2) = rec("PartDescription")
aRow(3) = rec("Qty")
aBody(lCnt) = "<tr><td>" & Join(aRow, "</td><td>") & "</td></tr>"
rec.MoveNext
Loop
End If
aBody(lCnt) = aBody(lCnt) & "</table></body></html>"
'create the email
Set olApp = CreateObject("Outlook.application")
Set olItem = olApp.CreateItem(0)
olItem.Display
olItem.To = "Email"
olItem.Subject = "Test E-mail"
olItem.HTMLBody = Join(aBody, vbNewLine)
olItem.Display
End Sub
Somewhere in your code, put a line that says
X = [Forms]![fmremail]![Text1]
Put a breakpoint in your code (hopefully you know how to do that?) on that line. When the code breaks, press F8 to step to the next line, and then type ?X in the Immediate Window. Or you can just hover your mouse over the line with the break point. The point is, you need to see what your code thinks [Forms]![fmremail]![Text1] is equal to. If it's null, you have a problem with your reference. In that case, you may need to add ".Value" or ".Text" to the end of it.
Another thing to check is your datatype for WOID. if it's text, you need to surround it with single quotes.
strQry = "SELECT tblePMParts.[Part#], tblePMParts.PartDescription, tblePMParts.Qty, tblePMParts.Price " & _
"FROM tblePMParts " & _
"WHERE (((tblePMParts.WOID)='" & [Forms]![fmremail]![Text1] & "'));"

Microsoft Access - Loop through all forms and controls on each form

Okay so when I press a specific button I want to loop through all forms, then find every control in each form with the tag 'TESTING'. If the tag = 'TESTING' then I want to change the caption of the object to 'abc123'.
The only objects with the tag 'TESTING' will be labels, so they will have the caption property.
So far I have this as the function:
Public Function changelabel()
On Error Resume Next
Dim obj As AccessObject, dbs As Object
Dim ctrl as Control
Set dbs = Application.CurrentProject
For Each obj In dbs.AllForms
DoCmd.OpenForm obj.Name, acDesign
For Each ctrl In Me.Controls
If ctrl.Tag = "TESTING" Then
ctrl.Caption = "abc123"
End If
Next ctrl
Next obj
End Function
Then this as the button code:
Public Sub TestButton_Click()
Call changelabel
End Sub
So it executes the first for loop and opens all the forms in design view correctly. The problem lies with the second for loop. None of the label captions that have the tag property as 'TESTING' are changed to 'abc123'.
So what do I need to change to get the second for loop to work?
Public Sub GetForms()
Dim oForm As Form
Dim nItem As Long
Dim bIsLoaded As Boolean
For nItem = 0 To CurrentProject.AllForms.Count - 1
bIsLoaded = CurrentProject.AllForms(nItem).IsLoaded
If Not bIsLoaded Then
On Error Resume Next
DoCmd.OpenForm CurrentProject.AllForms(nItem).NAME, acDesign
End If
Set oForm = Forms(CurrentProject.AllForms(nItem).NAME)
GetControls oForm
If Not bIsLoaded Then
On Error Resume Next
DoCmd.Close acForm, oForm.NAME
End If
Next
End Sub
Sub GetControls(ByVal oForm As Form)
Dim oCtrl As Control
Dim cCtrlType, cCtrlCaption As String
For Each oCtrl In oForm.Controls
If oCtrl.ControlType = acSubform Then Call GetControls(oCtrl.Form)
Select Case oCtrl.ControlType
Case acLabel: cCtrlType = "label": cCtrlCaption = oCtrl.Caption
Case acCommandButton: cCtrlType = "button": cCtrlCaption = oCtrl.Caption
Case acTextBox: cCtrlType = "textbox": cCtrlCaption = oCtrl.Properties("DataSheetCaption")
Case Else: cCtrlType = ""
End Select
If cCtrlType <> "" Then
Debug.Print oForm.NAME
Debug.Print oCtrl.NAME
Debug.Print cCtrlType
Debug.Print cCtrlCaption
End If
Next
End Sub
Something like this
Public Function changelabel()
Dim f As Form
Dim i As Integer
Dim c As Control
For i = 0 To CurrentProject.AllForms.Count - 1
If Not CurrentProject.AllForms(i).IsLoaded Then
DoCmd.OpenForm CurrentProject.AllForms(i).Name, acDesign
End If
Set f = Forms(i)
For Each c In f.Controls
If c.Tag = "TESTING" Then
c.Caption = "TESTING"
End If
Next c
Next i
End Function
You'll need to add a bit of house-keeping to set the objects used to nothing etc..

Loop subroutine for every used row using multiple dynamic cell references

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.

Modification to Ron De Bruins Email Different Files (?)

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