Transfering vb6 data to ms word with adodb

vishal anand.s 0 Newbie Poster

10 Years Ago

hi my name is vishal. I am learning how to transfer vb6 to table in ms Word using adodb. I have done word template named DCS Clinical Report which contains table of 10 columns and 13 rows. I am able to export it as a template but i am unable to fill in the cells in the table in ms word. I have done it exporting vb6 data to ms Excel. But i think there is more to exporting vb6 data to ms Word than to ms Excel(No offense) this is for my project only.i have done code in exporting vb6 data to Ms Excel using adodb.

Option Explicit
Dim dIsVisible As Boolean
Dim inst As String
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
      "ShellExecuteA" (ByVal hwnd As Long, ByVal lpszOp As _
      String, ByVal lpszFile As String, ByVal lpszParams As String, _
      ByVal lpszDir As String, ByVal FsShowCmd As Long) As Long

      Private Declare Function GetDesktopWindow Lib "user32" () As Long

      Const SW_SHOWNORMAL = 1

      Const SE_ERR_FNF = 2&
      Const SE_ERR_PNF = 3&
      Const SE_ERR_ACCESSDENIED = 5&
      Const SE_ERR_OOM = 8&
      Const SE_ERR_DLLNOTFOUND = 32&
      Const SE_ERR_SHARE = 26&
      Const SE_ERR_ASSOCINCOMPLETE = 27&
      Const SE_ERR_DDETIMEOUT = 28&
      Const SE_ERR_DDEFAIL = 29&
      Const SE_ERR_DDEBUSY = 30&
      Const SE_ERR_NOASSOC = 31&
      Const ERROR_BAD_FORMAT = 11&



Sub getDialyzerInfo()
    Me.Caption = "Dialyzer Info"
    fmeDialyzerID.Visible = True
    fmePatientwise.Visible = False
    dIsVisible = True
End Sub

Private Sub cmdGenerate_Click()
Dim rs As New ADODB.Recordset
 Dim xlApp As Excel.Application
    Dim wb As Workbook
    Dim ws As Excel.Worksheet
    Dim var As Variant


    Set xlApp = New Excel.Application

    FileCopy "D:\Workarea\vishal\Project\Dialyzer9.xls.xlsx", App.Path & "\report6.xls"

    Set wb = xlApp.Workbooks.Open(App.Path & "\report6.xls")
    Set ws = wb.Worksheets("Sheet1") 'Specify your worksheet name
    'Set ws = wb.Worksheets.Add()
    If (dIsVisible = True) Then
        If (Trim(Text1.Text) <> "") Then
            Set rs = adoDatabase.Execute("select r.dialysis_date,pn.patient_first_name,pn.patient_last_name, d.manufacturer,d.dialyzer_size,r.start_date,r.end_date,d.packed_volume,r.bundle_vol,r.disinfectant,t.technician_first_name,t.technician_last_name from dialyser d,patient_name pn, reprocessor r, techniciandetail t where pn.patient_id=d.patient_id and r.dialyzer_id=d.dialyserID and t.technician_id=r.technician_id and d.deleted_status=false and pn.status=true and d.dialyserID='" & Text1.Text & "' order by r.dialysis_date desc,pn.patient_first_name,pn.patient_last_name", "DCS Clinical Report - For Dialyzer ID(" & Text1.Text & ")")
        End If
    Else
        If cboPatientID.ListIndex = 0 Then
            Set rs = adoDatabase.Execute("select r.dialysis_date,pn.patient_first_name,pn.patient_last_name, d.manufacturer,d.dialyzer_size,r.start_date,r.end_date,d.packed_volume,r.bundle_vol,r.disinfectant,t.technician_first_name,t.technician_last_name from dialyser d,patient_name pn, reprocessor r, techniciandetail t where pn.patient_id=d.patient_id and r.dialyzer_id=d.dialyserID and r.dialysis_date between cdate('" & dtFrom.Value & "') and cdate('" & dtTo.Value & "') and t.technician_id=r.technician_id and d.deleted_status=false and pn.status=true order by r.dialysis_date desc,pn.patient_first_name,pn.patient_last_name", "DCS Clinical Report - Patient wise")

        Else
            Set rs = adoDatabase.Execute("select r.dialysis_date,pn.patient_first_name,pn.patient_last_name, d.manufacturer,d.dialyzer_size,r.start_date,r.end_date,d.packed_volume,r.bundle_vol,r.disinfectant,t.technician_first_name,t.technician_last_name from dialyser d,patient_name pn, reprocessor r, techniciandetail t where pn.patient_id=d.patient_id and r.dialyzer_id=d.dialyserID and r.dialysis_date between cdate('" & dtFrom.Value & "') and cdate('" & dtTo.Value & "') and d.patient_id=" & Left(cboPatientID.List(cboPatientID.ListIndex), InStr(cboPatientID.List(cboPatientID.ListIndex), "|") - 1) & " and t.technician_id=r.technician_id and d.deleted_status=false and pn.status=true order by r.dialysis_date desc,pn.patient_first_name,pn.patient_last_name", "DCS Clinical Report - Patient wise")
        End If
    End If
    If rs.EOF = True Then
    MsgBox "There is no datas for for this patient-DCS Clinical Report", vbInformation
    Exit Sub
    End If
    Dim j As Long
    j = 6
    Do While Not rs.EOF
        ws.Select
       ws.Cells(j + 1, 1) = rs.Fields(0).Value
       ws.Cells(j + 1, 2) = rs.Fields(1).Value
       ws.Cells(j + 1, 3) = rs.Fields(2).Value
       ws.Cells(j + 1, 4) = rs.Fields(3).Value
       ws.Cells(j + 1, 5) = rs.Fields(4).Value
       ws.Cells(j + 1, 6) = Format(rs.Fields(5).Value, "hh:mm:ss")
       ws.Cells(j + 1, 7) = Format(rs.Fields(6).Value, "hh:mm:ss")
       Dim minL As Long
       minL = DateDiff("n", CDate(rs.Fields(5).Value), CDate(rs.Fields(6).Value))
       If (minL >= 60) Then
       ws.Cells(j + 1, 8) = "0" & Left(minL / 60, 1) & ":" & IIf(Len(CStr(minL Mod 60)) = 2, (minL Mod 60), (minL Mod 60) & "0")
       Else
       ws.Cells(j + 1, 8) = "00:" & IIf(Len(CStr(minL Mod 60)) = 2, (minL Mod 60), (minL Mod 60) & "0")
       End If
       ws.Cells(j + 1, 9) = rs.Fields(7).Value
       ws.Cells(j + 1, 10) = rs.Fields(8).Value
       ws.Cells(j + 1, 11) = rs.Fields(9).Value
       ws.Cells(j + 1, 12) = rs.Fields(10).Value
       ws.Cells(j + 1, 13) = rs.Fields(11).Value
       rs.MoveNext
       j = j + 1
       Loop
       On Error Resume Next
    wb.SaveAs App.Path & "\report_result6.xls"

    'Closing the excel application

    wb.Close

    xlApp.Quit

    Set ws = Nothing
    Set wb = Nothing
    Set xlApp = Nothing

DoEvents
    Dim r As Long, msg As String
    r = StartDoc(App.Path & "\report_result6.xls")
    If r <= 32 Then
        'There was an error
        Select Case r
            Case SE_ERR_FNF
                msg = "File not found"
            Case SE_ERR_PNF
                msg = "Path not found"
            Case SE_ERR_ACCESSDENIED
                msg = "Access denied"
            Case SE_ERR_OOM
                msg = "Out of memory"
            Case SE_ERR_DLLNOTFOUND
                msg = "DLL not found"
            Case SE_ERR_SHARE
                msg = "A sharing violation occurred"
            Case SE_ERR_ASSOCINCOMPLETE
                msg = "Incomplete or invalid file association"
            Case SE_ERR_DDETIMEOUT
                msg = "DDE Time out"
            Case SE_ERR_DDEFAIL
                msg = "DDE transaction failed"
            Case SE_ERR_DDEBUSY
                msg = "DDE busy"
            Case SE_ERR_NOASSOC
                msg = "No association for file extension"
            Case ERROR_BAD_FORMAT
                msg = "Invalid EXE file or error in EXE image"
            Case Else
                msg = "Unknown error"
        End Select
        MsgBox msg
    End If
    Exit Sub
    End Sub
    Function StartDoc(DocName As String) As Long
    On Error GoTo errH
    Dim Scr_hDC As Long
    Scr_hDC = GetDesktopWindow()
    StartDoc = ShellExecute(Scr_hDC, "Open", DocName, _
    "", "C:\", SW_SHOWNORMAL)
    Exit Function
errH:
    MsgBox Err.Description, vbCritical
End Function



Private Sub Command2_Click()
    Unload Me
End Sub

Private Sub dtFrom_Change()
    dtTo.MinDate = dtFrom.Value
End Sub


Private Sub dtTo_Change()
    dtFrom.MaxDate = dtTo.Value
End Sub


Private Sub Form_Load()
    Me.Icon = MDIForm1.Icon
    dtTo.MaxDate = Now
    dtTo.Value = Now
    dtFrom.MaxDate = Now
    dtFrom.Value = Now
    loadPatientID
End Sub


Private Sub loadPatientID()
    On Error GoTo errH
    Dim vSQLStr As String
    vSQLStr = "select p.patient_id as patient_id,n.patient_first_name as patient_fname, n.patient_last_name as patient_lname from patient_name n,patient_id p where n.patient_id=p.patient_id and n.status = true and p.patient_id in (select patient_id from dialyser where deleted_status=false and closed_status=false);"
    Dim oRS As New ADODB.Recordset
    If (adoDatabase.State = 0) Then
        adoDatabase.Open
    End If
    oRS.Open vSQLStr, adoDatabase, adOpenForwardOnly, adLockReadOnly

    cboPatientID.clear
    cboPatientID.AddItem "[ALL]"
    Do While Not oRS.EOF
         '// Do something with the data'
         cboPatientID.AddItem oRS.Fields("patient_id").Value & "|" & oRS.Fields("patient_fname").Value & " " & oRS.Fields("patient_lname").Value
         oRS.MoveNext
    Loop
    cboPatientID.ListIndex = 0
    oRS.Close
    Exit Sub
errH:
Resume
    MsgBox Err.Description, vbCritical
End Sub


Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    On Error Resume Next
    MSComm1.PortOpen = False ' Close the comm port
End Sub

Private Sub Timer1_Timer()
    On Error GoTo errH
    If MSComm1.PortOpen = False Then ' If comm port is not open
       MSComm1.PortOpen = True ' Open it
    End If

    If MSComm1.InBufferCount > 0 Then ' If theres data in comm buffer
        inst = inst + MSComm1.Input ' Get the data
        Text1 = inst ' Show its value
    End If
errH:
End Sub

I have used the above code as a model to export vb6 data to Ms Word using adodb with little success. I browsed to net to fix the problem with no success.Given below is code of how i used to export vb6 data to Ms Word using adodb:

Option Explicit
Dim dIsVisible As Boolean
Dim inst As String
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
      "ShellExecuteA" (ByVal hwnd As Long, ByVal lpszOp As _
      String, ByVal lpszFile As String, ByVal lpszParams As String, _
      ByVal lpszDir As String, ByVal FsShowCmd As Long) As Long

      Private Declare Function GetDesktopWindow Lib "user32" () As Long

      Const SW_SHOWNORMAL = 1

      Const SE_ERR_FNF = 2&
      Const SE_ERR_PNF = 3&
      Const SE_ERR_ACCESSDENIED = 5&
      Const SE_ERR_OOM = 8&
      Const SE_ERR_DLLNOTFOUND = 32&
      Const SE_ERR_SHARE = 26&
      Const SE_ERR_ASSOCINCOMPLETE = 27&
      Const SE_ERR_DDETIMEOUT = 28&
      Const SE_ERR_DDEFAIL = 29&
      Const SE_ERR_DDEBUSY = 30&
      Const SE_ERR_NOASSOC = 31&
      Const ERROR_BAD_FORMAT = 11&
      Sub getDialyzerInfo()
    Me.Caption = "Dialyzer Info"
    fmeDialyzerID.Visible = True
    fmePatientwise.Visible = False
    dIsVisible = True
End Sub


Private Sub cmdGenerate_Click()
Dim rs As New ADODB.Recordset
Dim oWord As Word.Application
Dim oDoc As Word.Document
Dim oRange As Word.Range
Dim oTable As Word.Table


Set oWord = New Word.Application
oWord.Visible = True
Set oDoc = oWord.Documents.Open("D:\Workarea\vishal\Project\DCS Clinical Report.dotx")
Set oTable = oDoc.Tables.Add(oDoc.Range(0, 0), 12, 10)

If (dIsVisible = True) Then
        If (Trim(Text1.Text) <> "") Then
            Set rs = adoDatabase.Execute("select r.dialysis_date,pn.patient_first_name,pn.patient_last_name, d.manufacturer,d.dialyzer_size,r.start_date,r.end_date,d.packed_volume,r.bundle_vol,r.disinfectant,t.technician_first_name,t.technician_last_name from dialyser d,patient_name pn, reprocessor r, techniciandetail t where pn.patient_id=d.patient_id and r.dialyzer_id=d.dialyserID and t.technician_id=r.technician_id and d.deleted_status=false and pn.status=true and d.dialyserID='" & Text1.Text & "' order by r.dialysis_date desc,pn.patient_first_name,pn.patient_last_name", "DCS Clinical Report - For Dialyzer ID(" & Text1.Text & ")")
        End If
    Else
        If cboPatientID.ListIndex = 0 Then
            Set rs = adoDatabase.Execute("select r.dialysis_date,pn.patient_first_name,pn.patient_last_name, d.manufacturer,d.dialyzer_size,r.start_date,r.end_date,d.packed_volume,r.bundle_vol,r.disinfectant,t.technician_first_name,t.technician_last_name from dialyser d,patient_name pn, reprocessor r, techniciandetail t where pn.patient_id=d.patient_id and r.dialyzer_id=d.dialyserID and r.dialysis_date between cdate('" & dtFrom.Value & "') and cdate('" & dtTo.Value & "') and t.technician_id=r.technician_id and d.deleted_status=false and pn.status=true order by r.dialysis_date desc,pn.patient_first_name,pn.patient_last_name", "DCS Clinical Report - Patient wise")

        Else
            Set rs = adoDatabase.Execute("select r.dialysis_date,pn.patient_first_name,pn.patient_last_name, d.manufacturer,d.dialyzer_size,r.start_date,r.end_date,d.packed_volume,r.bundle_vol,r.disinfectant,t.technician_first_name,t.technician_last_name from dialyser d,patient_name pn, reprocessor r, techniciandetail t where pn.patient_id=d.patient_id and r.dialyzer_id=d.dialyserID and r.dialysis_date between cdate('" & dtFrom.Value & "') and cdate('" & dtTo.Value & "') and d.patient_id=" & Left(cboPatientID.List(cboPatientID.ListIndex), InStr(cboPatientID.List(cboPatientID.ListIndex), "|") - 1) & " and t.technician_id=r.technician_id and d.deleted_status=false and pn.status=true order by r.dialysis_date desc,pn.patient_first_name,pn.patient_last_name", "DCS Clinical Report - Patient wise")
        End If
    End If
    If rs.EOF = True Then
    MsgBox "There is no datas for for this patient-DCS Clinical Report", vbInformation
    Exit Sub
    End If
    Dim i As Long
    i = 1
    Do Until rs.EOF
    oDoc.Tables(1).Columns(1).Cells.Add
    oDoc.Tables(1).Columns(1).Cells(i + 1).Range.Text = rs.Fields(0).Value
    oDoc.Tables(1).Columns(2).Cells(i + 1).Range.Text = rs.Fields(1).Value
    oDoc.Tables(1).Columns(2).Cells(i + 1).Range.Text = rs.Fields(2).Value
    oDoc.Tables(1).Columns(3).Cells(i + 1).Range.Text = rs.Fields(3).Value
    oDoc.Tables(1).Columns(3).Cells(i + 1).Range.Text = rs.Fields(4).Value
    rs.MoveNext
    i = i + 1
    Loop
    oDoc.Activate

    On Error Resume Next
    oDoc.SaveAs2 App.Path & "\report_result9.docx"
    oWord.Visible = True
    oDoc.Close
    oWord.Quit
    Set oDoc = Nothing
    Set oWord = Nothing

    DoEvents
    Dim r As Long, msg As String
    r = StartDoc(App.Path & "\report_result9.docx")
    If r <= 32 Then
        'There was an error
        Select Case r
            Case SE_ERR_FNF
                msg = "File not found"
            Case SE_ERR_PNF
                msg = "Path not found"
            Case SE_ERR_ACCESSDENIED
                msg = "Access denied"
            Case SE_ERR_OOM
                msg = "Out of memory"
            Case SE_ERR_DLLNOTFOUND
                msg = "DLL not found"
            Case SE_ERR_SHARE
                msg = "A sharing violation occurred"
            Case SE_ERR_ASSOCINCOMPLETE
                msg = "Incomplete or invalid file association"
            Case SE_ERR_DDETIMEOUT
                msg = "DDE Time out"
            Case SE_ERR_DDEFAIL
                msg = "DDE transaction failed"
            Case SE_ERR_DDEBUSY
                msg = "DDE busy"
            Case SE_ERR_NOASSOC
                msg = "No association for file extension"
            Case ERROR_BAD_FORMAT
                msg = "Invalid EXE file or error in EXE image"
            Case Else
                msg = "Unknown error"
        End Select
        MsgBox msg
    End If
    Exit Sub
    End Sub
    Function StartDoc(DocName As String) As Long
    On Error GoTo errH
    Dim Scr_hDC As Long
    Scr_hDC = GetDesktopWindow()
    StartDoc = ShellExecute(Scr_hDC, "Open", DocName, _
    "", "C:\", SW_SHOWNORMAL)
    Exit Function
errH:
    MsgBox Err.Description, vbCritical
End Function





Private Sub Command2_Click()
Unload Me
End Sub

i think i getting error in this line below saying Invalid procedure call or argument.
Set rs = adoDatabase.Execute("select r.dialysis_date,pn.patient_first_name,pn.patient_last_name, d.manufacturer,d.dialyzer_size,r.start_date,r.end_date,d.packed_volume,r.bundle_vol,r.disinfectant,t.technician_first_name,t.technician_last_name from dialyser d,patient_name pn, reprocessor r, techniciandetail t where pn.patient_id=d.patient_id and r.dialyzer_id=d.dialyserID and r.dialysis_date between cdate('" & dtFrom.Value & "') and cdate('" & dtTo.Value & "') and d.patient_id=" & Left(cboPatientID.List(cboPatientID.ListIndex), InStr(cboPatientID.List(cboPatientID.ListIndex), "|") - 1) & " and t.technician_id=r.technician_id and d.deleted_status=false and pn.status=true order by r.dialysis_date desc,pn.patient_first_name,pn.patient_last_name", "DCS Clinical Report - Patient wise")
Can anyone help me where i am going wrong or what needs to be done. Any help or guidance would be greatly appreciated.

visual-basic

1 Contributor
0 Replies
140 Views

Be the first to reply

Be a part of the DaniWeb community

We're a friendly, industry-focused community of developers, IT pros, digital marketers, and technology enthusiasts meeting, networking, learning, and sharing knowledge.