Helen Limehouse
2012-06-07 14:14:04 UTC
Hello,
I am in the process of reverse engineering the data collection functionality (this is where I found out I could do this reverse engineering of this process: http://blogs.office.com/b/microsoft-access/archive/2009/02/09/automate-data-collection-forms-using-vba.aspx) in access 2010, and am running into an issue when creating the html email. I have a vba module which does the following:
1. Creates a entry in the AccessDCActionFile.xml file, which is what links the html email created later with the access tables to update.
2. Creates a record in the MsysDataCollection table in access, which also creates a unique GUID. This GUID links this table with the record in the file above and also the html email created later and sent to outlook.
This is the proc:
Private Sub AddRecordToXMLFile()
Dim strFirstQuery, strSecondQuery, strThirdQuery As String
Dim strPath, strPath1, strPath2 As String
Dim strData, strResult As String
Dim strtmp, strfulltmp As String
'strPath = "c:\clientmatters\AccessDCActionFile.xml" 'Header Information file
'strResult = "c:\clientmatters\AccessDCActionFile_Updated.xml" 'Result of the three merged files
FileCopy "c:\users\lime1399\appdata\roaming\microsoft\access\AccessDCActionFile.xml", "c:\users\lime1399\appdata\roaming\microsoft\access\AccessDCActionFile_Input.xml"
strPath = "c:\users\lime1399\appdata\roaming\microsoft\access\AccessDCActionFile_Input.xml" 'Header Information file
strResult = "c:\users\lime1399\appdata\roaming\microsoft\access\AccessDCActionFile.xml" 'Result of the three merged files
Open strPath For Input As #1 'Open Header
Open strResult For Output As #4 'Open Results File
Dim db As DAO.Database
Dim rstAdd As DAO.Recordset
Dim rstFormID As DAO.Recordset
Dim rstDataCollection As DAO.Recordset
Dim rstDataCollectionCopyFrom As DAO.Recordset
Dim newGUID As String
Dim Mapping As String
Dim OutlookFolder As String
Dim FormID As String
Set db = CurrentDb
Set rstAdd = db.OpenRecordset("Table3_Keep")
Set rstFormID = db.OpenRecordset("FormID")
Set rstDataCollection = db.OpenRecordset("MsysDataCollection")
Set rstDataCollectionCopyFrom = db.OpenRecordset("Select Mapping, OutlookFolder, CreatedDate from MSysDataCollection order by CreatedDate desc")
rstDataCollectionCopyFrom.MoveFirst
Mapping = rstDataCollectionCopyFrom![Mapping].Value
OutlookFolder = rstDataCollectionCopyFrom![OutlookFolder].Value
rstDataCollectionCopyFrom.Close
Set rstDataCollectionCopyFrom = Nothing
rstAdd.MoveFirst
rstAdd.Delete
rstAdd.AddNew
rstAdd.Update
rstAdd.MoveFirst
newGUID = Mid(rstAdd![ID].Value, 6, 39)
'rstAdd.Close
'Set rstAdd = Nothing
DoCmd.SetWarnings False
DoCmd.OpenQuery "QryUpdateFormID"
rstFormID.MoveFirst
FormID = rstFormID![FormID].Value
rstFormID.Close
Set rstFormID = Nothing
rstDataCollection.MoveLast
rstDataCollection.AddNew
rstDataCollection("Active") = -1
rstDataCollection("BasedOnType") = 1
rstDataCollection("CreatedDate") = Now()
rstDataCollection("ExternalID") = rstAdd![ID].Value
rstDataCollection("FormName") = "Client Matters Update Form"
rstDataCollection("InfoPathForm") = 0
rstDataCollection("Mapping") = Mapping
rstDataCollection("OutlookFolder") = OutlookFolder
rstDataCollection("SentDate") = Now()
rstDataCollection.Update
rstAdd.Close
Set rstAdd = Nothing
rstDataCollection.Close
Set rstDataCollection = Nothing
Do While Not EOF(1)
Line Input #1, tmp
fulltmp = Mid(tmp, 1, InStr(tmp, "</mdb") - 1) & FormID & "</mdbMap><sendingGuids/><lastShutdown>41022.64263455113</lastShutdown></ActionConfigFile>"
Loop
Print #4, fulltmp 'Make Merged Results File
Close #4 'Close Files
Close #1
Kill "c:\users\lime1399\appdata\roaming\microsoft\access\AccessDCActionFile_Input.xml"
CreateEmail2
End Sub
-------- End of Proc
I then create the html email which contains the fields and is formatted as close to the email which access generates for this purpose (if you were to look under the hood at the email that access creates during the data collection process).
I think here is where my issue resides, as this proc is indeed creating the email, but when the email gets to outlook, it does not contain something I need, as it does not show this when you mouse over the email (which an email created by the data collection process does):
AccessDataCollection:{F2bfo...GUID here..}.
Can you please look at my email proc below and let me know what I am missing?
Private Sub CreateEmail()
Dim strFirstQuery, strSecondQuery, strThirdQuery As String
Dim strPath, strPath1, strPath2 As String
Dim strData, strResult As String
Dim strtmp, strfulltmp, strfulltmpTop, strfulltmpBottom As String
Dim ODAttorney As String
Dim MyOutlook As Outlook.Application
Set MyOutlook = New Outlook.Application
Dim MyMail As Outlook.MailItem
Set MyMail = MyOutlook.CreateItem(olMailItem)
Dim Subjectline As String
Dim BodyFile As String
Subjectline$ = InputBox$("Please enter the subject line for this mailing.", _
"We Need A Subject Line!")
Set MyOutlook = New Outlook.Application
strPath = "c:\clientmatters\Email_HTML.html" 'Email
Open strPath For Output As #1 'Open Email File
Dim db As DAO.Database
Dim rstEmailInserts As DAO.Recordset
Dim rstEmailTo As DAO.Recordset
Set db = CurrentDb
Set rstEmailInserts = db.OpenRecordset("TableEmailInsert")
rstEmailInserts.MoveFirst
strfulltmpTop = rstEmailInserts![Section1].Value
strfulltmpBottom = rstEmailInserts![Section21].Value
Set rstEmailTo = db.OpenRecordset("Select * from EmailToTable Order by ODAttorneyEmail")
rstEmailTo.MoveFirst
ODAttorney = rstEmailTo![ODAttorneyEmail].Value
strfulltmp = strfulltmpTop
Do While Not rstEmailTo.EOF
strfulltmp = strfulltmpTop
Do While ODAttorney = rstEmailTo![ODAttorneyEmail].Value And Not rstEmailTo.EOF
If Not rstEmailTo.EOF Then
ODAttorney = rstEmailTo![ODAttorneyEmail].Value
Else
Exit Do
End If
strfulltmp = strfulltmp & rstEmailInserts![Section2a].Value & rstEmailTo![Client/Matter#].Value
strfulltmp = strfulltmp & rstEmailInserts![Section2b].Value & rstEmailTo![Client/Matter#].Value
strfulltmp = strfulltmp & rstEmailInserts![Section2c].Value & rstEmailTo![Client/Matter#].Value
'strfulltmp = strfulltmp & rstEmailInserts![Section2].Value & rstEmailTo![Client/Matter#].Value
strfulltmp = strfulltmp & rstEmailInserts![Section3].Value & rstEmailTo![CaseName].Value
strfulltmp = strfulltmp & rstEmailInserts![Section4].Value & rstEmailTo![CaseType].Value
strfulltmp = strfulltmp & rstEmailInserts![Section5].Value & rstEmailTo![LocationofMatter].Value
strfulltmp = strfulltmp & rstEmailInserts![Section6].Value & rstEmailTo![Court/Venue].Value
strfulltmp = strfulltmp & rstEmailInserts![Section7].Value & rstEmailTo![CaseDescription].Value
strfulltmp = strfulltmp & rstEmailInserts![Section8].Value & rstEmailTo![FileDate].Value
strfulltmp = strfulltmp & rstEmailInserts![Section9].Value & rstEmailTo![CutoffDate].Value
strfulltmp = strfulltmp & rstEmailInserts![Section10].Value & rstEmailTo![Mediation/Trial Date].Value
strfulltmp = strfulltmp & rstEmailInserts![Section11].Value & rstEmailTo![Tyco Attorney].Value
strfulltmp = strfulltmp & rstEmailInserts![Section12].Value & rstEmailTo![Tyco HR Rep].Value
strfulltmp = strfulltmp & rstEmailInserts![Section13].Value & rstEmailTo![Estimated Budget].Value
strfulltmp = strfulltmp & rstEmailInserts![Section14].Value & rstEmailTo![CaseStatus].Value
strfulltmp = strfulltmp & rstEmailInserts![Section15].Value & rstEmailTo![SummaryofCurrentStatus].Value
strfulltmp = strfulltmp & rstEmailInserts![Section16].Value & rstEmailTo![FullDateofResolution].Value
strfulltmp = strfulltmp & rstEmailInserts![Section17].Value & rstEmailTo![CaseOutcome].Value
strfulltmp = strfulltmp & rstEmailInserts![Section18].Value & rstEmailTo![Settlement/Award].Value
strfulltmp = strfulltmp & rstEmailInserts![Section19].Value & rstEmailTo![DescriptionofCaseOutcome].Value
strfulltmp = strfulltmp & rstEmailInserts![Section20].Value
rstEmailTo.MoveNext
If rstEmailTo.EOF Then
Exit Do
End If
Loop
strfulltmp = strfulltmp & rstEmailInserts![Section21].Value
Print #1, strfulltmp
MyMail.To = ODAttorney
MyMail.Subject = Subjectline$
MyMail.HTMLBody = strfulltmp
MyMail.Send
Loop
Set MyOutlook = Nothing
Close #1 'Close Files
Close #1
rstEmailInserts.Close
Set rstEmailInserts = Nothing
rstEmailTo.Close
Set rstEmailTo = Nothing
End Sub
Any help would be most appreciated :).
Thank you,
Helen Limehouse
I am in the process of reverse engineering the data collection functionality (this is where I found out I could do this reverse engineering of this process: http://blogs.office.com/b/microsoft-access/archive/2009/02/09/automate-data-collection-forms-using-vba.aspx) in access 2010, and am running into an issue when creating the html email. I have a vba module which does the following:
1. Creates a entry in the AccessDCActionFile.xml file, which is what links the html email created later with the access tables to update.
2. Creates a record in the MsysDataCollection table in access, which also creates a unique GUID. This GUID links this table with the record in the file above and also the html email created later and sent to outlook.
This is the proc:
Private Sub AddRecordToXMLFile()
Dim strFirstQuery, strSecondQuery, strThirdQuery As String
Dim strPath, strPath1, strPath2 As String
Dim strData, strResult As String
Dim strtmp, strfulltmp As String
'strPath = "c:\clientmatters\AccessDCActionFile.xml" 'Header Information file
'strResult = "c:\clientmatters\AccessDCActionFile_Updated.xml" 'Result of the three merged files
FileCopy "c:\users\lime1399\appdata\roaming\microsoft\access\AccessDCActionFile.xml", "c:\users\lime1399\appdata\roaming\microsoft\access\AccessDCActionFile_Input.xml"
strPath = "c:\users\lime1399\appdata\roaming\microsoft\access\AccessDCActionFile_Input.xml" 'Header Information file
strResult = "c:\users\lime1399\appdata\roaming\microsoft\access\AccessDCActionFile.xml" 'Result of the three merged files
Open strPath For Input As #1 'Open Header
Open strResult For Output As #4 'Open Results File
Dim db As DAO.Database
Dim rstAdd As DAO.Recordset
Dim rstFormID As DAO.Recordset
Dim rstDataCollection As DAO.Recordset
Dim rstDataCollectionCopyFrom As DAO.Recordset
Dim newGUID As String
Dim Mapping As String
Dim OutlookFolder As String
Dim FormID As String
Set db = CurrentDb
Set rstAdd = db.OpenRecordset("Table3_Keep")
Set rstFormID = db.OpenRecordset("FormID")
Set rstDataCollection = db.OpenRecordset("MsysDataCollection")
Set rstDataCollectionCopyFrom = db.OpenRecordset("Select Mapping, OutlookFolder, CreatedDate from MSysDataCollection order by CreatedDate desc")
rstDataCollectionCopyFrom.MoveFirst
Mapping = rstDataCollectionCopyFrom![Mapping].Value
OutlookFolder = rstDataCollectionCopyFrom![OutlookFolder].Value
rstDataCollectionCopyFrom.Close
Set rstDataCollectionCopyFrom = Nothing
rstAdd.MoveFirst
rstAdd.Delete
rstAdd.AddNew
rstAdd.Update
rstAdd.MoveFirst
newGUID = Mid(rstAdd![ID].Value, 6, 39)
'rstAdd.Close
'Set rstAdd = Nothing
DoCmd.SetWarnings False
DoCmd.OpenQuery "QryUpdateFormID"
rstFormID.MoveFirst
FormID = rstFormID![FormID].Value
rstFormID.Close
Set rstFormID = Nothing
rstDataCollection.MoveLast
rstDataCollection.AddNew
rstDataCollection("Active") = -1
rstDataCollection("BasedOnType") = 1
rstDataCollection("CreatedDate") = Now()
rstDataCollection("ExternalID") = rstAdd![ID].Value
rstDataCollection("FormName") = "Client Matters Update Form"
rstDataCollection("InfoPathForm") = 0
rstDataCollection("Mapping") = Mapping
rstDataCollection("OutlookFolder") = OutlookFolder
rstDataCollection("SentDate") = Now()
rstDataCollection.Update
rstAdd.Close
Set rstAdd = Nothing
rstDataCollection.Close
Set rstDataCollection = Nothing
Do While Not EOF(1)
Line Input #1, tmp
fulltmp = Mid(tmp, 1, InStr(tmp, "</mdb") - 1) & FormID & "</mdbMap><sendingGuids/><lastShutdown>41022.64263455113</lastShutdown></ActionConfigFile>"
Loop
Print #4, fulltmp 'Make Merged Results File
Close #4 'Close Files
Close #1
Kill "c:\users\lime1399\appdata\roaming\microsoft\access\AccessDCActionFile_Input.xml"
CreateEmail2
End Sub
-------- End of Proc
I then create the html email which contains the fields and is formatted as close to the email which access generates for this purpose (if you were to look under the hood at the email that access creates during the data collection process).
I think here is where my issue resides, as this proc is indeed creating the email, but when the email gets to outlook, it does not contain something I need, as it does not show this when you mouse over the email (which an email created by the data collection process does):
AccessDataCollection:{F2bfo...GUID here..}.
Can you please look at my email proc below and let me know what I am missing?
Private Sub CreateEmail()
Dim strFirstQuery, strSecondQuery, strThirdQuery As String
Dim strPath, strPath1, strPath2 As String
Dim strData, strResult As String
Dim strtmp, strfulltmp, strfulltmpTop, strfulltmpBottom As String
Dim ODAttorney As String
Dim MyOutlook As Outlook.Application
Set MyOutlook = New Outlook.Application
Dim MyMail As Outlook.MailItem
Set MyMail = MyOutlook.CreateItem(olMailItem)
Dim Subjectline As String
Dim BodyFile As String
Subjectline$ = InputBox$("Please enter the subject line for this mailing.", _
"We Need A Subject Line!")
Set MyOutlook = New Outlook.Application
strPath = "c:\clientmatters\Email_HTML.html" 'Email
Open strPath For Output As #1 'Open Email File
Dim db As DAO.Database
Dim rstEmailInserts As DAO.Recordset
Dim rstEmailTo As DAO.Recordset
Set db = CurrentDb
Set rstEmailInserts = db.OpenRecordset("TableEmailInsert")
rstEmailInserts.MoveFirst
strfulltmpTop = rstEmailInserts![Section1].Value
strfulltmpBottom = rstEmailInserts![Section21].Value
Set rstEmailTo = db.OpenRecordset("Select * from EmailToTable Order by ODAttorneyEmail")
rstEmailTo.MoveFirst
ODAttorney = rstEmailTo![ODAttorneyEmail].Value
strfulltmp = strfulltmpTop
Do While Not rstEmailTo.EOF
strfulltmp = strfulltmpTop
Do While ODAttorney = rstEmailTo![ODAttorneyEmail].Value And Not rstEmailTo.EOF
If Not rstEmailTo.EOF Then
ODAttorney = rstEmailTo![ODAttorneyEmail].Value
Else
Exit Do
End If
strfulltmp = strfulltmp & rstEmailInserts![Section2a].Value & rstEmailTo![Client/Matter#].Value
strfulltmp = strfulltmp & rstEmailInserts![Section2b].Value & rstEmailTo![Client/Matter#].Value
strfulltmp = strfulltmp & rstEmailInserts![Section2c].Value & rstEmailTo![Client/Matter#].Value
'strfulltmp = strfulltmp & rstEmailInserts![Section2].Value & rstEmailTo![Client/Matter#].Value
strfulltmp = strfulltmp & rstEmailInserts![Section3].Value & rstEmailTo![CaseName].Value
strfulltmp = strfulltmp & rstEmailInserts![Section4].Value & rstEmailTo![CaseType].Value
strfulltmp = strfulltmp & rstEmailInserts![Section5].Value & rstEmailTo![LocationofMatter].Value
strfulltmp = strfulltmp & rstEmailInserts![Section6].Value & rstEmailTo![Court/Venue].Value
strfulltmp = strfulltmp & rstEmailInserts![Section7].Value & rstEmailTo![CaseDescription].Value
strfulltmp = strfulltmp & rstEmailInserts![Section8].Value & rstEmailTo![FileDate].Value
strfulltmp = strfulltmp & rstEmailInserts![Section9].Value & rstEmailTo![CutoffDate].Value
strfulltmp = strfulltmp & rstEmailInserts![Section10].Value & rstEmailTo![Mediation/Trial Date].Value
strfulltmp = strfulltmp & rstEmailInserts![Section11].Value & rstEmailTo![Tyco Attorney].Value
strfulltmp = strfulltmp & rstEmailInserts![Section12].Value & rstEmailTo![Tyco HR Rep].Value
strfulltmp = strfulltmp & rstEmailInserts![Section13].Value & rstEmailTo![Estimated Budget].Value
strfulltmp = strfulltmp & rstEmailInserts![Section14].Value & rstEmailTo![CaseStatus].Value
strfulltmp = strfulltmp & rstEmailInserts![Section15].Value & rstEmailTo![SummaryofCurrentStatus].Value
strfulltmp = strfulltmp & rstEmailInserts![Section16].Value & rstEmailTo![FullDateofResolution].Value
strfulltmp = strfulltmp & rstEmailInserts![Section17].Value & rstEmailTo![CaseOutcome].Value
strfulltmp = strfulltmp & rstEmailInserts![Section18].Value & rstEmailTo![Settlement/Award].Value
strfulltmp = strfulltmp & rstEmailInserts![Section19].Value & rstEmailTo![DescriptionofCaseOutcome].Value
strfulltmp = strfulltmp & rstEmailInserts![Section20].Value
rstEmailTo.MoveNext
If rstEmailTo.EOF Then
Exit Do
End If
Loop
strfulltmp = strfulltmp & rstEmailInserts![Section21].Value
Print #1, strfulltmp
MyMail.To = ODAttorney
MyMail.Subject = Subjectline$
MyMail.HTMLBody = strfulltmp
MyMail.Send
Loop
Set MyOutlook = Nothing
Close #1 'Close Files
Close #1
rstEmailInserts.Close
Set rstEmailInserts = Nothing
rstEmailTo.Close
Set rstEmailTo = Nothing
End Sub
Any help would be most appreciated :).
Thank you,
Helen Limehouse