A simple MDB table output to the Word VB applet, including simple queries, sorting, and packet functions. Welcome to exchange CWXIAO888@163.com
Option ExplicitDim DataType (100) As IntegerDim SqlString As StringDim OrderStr As StringDim TalNaStr As StringDim i As IntegerDim MacroName As StringPrivate WordApp As Word.ApplicationPrivate doc As Word.DocumentPrivate se1 As Word.SelectionPrivate db As DatabasePrivate rs As Recordset
Private Sub CmdQuery_Click () 'On Error Resume NextTalNaStr = Data1.Caption'queryprintfrm.Data1.DatabaseName = datalistfrm.Text1.Text'queryprintfrm.Data1.RecordSource = datalistfrm.Combo1.Text'queryprintfrm.Data1.DatabaseName = datalistfrm.Text1.Textqueryprintfrm .DATA1.Recordsource = Datalistfrm.combo1.text
QueryPrintFrm.Data1.refresh
If me.exp1.text = "like" TENORDERSTR = FINDFIELD.TEXTQUERYPRINTFRM.DATA1.Recordsource = "SELECT *" " Talnastr " " " Where " " " me.findfield.text " " "Like" "" "'" "" "" "ORDER BY" "" ORDERSTRME.DATA1.REFRESHME.DBGRID1.REFRESHME.REFRESHEND IF
If me.exp1.text = "in" THENORDERSTR = FINDFIELD.TEXTQUERYPRINTFRM.DATA1.Recordsource = "SELECT *" " TalNastr " " " Where " " " me.fieldfield.text " " "IN" "" "(" "" ")" "" " " " " ORDER BY " " ORDERSTRME.DATA1.Refreshme.dbGrid1.Refreshme. RefreshEnd IfOn Error Resume NextSelect Case Data1.Recordset.Fields (ComFind.ListIndex) .TypeCase 1, 4, 5SqlString = "select * from" TalNaStr "where" FindField.Text "" Exp1.Text "" Range1.textcase 10sqlstring = "Select * from" Talnastr " Findfield.Text " " " " " " RANGE1.TEXT " "Case 8Sqlstring =" Select * from " Talnastr "Where" findfield.text exp1.text "cdate (" "" RANGE1.TEXT ")" "End SelectRDERST = Findfield.TextQueryData Sqlstring, Orderstr
End Sub
Private sub combo1_click () on error resume nexttalnastr = data1.captionData1.recordsource = "SELECT" "" " " "" "" "" "" "GROUP BY" "" " Combo1.Text'Data1.RecordSource = "select * from order by name" Data1.RefreshDBGrid1.RefreshData1.Recordset.MoveLastMe.Label8.Caption = Me.Data1.Recordset.RecordCountMe.RefreshEnd SubPrivate Sub ComFind_Click () FindField.Text = ComFind. TextRange1.text = "" COMSORT.TEXT = COMFIND.TEXTME.REFRESHEND SUB
Private Sub Command1_Click () On Error Resume Next For i = 0 To List1.ListCount - 1 Step 1 If List1.Selected (i) Then List2.AddItem List1.Text List1.RemoveItem (List1.ListIndex) Exit Sub End If Next List1. SetFocus List1.text = list1.list (0) if list1.list (0) = "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" ""
Private Sub Command10_Click () DIM SFILE AS STRING WITH DLGCOMMONDIALOG .DIALOGTILE = "Open Database File" .cancelerror = false 'Todo: Sets the flag and properties of the CommON Dialog control. Filter = "All Database Files * .mdb | * .mdb |" .Showopen if len (.filename) = 0 THEN EXIT SUB end if sfile = .filename data1.caption = .filetitle end with 'data1.database = label3.caption
Data1.DatabaseName = sfile 'data1.recordsource =' on error resume next data1.refresh 'form1.msflexGrid1.refresh form1.dbgrid1.refresh form1.refreshend SubPrivate Sub Command2_click ()
'Set db = openDatabase (DATALISTFRM.TEXT1.TEXT)' SET RS = DB.OpenRecordset (DatalistFrm.comBo1.text) SET DB = Data1.DatabaseSet RS = Data1.RecordSetData1.Refresh
SET WORDAPP = New Word.ApplicationWordApp.documents.addset Doc = Wordapp.ActiveDocumentSet Se1 = Wordapp.Serection
With doc.PageSetup .LineNumbering.Active = False .Orientation = wdOrientLandscape .TopMargin = CentimetersToPoints (2) .BottomMargin = CentimetersToPoints (2) .LeftMargin = CentimetersToPoints (2) .RightMargin = CentimetersToPoints (2) .Gutter = CentimetersToPoints (0). HeaderDistance = CentimetersToPoints (1.5) .FooterDistance = CentimetersToPoints (1.75) .PageWidth = CentimetersToPoints (29.7) .PageHeight = CentimetersToPoints (21) .FirstPageTray = wdPrinterDefaultBin .OtherPagesTray = wdPrinterDefaultBin .SectionStart = wdSectionNewPage .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .VerticalAlignment = WDALIGNVERTICALTOP .SUPPRESSENDNOTES = false .mirrorMargins = false .twopagesonone = false .gutterpos = wdgutterposleft .la youtMode = wdLayoutModeLineGrid End With se1.TypeText Text: = "20" & CStr (Date) & "" & CStr (Time ()) If List2.ListCount = 0 Then Call Command6_ClickEnd Ifdoc.Tables.Add Range: = se1.Range, Numrows: = 1, NumColumns: = list2.listcount for i = 0 to list2.listcount - 1screen.mousepointer = 11'se1.typetext text: = rs.fields (i) .namese1.typetext text: = list2.list (i ) se1.moveright unit: = 12Next
'se1.typetext text: = "Product Name"' Se1.Moveright Unit: = 12
Do Until Rs.eof for i = 0 to list2.listcount - 1 on error resume next 'se1.typetext text: = rs.fields (i) .Value se1.typetext text: = rs.fields (i) ) .Value se1.moveright unit: = 12 Next'se1.typetext text: = rs! Product Name 'se1.moveright unit: = 12'se1.typetext text: = rs! Medicinal' se1.moveright unit: = 12
rs.MoveNext LoopWordApp.Run MacroName: = "AutoFitContent" se1.InsertBreak se1.Delete Count: = List2.ListCount se1.Sections (1) .Footers (1) .PageNumbers.Add PageNumberAlignment: = _ wdAlignPageNumberRight, FirstPage: = True WordApp .Visible = true 'wordapp.run macroname: = "insertdatetime" set wordapp = NothingScreen.MousePointer = 1
End Sub
Private Sub Command3_Click () 'CrystalReport1.end Sub
Private sub fascist4_click () unload queryprintfrmend sub
Private sub fascist5_click () endend sub
Private submmand6_click () for i = 0 to list1.listcount - 1 step 1 list2.additem list1.list (i) Next List1.clear List2.set2.list (0) End Sub
Private Sub Command7_Click () On Error Resume Next For i = 0 To List2.ListCount - 1 Step 1 If List2.Selected (i) Then List1.AddItem List2.Text List2.RemoveItem (List2.ListIndex) Exit Sub End If Next List2. SetFocus List2.text = list2.list (0) if list2.list (0) = "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "" "
End Sub
Private sub fascist8_click () for i = 0 to list2.listcount - 1 step 1 list1.additem list2.list (i) Next list1.text = list1.list (0) end subircivate submman_click () ON Error Resume next'on error Goto Errlist: 'Errlist:' if msgbox ("No selected field or selected field is not required, please re-select the field and browse!", Vbokonly) = Vbok Ten exit subdi.. ListCount <> 0 THEN for i = 0 to list2.listcount - 1 Step 1 IF (i <> list2.listcount - 1) Then ListStr = ListStr List2.List (i) "," Else ListStr = ListStr List2. List (i) end if next end if me.data1.recordsource = "SELECT" "" " " " " from " " data1.caption me.data1.refresh me.dbgrid1.refresh Me.Refresh
End Sub
Private subrster_click () OrderStr = Comsort.TextQueryData Sqlstring, OrderStrend Sub
Function QueryData (ByVal SqlString As String, ByVal OrderStr As String) As StringOn Error Resume NextSqlString = SqlString "order by" "" OrderStrData1.RecordSource = SqlString'Data1.RecordSource = "select * from order by name" Data1.RefreshDBGrid1 .Refreshme.refreshend function
Private Sub Form_Load () on Error ResMe next
queryprintfrm.Data1.DatabaseName = datalistfrm.Text1.Textqueryprintfrm.Data1.RecordSource = datalistfrm.Combo1.Textqueryprintfrm.Caption = datalistfrm.Combo1.Textqueryprintfrm.Data1.Refresh'Me.Data1.RecordSource = datalistfrm.Combo1.Text'Me.Caption = datalistfrm.Combo1.Text'Me.Data1.RefreshFor i = 0 To Data1.Recordset.Fields.Count - 1 Step 1queryprintfrm.ComFind.AddItem Data1.Recordset.Fields (i) .Namequeryprintfrm.ComSort.AddItem Data1.Recordset.Fields ( i) .NameMe.List1.AddItem Data1.Recordset.Fields (i) .Name'Me.List2.AddItem Data1.Recordset.Fields (i) .NameMe.Combo1.AddItem Data1.Recordset.Fields (i) .NameNextqueryprintfrm.RefreshFor i = 0 to data1.recordset.fields.count - 1DataType (i) = data1.recordset (i) .typeNext'rror: 'msgbox "Database file error, please re-select the database!"
End Sub
PRIVATE SUB LIST1_DBLCLICK () CALL COMMAND1_CLICK
End Sub
Private sub list2_dblclick () call command7_clickend sub
PRIVATE SUB OPEN_CLICK () CALL COMMAND10_CLICKEND SUB
