Inserting a database address - code listing

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