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