This is a complete listing of the code referred to in the previous example.
If you want to make use of this macro, copy and paste into the macro editor and then replace the dbpath, tbname and srchfld text on lines 4 to 6 with your own data. Also adjust the function BuildAddBlock to match your own field names.
Sub InsertDBAddress
Dim app, mydb, mytb, srchtxt, dbpath, tbname, srchfld, qrytxt
dbpath = "c:\my documents\mydata.adb"
tbname = "mytable"
srchfld = "Lastname"
Set app = CreateObject("AbilityDatabase.Application")
app.Databases.Open dbpath, False
Set mydb = app.ActiveDatabase
srchtxt = InputBox("Enter " & srchfld & ":", "Ability Message")
If Len(srchtxt) = 0 Then
Exit Sub
End If
qrytxt = "SELECT * FROM " & tbname & " WHERE " & srchfld & "='" & srchtxt & "'"
Set mytb = mydb.Admin.OpenRecordset(qrytxt)
If mytb.BOF Then
MsgBox "No matching records"
Exit Sub
End If
mytb.MoveNext
If mytb.EOF Then
mytb.MoveFirst
Selection.InsertAfter BuildAddBlock(mytb.Fields)
Selection.Collapse(1)
End If
mytb.MoveFirst
Do
ret = MsgBox("More than one record - Select this record " & _
"With the Yes button or choose No For Next " & _
"record" & vbCr & vbCr & BuildAddBlock(mytb.Fields), _
vbYesNoCancel, _
"Ability Message")
If ret = vbCancel Then
Exit Sub
ElseIf ret = vbYes Then
Exit Do
End If
mytb.MoveNext
If mytb.EOF Then
ret = MsgBox("End of records!" & vbCr & vbCr & _
"Review records again?", vbYesNo, _
"Ability Message")
If ret = vbNo Then
Exit Sub
End If
mytb.MoveFirst
End If
Loop
Selection.InsertAfter BuildAddBlock(mytb.Fields)
Selection.Collapse(1)
End Sub
Function BuildAddBlock(Flds)
Dim s
s = Flds("CustTitle") & " " & Flds("FirstName") & " " & Flds("Lastname") & vbCr
s = s & AddLine(Flds("Company"))
s = s & AddLine(Flds("Add1"))
s = s & AddLine(Flds("Add2"))
s = s & AddLine(Flds("Add3"))
s = s & AddLine(Flds("Add4"))
s = s & AddLine(Flds("Postcode"))
BuildAddBlock = s
End Function
Function AddLine(x)
AddLine = ""
If Len(x) > 0 Then
AddLine = x & vbCr
End If
End Function