Converting VBA code to ADO

Remster · #1 02-13-2015, 07:39 AM

Hi Folks

I've been asked to debug some VBA code from a macro in a Word document that no longer works now we've moved to Office 2010. I'm told I need to convert the code to ADO. I'm unsure what this means and I'm a little bit out of my depth. Can anyone help me with this please? Here's the code:

Code:

Sub DutyOfCare2()
 
    Dim Db As Database
    Dim WkSpace As Workspace
 
    Documents.Add Template:="cwtn.dot"
    ActiveDocument.PageSetup.HeaderDistance = 0
 
    On Error Resume Next
    Application.StatusBar = "Opening Database"
    Set WkSpace = CreateWorkspace("Contender", "", "", dbUseODBC)
    Set Db = WkSpace.OpenDatabase("Contender", dbDriverComplete, False, "ODBC;DATABASE=/usr/username/v7/databases/live/username;...;...;DSN=Contender")
 
    If BuildDutyOfCareReps(Db) Then
        Dialogs(wdDialogFilePrint).Show
 
    End If
 
    Db.Close
 
    Application.StatusBar = "Ready"
 
    ActiveDocument.Saved = True
 
End Sub

Thanks

Remster

Guessed · #2 02-13-2015, 07:15 PM

The database connection is being passed to a function called BuildDutyOfCareReps so changing to an ADO connection might require changes to that function as well. Can you post that code as well?

PS. It is not a good idea to post your database username and password on a public forum. You should change that text to protect your data.

Remster · #3 02-19-2015, 03:04 AM

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

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Converting Q and A to database	jscgdunn	Word	1	04-11-2014 05:29 PM
converting mm.s format to mm:ss	derohanes	Excel	12	10-30-2012 08:34 AM
Converting hh:mm to hours	Sammael	Excel	2	04-17-2012 01:33 PM
Error converting to PDF	danx1000	Word	1	04-03-2012 04:58 PM
Converting ACT to Outlook	tabletop	Office	1	01-26-2012 09:39 PM