Show parent child linked records via VBA

J

jinsatoemo

New member
Local time
Today, 10:09
Joined
Nov 25, 2024
Messages
5
Good day all,

I'm trying to create\modify an existing vba code to generate an email via CDO that shows something like:

parent record
-child record
parent record
- child record

lets say i have 2 tables,table A(IDx primary key) and table B(IDx linked key).I want to generate all the parent data and show the linked child detail below the parent data.I can't seem to get the working code to link the parent and the child and to show it in the format that want.

For some reason,i cant post the example code of the ouput format that i want to modify as the web will give some spam error so i attach it as txt file.The code for the child data linking from table B is not there yet as i'm not sure how the coding will be.

I'm not familiar with VBA and dont have any skills with it either...I usually find any template codes and modify it as i see logic and see if it works..thank you in advance for any help and its much appreciated...
 

Attachments

You can always post code within code tags.
Also if you can attach that text file, you can attach a sample or original DB.

Here is something I used to use when I volunteered with SSAFA, however I was using Outlook for the emails.
There I include all items for a particular client.

Perhaps you can work from that?
 

Attachments

Last edited:
You'll probably need to create two recordsets, one of the Parent data and one of the child data, and loop around the Parent data, and then pull in the matching child data.

If you genuinely only have one child record per Parent record then it may be easier in a single recordset.
 
not tested:
Code: 
Function test()

Dim strMsg As String
Dim sqlString As String
Dim i As Integer
Dim rowColor As String
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset


sqlString = "SELECT * FROM A"
rs.Open sqlString, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

strMsg = "<table border='1' cellpadding='1' cellspacing='1' style='border-collapse: collapse' bordercolor='#111111' width='800'>" & _
"<tr>" & _
"<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Product</b></font></td>" & _
"</tr>"

i = 1

Dim rsChild As ADODB.Recordset

Do While Not rs.EOF

    sqlString = "SELECT * FROM B Where ParentID = " & rs!ID
    
    Set rsChild = New ADODB.Recordset
    rsChild.Open sqlString, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    
    If (i Mod 2 = 0) Then
    rowColor = "<td bgcolor='#FFFFFF'>&nbsp;"
    Else
    rowColor = "<td bgcolor='#E1DFDF'>&nbsp;"
    End If
    
    strMsg = strMsg & "<tr>" & _
    rowColor & "<font size='2'>" & rs.Fields("item") & "</font></td>" & _
    "</tr>"
    i = i + 1
    Do While Not rsChild.EOF
        If (i Mod 2 = 0) Then
        rowColor = "<td bgcolor='#FFFFFF'>&nbsp;"
        Else
        rowColor = "<td bgcolor='#E1DFDF'>&nbsp;"
        End If
        
        strMsg = strMsg & "<tr>" & _
        rowColor & "<font size='2'>" & rsChild.Fields("itemB") & "</font></td>" & _
        "</tr>"
        i = i + 1
        rsChild.MoveNext
    Loop
    rs.MoveNext
Loop

strMsg = strMsg & "</table>"
rs.Close


Set rs = Nothing

Dim objMessage, objConfig, Flds
Set objMessage = CreateObject("cdo.message")
Set objConfig = CreateObject("cdo.configuration")
Set Flds = objConfig.Fields

Flds.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
Flds.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.x.com"



Flds.Update
Set objMessage.Configuration = objConfig
objMessage.TO = "mat@x.com"
objMessage.FROM = "test<donotreply@x.com>"
objMessage.Subject = "Test Report For " & Format(Date - 2, "medium date")
objMessage.Fields.Update
objMessage.HTMLBody = "<font face=" & Chr(34) & "Calibri" & Chr(34) & " size=" & Chr(34) & "3" & Chr(34) & ">" & "Good day," & "<br /><br />" & "Here are the daily test report for " & _
"<b>" & Format(Date - 2, "medium date") & "</b>" & "<br /><br /><b><u>" & "Test report" & "</b><br /></b></u>" & strMsg & _
"<br /><br />" & "Thank You," & "<br />" & "X Team" & "</font>"
objMessage.Send
End Function
 
Last edited:
recommend you use indenting to make your code easier to use


Code: 
Function test()
Dim strMsg As String
Dim sqlString As String
Dim i As Integer
Dim rowColor As String
Dim rs As ADODB.Recordset
dim isParent as boolean
dim PK as long

Set rs = New ADODB.Recordset

'assumes B is the name of your child table and the join is on fields called APK and AFK
sqlString = "SELECT * FROM A INNER JOIN B ON A.APK=B.AFK ORDER BY A.APK, B.BPK" 'note the sort on the BPK - not necessarily required
rs.Open sqlString, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

strMsg = "<table border='1' cellpadding='1' cellspacing='1' style='border-collapse: collapse' bordercolor='#111111' width='800'>" & _
                "<tr>" & _
                "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Product</b></font></td>" & _
                "</tr>"

'set the parameters for code control
i = 0
isParent=true
PK=rs!APK

Do While Not rs.EOF

    If (i Mod 2 = 0) Then
        rowColor = "<td bgcolor='#FFFFFF'>&nbsp;"
    Else
      rowColor = "<td bgcolor='#E1DFDF'>&nbsp;"
    End If

    if isParent then
        strMsg = strMsg & "<tr>" & rowColor & "<font size='2'>" & rs!Item & "</font></td></tr>"
        isParent=false
    Else
        'substitute whatever you want to appear for ChildItem
        strMsg = strMsg & "<tr>" & rowColor & "<font size='2'>" & rs!ChildItem & "</font></td></tr>"
    End If

    rs.MoveNext
    i = i + 1

    if rs!APK<>PK
        PK=rs!APK
        isParent=true
     end if

Loop

strMsg = strMsg & "</table>"
rs.Close
Set rs = Nothing

Set objMessage = CreateObject("cdo.message")
Set objConfig = CreateObject("cdo.configuration")
Set Flds = objConfig.Fields
Flds.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
Flds.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.x.com"
Flds.Update

Set objMessage.Configuration = objConfig
objMessage.TO = "mat@x.com"
objMessage.FROM = "test<donotreply@x.com>"
objMessage.Subject = "Test Report For " & Format(Date - 2, "medium date")
objMessage.Fields.Update
objMessage.HTMLBody = "<font face=" & Chr(34) & "Calibri" & Chr(34) & " size=" & Chr(34) & "3" & Chr(34) & ">" & "Good day," & _
                                          "<br /><br />" & "Here are the daily test report for " & _
                                          "<b>" & Format(Date - 2, "medium date") & "</b>" & "<br /><br /><b><u>" & "Test report" & _
                                          "</b><br /></b></u>" & strMsg & _
                                          "<br /><br />" & "Thank You," & "<br />" & "X Team" & "</font>"
objMessage.Send

End Function
 
Good day friends,

Firstly,very much thank you and appreciation to all of you who contributed your time and expertise to help me.because of this,i have managed to get the result that i wanted.All your inputs are sooooooo valuable to me and others who came to seek the solution for this kind of inquiry.
One more inquiry is,can the child linked record have column headers to make it more meaningful on what data it represents?currently it looks like this
parentchild.jpg


the child linked records(in red circle) follows the parent records perfectly but it lacks child field headers.I tried all logically way to put headers in that but it doesnt come out right.....Many thanks in advance for your kindness...
 
maybe it is time you share your Header/Detail tables.
it is very easy to work on somewhat actual data.
 
Attached is the code that i used,modified accordingly

I want to create the table headers for the 5 columns child link data....

Also how do u refer this part as string if needed as it will give u a type mismatched error
sqlString = "SELECT * FROM [LRMS-Q] Where LRMRID = " & rs!LRMRID

Many thanks
 

Attachments

try:
Code: 
Function test()

Dim strMsg As String
Dim sqlString As String
Dim i As Integer
Dim rowColor As String
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset


sqlString = "SELECT * FROM [LRM-Q2W]"
rs.Open sqlString, CurrentProject.Connection, adOpenKeyset, adLockOptimistic


i = 1

Dim rsChild As ADODB.Recordset

Do While Not rs.EOF

    sqlString = "SELECT * FROM [LRMS-Q] Where LRMRID = " & rs!LRMRID
    
    Set rsChild = New ADODB.Recordset
    rsChild.Open sqlString, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    
    strMsg = strNsg & "<table border='1' cellpadding='1' cellspacing='1' style='border-collapse: collapse' bordercolor='#111111' width='800'>" & _
    "<tr>" & _
     "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Delivery Date</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>PO No.</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Supplier</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Category</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Part Code</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Description</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Total Qty</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Unit</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Trips</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Qty/Trip</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Location</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Remarks</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Received Qty</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Completion %</b></font></td>" & _
    "</tr>"

    If (i Mod 2 = 0) Then
    rowColor = "<td bgcolor='#FFFFFF'>&nbsp;"
    Else
    rowColor = "<td bgcolor='#E1DFDF'>&nbsp;"
    End If
    
    strMsg = strMsg & "<tr>" & _
    rowColor & "<font size='2'>" & rs.Fields("DelDAte") & "</font></td>" & _
    rowColor & "<font size='2'>" & rs.Fields("PONo") & "</font></td>" & _
    rowColor & "<font size='2'>" & rs.Fields("Supplier") & "</font></td>" & _
    rowColor & "<font size='2'>" & rs.Fields("ItemCat") & "</font></td>" & _
    rowColor & "<font size='2'>" & rs.Fields("Item") & "</font></td>" & _
    rowColor & "<font size='2'>" & rs.Fields("Remarks") & "</font></td>" & _
    rowColor & "<font size='2'>" & rs.Fields("TMT") & "</font></td>" & _
    rowColor & "<font size='2'>" & rs.Fields("ItemUnit") & "</font></td>" & _
    rowColor & "<font size='2'>" & rs.Fields("Trips") & "</font></td>" & _
    rowColor & "<font size='2'>" & rs.Fields("MTPT") & "</font></td>" & _
    rowColor & "<font size='2'>" & rs.Fields("Loc") & "</font></td>" & _
    rowColor & "<font size='2'>" & rs.Fields("LRMRem") & "</font></td>" & _
    rowColor & "<font size='2'>" & rs.Fields("SumOfRMTx") & "</font></td>" & _
    rowColor & "<font size='2'>" & rs.Fields("PCP") & "</font></td>" & _
    "</tr></table>"
    
    i = i + 1
    
    strMsg = strNsg & "<table border='1' cellpadding='1' cellspacing='1' style='border-collapse: collapse' bordercolor='#111111' width='800'>" & _
    "<tr>" & _
     "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Delivery Date</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Delivery Time</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>RMT</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Location</b></font></td>" & _
        "<td bgcolor='#7EA7CC'>&nbsp;<font size='2'><b>Remarks</b></font></td>" & _
    "</tr>"

    Do While Not rsChild.EOF
    
        If (i Mod 2 = 0) Then
        rowColor = "<td bgcolor='#FFFFFF'>&nbsp;"
        Else
        rowColor = "<td bgcolor='#E1DFDF'>&nbsp;"
        End If
           
        strMsg = strMsg & "<tr>" & _
        rowColor & "<font size='2'>" & Format(rsChild.Fields("Deldate"), "dd/MM/YY") & "</font></td>" & _
        rowColor & "<font size='2'>" & Format(rsChild.Fields("Deltime"), "short time") & "</font></td>" & _
        rowColor & "<font size='2'>" & Format(rsChild.Fields("RMT"), "0.00") & "</font></td>" & _
        rowColor & "<font size='2'>" & rsChild.Fields("Rloc") & "</font></td>" & _
        rowColor & "<font size='2'>" & rsChild.Fields("LRMSRem") & "</font></td>" & _
        "</tr>"
        
        i = i + 1
        rsChild.MoveNext
    Loop
    strMsg = strMsg & </table><br>"
    rs.MoveNext
Loop


rs.Close


Set rs = Nothing

Dim objMessage, objConfig, Flds
Set objMessage = CreateObject("cdo.message")
Set objConfig = CreateObject("cdo.configuration")
Set Flds = objConfig.Fields

Flds.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
Flds.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "mail.x.com"



Flds.Update
Set objMessage.Configuration = objConfig
objMessage.TO = "mat@x.com"
objMessage.FROM = "test<donotreply@x.com>"
objMessage.Subject = "Test Report For " & Format(Date - 2, "medium date")
objMessage.Fields.Update
objMessage.HTMLBody = "<font face=" & Chr(34) & "Calibri" & Chr(34) & " size=" & Chr(34) & "3" & Chr(34) & ">" & "Good day," & "<br /><br />" & "Here are the daily test report for " & _
"<b>" & Format(Date - 2, "medium date") & "</b>" & "<br /><br /><b><u>" & "Test report" & "</b><br /></b></u>" & strMsg & _
"<br /><br />" & "Thank You," & "<br />" & "The X Team" & "</font>"
objMessage.Send
End Function
 
Good day arnelgp,

This my friend works perfectly for my situation.Thank you so much for your expertise and kindness!Not forgotting to other friends who contributed as well as its all a very very valuable knowledge in multiple scenarios.Thank you friends and its very much appreciated.May you all have a very good and blessed life.

Btw,the code got some minor typo and punctuation error which can be figured out easily.Below is the sample output

parentchild.jpg
 
You must log in or register to reply here.

Similar threads

N
Solved How to parse Json received data into a parent and child tables in access
Replies
14
Views
1,557
nector
N
A
Mail merge query with multiple records
Replies
10
Views
290
ebs17
E
N
How to update Parent form controls from the child / subform line totals
Replies
7
Views
614
nector
N
T
Solved very simple, but can't figure it out
Replies
5
Views
104
TipsyWolf
T
J
Solved subform remains blank after new record saved
Replies
3
Views
606
Jaks
J

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom