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.