0

hi my name is vishal. i have been trying long to figure out to export data from vb6 using join queries in sql to ms word.
here is my sample code i have tried:

Option Explicit
Dim dIsVisible As Boolean
Dim inst As String
Private Declare Function ShellExecute Lib "shell32.dll" Alias _

      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 Su**b


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
FileCopy "D:\Workarea\vishal\Project\DCS Clinical Report.dotx", App.Path & "\report11.docx"
Set oDoc = oWord.Documents.Add
Set oDoc = oWord.Documents.Open(App.Path & "\report11.docx")
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).Type
    oDoc.Tables(1).Columns(4).Cells(i + 1).Range.Text = Format(rs.Fields(5).Value, "hh:mm:ss")
    oDoc.Tables(1).Columns(5).Cells(i + 1).Range.Text = 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
    oDoc.Tables(1).Columns(6).Cells(i + 1).Range.Text = "0" & Left(minL / 60, 1) & ":" & IIf(Len(CStr(minL Mod 60)) = 2, (minL Mod 60), (minL Mod 60) & "0")
       Else
    oDoc.Tables(1).Columns(6).Cells(i + 1).Range.Text = "00:" & IIf(Len(CStr(minL Mod 60)) = 2, (minL Mod 60), (minL Mod 60) & "0")
       End If
    oDoc.Tables(1).Columns(7).Cells(i + 1).Range.Text = rs.Fields(7).Value
    oDoc.Tables(1).Columns(8).Cells(i + 1).Range.Text = rs.Fields(8).Value
    oDoc.Tables(1).Columns(9).Cells(i + 1).Range.Text = rs.Fields(9).Value
    oDoc.Tables(1).Columns(10).Cells(i + 1).Range.Text = rs.Fields(10).Value
    oDoc.Tables(1).Columns(10).Cells(i + 1).Range.Text = rs.Fields(11).Value
    rs.MoveNext
    i = i + 1
    Loop

    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

But every time i execute it i get run-time error'6102' saying"Word encountered error processing xml file report11.no detail available". i feel i am going to get mad solving this problem.Can anyone help me on how to solve this problem so i can access my word document to see what really had happened.Any help would be appreciated.

End Function
Bold Text Here

2
Contributors
1
Reply
13
Views
3 Years
Discussion Span
Last Post by rishif2
0

"D:\Workarea\vishal\Project\DCS Clinical Report.dotx", App.Path & "\report11.docx"

is that correct file name ?

did you add proper references before going to access word file.?

This topic has been dead for over six months. Start a new discussion instead.
Have something to contribute to this discussion? Please be thoughtful, detailed and courteous, and be sure to adhere to our posting rules.