Thanks for your reply, including the tip about the password (I hadn't noticed it). There's rather a lot more code. I don't expect anyone to work it all out for me, but here it is:
Code:
Option Explicit
Dim G_PageLen As Integer
Code:
Function BuildDutyOfCareReps(Db As Database) As Boolean
Dim cwtnSet As Recordset
Dim SQLString As String
Dim NoOfPages As Integer
Dim CopyNo As Integer
Dim PrintLabels As Boolean
Dim Reply As Integer
Dim NoOfRecords As Long
Dim CurrRecord As Long
Dim FooterMessage As String
BuildDutyOfCareReps = True
Set cwtnSet = Db.OpenRecordset("SELECT * FROM cwtn_head_rep WHERE print_flag = 'N'", dbOpenDynaset)
If cwtnSet.EOF And cwtnSet.BOF Then
MsgBox "No outstanding notices to print", vbOKOnly + vbInformation, "Duty Of Care Report"
BuildDutyOfCareReps = False
Exit Function
End If
Reply = MsgBox("Print Address Labels ?", vbYesNoCancel, "Duty Of Care")
If Reply = vbCancel Then
BuildDutyOfCareReps = False
Exit Function
ElseIf Reply = vbYes Then
PrintLabels = True
Else
PrintLabels = False
End If
FooterMessage = InputBox("Enter footer text :", "Notice Footer")
If Len(FooterMessage) > 0 Then
G_PageLen = 53
Else
G_PageLen = 54
End If
cwtnSet.MoveLast
NoOfRecords = cwtnSet.RecordCount
CurrRecord = 0
cwtnSet.MoveFirst
Do
CurrRecord = CurrRecord + 1
NoOfPages = GetNoOfPages(Db, cwtnSet)
For CopyNo = 1 To cwtnSet!print_copies
If AddPage1Header(Db, cwtnSet, NoOfPages) <> True Then
BuildDutyOfCareReps = False
Exit Function
End If
If AddItems(Db, cwtnSet, NoOfPages) <> True Then
BuildDutyOfCareReps = False
Exit Function
End If
If Not (cwtnSet.AbsolutePosition = cwtnSet.RecordCount - 1 And CopyNo = cwtnSet!print_copies) Then
Selection.InsertBreak wdPageBreak
End If
Next
SQLString = "UPDATE cwtn_head_rep SET print_flag='Y' WHERE cwtn_no=" & cwtnSet.Fields("cwtn_no")
Db.Execute SQLString
If PrintLabels = True Then
SQLString = "UPDATE cwtn_head_rep SET label_flag='Y' WHERE cwtn_no=" & cwtnSet.Fields("cwtn_no")
Db.Execute SQLString
End If
cwtnSet.MoveNext
Loop While Not cwtnSet.EOF
With ActiveDocument.Sections(1)
.Footers(wdHeaderFooterPrimary).Range.Text = "Note: Please check the waste transfer notice details amending as appropriate. Sign and return one copy to: City Services, Mill Road Depot, Cambridge, CB1 2AZ and retain one for your own records (which must be retained for two years)."
.Headers(wdHeaderFooterPrimary).Exists = False
If Len(FooterMessage) > 0 Then
.Footers(wdHeaderFooterPrimary).Range.InsertAfter vbCr & "* " & FooterMessage
End If
End With
cwtnSet.Close
End Function
Code:
Function GetNoOfPages(Db As Database, cwtnSet As Recordset) As Integer
Dim cwtnItemSet As Recordset
Dim NoOfItems As Integer
GetNoOfPages = 1
Set cwtnItemSet = Db.OpenRecordset("SELECT * FROM cwtn_item_rep WHERE cwtn_no = " & cwtnSet!cwtn_no, dbOpenDynaset)
If cwtnItemSet.EOF And cwtnItemSet.BOF Then
Exit Function
End If
cwtnItemSet.MoveLast
NoOfItems = cwtnItemSet.RecordCount
If NoOfItems > 2 Then
If NoOfItems <= 10 Then
GetNoOfPages = 2
Else
If NoOfItems <= 18 Then
GetNoOfPages = 3
Else
GetNoOfPages = ((NoOfItems - 10) / 8) + 2
End If
End If
End If
End Function
Code:
Function AddReportFooter(Db As Database, cwtnSet As Recordset, PageNo As Integer, NoOfPages As Integer)
Dim LineNo As Integer
CheckNewPage Db, cwtnSet, 9, PageNo, NoOfPages
Selection.EndOf Unit:=wdLine, Extend:=wdMove
For LineNo = Selection.Information(wdFirstCharacterLineNumber) To G_PageLen - 9
Selection.TypeText vbCr
Next
Selection.InlineShapes.AddHorizontalLineStandard
Selection.Font.Bold = True
Selection.TypeText "TRANSFER PERIOD: " & cwtnSet!start_date & " TO " & cwtnSet!end_date & vbCr
Selection.InlineShapes.AddHorizontalLineStandard
Selection.TypeText "To be signed by customer (producer of waste)" & vbCr & vbCr
Selection.TypeText "Signed: Print Name (Block Capital):" & vbCr & vbCr & vbCr
Selection.TypeText "Representing: " & cwtnSet!dbtr_name
End Function
Code:
Function AddItems(Db As Database, cwtnSet As Recordset, NoOfPages As Integer)
Dim WasteType As String
Dim WasteDesc As String
Dim cwtnItemSet As Recordset
Dim CwtnNo As Long
Dim TaskDesc As String
Dim TaskCode As String
Dim TaskBins As Integer
Dim CollectionDay As String
Dim MultFlag As String
Dim PageNo As Integer
AddItems = True
PageNo = 1
CwtnNo = cwtnSet.Fields("cwtn_no")
Set cwtnItemSet = Db.OpenRecordset("SELECT * FROM cwtn_item_rep WHERE cwtn_no = " & CwtnNo, dbOpenDynaset)
If cwtnItemSet.EOF And cwtnItemSet.BOF Then
Selection.TypeText "No Records Found" & Chr$(13)
Else
cwtnItemSet.MoveFirst
Do
PageNo = CheckNewPage(Db, cwtnSet, 5, PageNo, NoOfPages)
Selection.Font.Bold = False
Selection.TypeText "Waste Contained in:" & vbTab & "Qty:" & vbTab & "Collection Days:" & vbTab & "M:" & vbCr
TaskCode = ""
TaskDesc = ""
CollectionDay = ""
MultFlag = ""
TaskBins = 0
If Not IsNull(cwtnItemSet!task_ref) Then
TaskDesc = Trim$(cwtnItemSet!task_ref)
End If
If Not IsNull(cwtnItemSet!task_desc) Then
TaskDesc = Trim$(cwtnItemSet!task_desc)
End If
If Not IsNull(cwtnItemSet!collection_days) Then
CollectionDay = Trim$(cwtnItemSet!collection_days)
End If
If Not IsNull(cwtnItemSet!task_bins) Then
TaskBins = cwtnItemSet!task_bins
End If
If Not IsNull(cwtnItemSet!mult_flag) Then
MultFlag = Trim$(cwtnItemSet!mult_flag)
End If
Selection.TypeText TaskCode & " " & TaskDesc & vbTab & TaskBins & vbTab & CollectionDay & vbTab & MultFlag & vbCr & vbCr
WasteType = ""
WasteDesc = ""
If Not IsNull(cwtnSet!waste_type) Then
WasteType = Trim$(cwtnSet!waste_type)
End If
If Not IsNull(cwtnSet!waste_desc) Then
WasteDesc = Trim$(cwtnSet!waste_desc)
End If
Selection.Font.Bold = True
Selection.TypeText "Waste Description: "
Selection.Font.Bold = False
Selection.TypeText WasteType & " " & WasteDesc & vbCr
Selection.InlineShapes.AddHorizontalLineStandard
cwtnItemSet.MoveNext
Loop While Not cwtnItemSet.EOF
End If
If Not IsNull(cwtnSet!notes1) Then
Selection.TypeText cwtnSet!notes1 & vbCr
End If
If Not IsNull(cwtnSet!notes2) Then
Selection.TypeText cwtnSet!notes2
End If
AddReportFooter Db, cwtnSet, PageNo, NoOfPages
cwtnItemSet.Close
End Function
Code:
Function CheckNewPage(Db As Database, cwtnSet As Recordset, LinesNeeded As Integer, PageNo As Integer, NoOfPages As Integer)
If Selection.Information(wdFirstCharacterLineNumber) > G_PageLen - LinesNeeded Then
PageNo = PageNo + 1
Selection.InsertBreak wdPageBreak
AddPageHeader Db, cwtnSet, PageNo, NoOfPages
Selection.Font.Bold = True
Selection.TypeText vbCr & vbCr & "Collection Details: "
Selection.Font.Bold = False
Selection.TypeText cwtnSet!agree_name & vbCr
Selection.Font.Bold = False
Selection.InlineShapes.AddHorizontalLineStandard
End If
CheckNewPage = PageNo
End Function
Code:
Function AddPageHeader(Db As Database, cwtnSet As Recordset, PageNo As Integer, NoOfPages As Integer)
Dim cwtnTBox As Shape
Dim NewPic As Shape
Static FirstTime As Integer
If FirstTime = 0 Then
Set NewPic = ActiveDocument.Shapes.AddPicture _
( _
"logo.bmp", _
True, _
False, _
MillimetersToPoints(173.9), _
MillimetersToPoints(15.8), _
MillimetersToPoints(21.6), _
MillimetersToPoints(25.4) _
)
FirstTime = 1
NewPic.Name = "Logo"
NewPic.WrapFormat.Type = wdWrapNone
NewPic.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
NewPic.RelativeVerticalPosition = wdRelativeVerticalPositionPage
NewPic.Left = MillimetersToPoints(173.9)
NewPic.Top = MillimetersToPoints(15.8)
NewPic.Width = MillimetersToPoints(21.6)
NewPic.Height = MillimetersToPoints(25.4)
Else
Set NewPic = ActiveDocument.Shapes("Logo").Duplicate
NewPic.Left = MillimetersToPoints(173.9)
NewPic.Top = MillimetersToPoints(15.8)
NewPic.Width = MillimetersToPoints(21.6)
NewPic.Height = MillimetersToPoints(25.4)
NewPic.WrapFormat.Type = wdWrapNone
NewPic.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
NewPic.RelativeVerticalPosition = wdRelativeVerticalPositionPage
End If
Selection.EndOf Unit:=wdLine, Extend:=wdMove
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = True
Selection.TypeText "Duty Of Care: Controlled Waste Transfer Notice : " & cwtnSet!cwtn_no
Selection.Font.Bold = False
Selection.TypeText vbTab & " Issued : " & Format(Date, "dd/mm/yy") & " Page " & PageNo & " Of " & NoOfPages
AddCustomerBox Db, cwtnSet
ActiveDocument.Shapes.AddLine MillimetersToPoints(200), MillimetersToPoints(155), MillimetersToPoints(202), MillimetersToPoints(155)
End Function
Code:
Function AddPage1Header(Db As Database, cwtnSet As Recordset, NoOfPages As Integer)
Dim LineNo As Integer
Dim SigPic As Shape
Static FirstTime As Integer
AddPage1Header = True
AddPageHeader Db, cwtnSet, 1, NoOfPages
AddDelAddress Db, cwtnSet
AddCOWBox
If FirstTime = 0 Then
Set SigPic = ActiveDocument.Shapes.AddPicture _
( _
"sig.tif", _
True, _
False, _
MillimetersToPoints(124.7), _
MillimetersToPoints(77.7), _
MillimetersToPoints(47.6), _
MillimetersToPoints(17) _
)
SigPic.Name = "Sig"
SigPic.WrapFormat.Type = wdWrapNone
SigPic.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
SigPic.RelativeVerticalPosition = wdRelativeVerticalPositionPage
SigPic.Left = MillimetersToPoints(125.2)
SigPic.Top = MillimetersToPoints(77.7)
SigPic.Width = MillimetersToPoints(47.6)
SigPic.Height = MillimetersToPoints(17)
FirstTime = 1
Else
Set SigPic = ActiveDocument.Shapes("Sig").Duplicate
SigPic.Left = MillimetersToPoints(125.2)
SigPic.Top = MillimetersToPoints(77.7)
SigPic.Width = MillimetersToPoints(47.6)
SigPic.Height = MillimetersToPoints(17)
SigPic.WrapFormat.Type = wdWrapNone
SigPic.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
SigPic.RelativeVerticalPosition = wdRelativeVerticalPositionPage
End If
While Selection.Information(wdFirstCharacterLineNumber) <> 22
Selection.TypeText vbCr
Wend
AddSiteAddress Db, cwtnSet
End Function
Code:
Function AddSiteAddress(Db As Database, cwtnSet As Recordset)
Dim CollCount As Integer
Dim CollAddr(1 To 9) As String
Dim Index As Integer
Selection.Font.Bold = True
Selection.TypeText "Producer of Waste / Collection Site:" & vbCr
Selection.Font.Bold = False
Selection.InlineShapes.AddHorizontalLineStandard
CollCount = 0
If Not IsNull(cwtnSet!site_name) Then
CollCount = CollCount + 1
CollAddr(CollCount) = cwtnSet!site_name
End If
If Not IsNull(cwtnSet!site_addr_1) Then
CollCount = CollCount + 1
CollAddr(CollCount) = cwtnSet!site_addr_1
End If
If Not IsNull(cwtnSet!site_addr_2) Then
CollCount = CollCount + 1
CollAddr(CollCount) = cwtnSet!site_addr_2
End If
If Not IsNull(cwtnSet!site_addr_3) Then
CollCount = CollCount + 1
CollAddr(CollCount) = cwtnSet!site_addr_3
End If
If Not IsNull(cwtnSet!site_addr_4) Then
CollCount = CollCount + 1
CollAddr(CollCount) = cwtnSet!site_addr_4
End If
If Not IsNull(cwtnSet!site_addr_5) Then
CollCount = CollCount + 1
CollAddr(CollCount) = cwtnSet!site_addr_5
End If
If Not IsNull(cwtnSet!site_addr_6) Then
CollCount = CollCount + 1
CollAddr(CollCount) = cwtnSet!site_addr_6
End If
For Index = 1 To CollCount
Selection.TypeText CollAddr(Index) & vbCr
Next
Selection.Font.Bold = True
Selection.TypeText vbCr & "Collection Details: "
Selection.Font.Bold = False
Selection.TypeText cwtnSet!agree_name & vbCr
Selection.InlineShapes.AddHorizontalLineStandard
End Function
Code:
Function AddDelAddress(Db As Database, cwtnSet As Recordset)
Dim Addr(1 To 9) As String
Dim AddrCount As Integer
Dim Index As Integer
Dim cwtnDTBox As Shape
Dim Count As Integer
Selection.EndOf Unit:=wdLine, Extend:=wdMove
Set cwtnDTBox = ActiveDocument.Shapes.AddTextbox _
( _
msoTextOrientationHorizontal, _
MillimetersToPoints(13.7), _
MillimetersToPoints(50.6), _
MillimetersToPoints(106.8), _
MillimetersToPoints(55) _
)
cwtnDTBox.TextFrame.TextRange.Font.Name = "Arial"
cwtnDTBox.TextFrame.TextRange = "Delivery Address:"
AddrCount = 0
If Not IsNull(cwtnSet!send_to_name_1) Then
AddrCount = AddrCount + 1
Addr(AddrCount) = cwtnSet!send_to_name_1
End If
If Not IsNull(cwtnSet!send_to_name_2) Then
AddrCount = AddrCount + 1
Addr(AddrCount) = cwtnSet!send_to_name_2
End If
If Not IsNull(cwtnSet!send_to_addr_1) Then
AddrCount = AddrCount + 1
Addr(AddrCount) = cwtnSet!send_to_addr_1
End If
If Not IsNull(cwtnSet!send_to_addr_2) Then
AddrCount = AddrCount + 1
Addr(AddrCount) = cwtnSet!send_to_addr_2
End If
If Not IsNull(cwtnSet!send_to_addr_3) Then
AddrCount = AddrCount + 1
Addr(AddrCount) = cwtnSet!send_to_addr_3
End If
If Not IsNull(cwtnSet!send_to_addr_4) Then
AddrCount = AddrCount + 1
Addr(AddrCount) = cwtnSet!send_to_addr_4
End If
If Not IsNull(cwtnSet!send_to_addr_5) Then
AddrCount = AddrCount + 1
Addr(AddrCount) = cwtnSet!send_to_addr_5
End If
If Not IsNull(cwtnSet!send_to_addr_6) Then
AddrCount = AddrCount + 1
Addr(AddrCount) = cwtnSet!send_to_addr_6
End If
For Index = 1 To AddrCount
cwtnDTBox.TextFrame.TextRange.InsertAfter (vbCr & Addr(Index))
Next
cwtnDTBox.TextFrame.TextRange.Font.Size = 10
For Count = 1 To 17
cwtnDTBox.TextFrame.TextRange.Characters(Count).Bold = True
cwtnDTBox.TextFrame.TextRange.Characters(Count).Font.Size = 9
Next
End Function
Code:
Function AddCustomerBox(Db As Database, cwtnSet As Recordset)
Dim Addr(1 To 7) As String
Dim AddrCount As Integer
Dim Index As Integer
Dim cwtnTBox As Shape
Dim Count As Integer
Selection.InlineShapes.AddHorizontalLineStandard
Selection.Font.Bold = True
Selection.TypeText "Customer: "
Selection.Font.Bold = False
If Not IsNull(cwtnSet!dbtr_name) Then
Selection.TypeText cwtnSet!dbtr_name
End If
If Not IsNull(cwtnSet!dbtr_addr1) Then
AddrCount = AddrCount + 1
Addr(AddrCount) = cwtnSet!dbtr_addr1
End If
If Not IsNull(cwtnSet!dbtr_addr2) Then
AddrCount = AddrCount + 1
Addr(AddrCount) = cwtnSet!dbtr_addr2
End If
If Not IsNull(cwtnSet!dbtr_addr3) Then
AddrCount = AddrCount + 1
Addr(AddrCount) = cwtnSet!dbtr_addr3
End If
If Not IsNull(cwtnSet!dbtr_addr4) Then
AddrCount = AddrCount + 1
Addr(AddrCount) = cwtnSet!dbtr_addr4
End If
If Not IsNull(cwtnSet!dbtr_addr5) Then
AddrCount = AddrCount + 1
Addr(AddrCount) = cwtnSet!dbtr_addr5
End If
If Not IsNull(cwtnSet!dbtr_addr6) Then
AddrCount = AddrCount + 1
Addr(AddrCount) = cwtnSet!dbtr_addr6
End If
For Index = 1 To AddrCount
Selection.TypeText vbCr & Addr(Index)
Next
End Function
Code:
Function AddCOWBox()
Dim cwtnTBox As Shape
Dim Count As Integer
Set cwtnTBox = ActiveDocument.Shapes.AddTextbox _
( _
msoTextOrientationHorizontal, _
MillimetersToPoints(122.5), _
MillimetersToPoints(50.6), _
MillimetersToPoints(79.8), _
MillimetersToPoints(55) _
)
cwtnTBox.TextFrame.TextRange.Font.Name = "Arial"
cwtnTBox.TextFrame.TextRange.Font.Size = 10
cwtnTBox.TextFrame.TextRange = "Collector of Waste: Cambridge City Council" & _
" by virtue of this notice is a waste collection authority and exempt from" & _
" registering as a waste carrier. (By virtue of para 3.5 " & Chr$(34) & _
"The Duty of Care, A code of Practice" & Chr$(34) & ") Exemption number" & _
": cam/e/c/cam023" & vbCr & vbCr & vbCr & _
" Michael Parsons" & vbCr & vbCr & vbCr & _
"Representing Cambridge City Council" & vbCr & _
"The Guildhall, Cambridge, CB2 3QJ"
For Count = 1 To 19
cwtnTBox.TextFrame.TextRange.Characters(Count).Bold = True
Next
End Function