一个简单的MDB之Table输出到Word的vb小程序，包括简单的查询、排序和分组功能。欢迎批评交流cwxiao888@163.com
Option Explicit
Dim DataType(100) As Integer
Dim SqlString As String
Dim OrderStr As String
Dim TalNaStr As String
Dim i As Integer
Dim MacroName As String
Private WordApp As Word.Application
Private doc As Word.Document
Private se1 As Word.Selection
Private db As Database
Private rs As Recordset
Private Sub CmdQuery_Click()
'On Error Resume Next
TalNaStr = Data1.Caption
'queryprintfrm.Data1.DatabaseName = datalistfrm.Text1.Text
'queryprintfrm.Data1.RecordSource = datalistfrm.Combo1.Text
'queryprintfrm.Data1.DatabaseName = datalistfrm.Text1.Text
queryprintfrm.Data1.RecordSource = datalistfrm.Combo1.Text
queryprintfrm.Data1.Refresh
If Me.Exp1.Text = "Like" Then
OrderStr = FindField.Text
queryprintfrm.Data1.RecordSource = "select * from" + " " + TalNaStr + " " + "where" + " " + Me.FindField.Text + " " + "like" + " " + "'" + Me.Range1.Text + "'" + " " + "order by " + " " + OrderStr
Me.Data1.Refresh
Me.DBGrid1.Refresh
Me.Refresh
End If
If Me.Exp1.Text = "In" Then
OrderStr = FindField.Text
queryprintfrm.Data1.RecordSource = "select * from" + " " + TalNaStr + " " + "where" + " " + Me.FindField.Text + " " + "In" + " " + "(" + "'" + Me.Range1.Text + "'" + ")" + " " + "order by " + " " + OrderStr
Me.Data1.Refresh
Me.DBGrid1.Refresh
Me.Refresh
End If
On Error Resume Next
Select Case Data1.Recordset.Fields(ComFind.ListIndex).Type
Case 1, 4, 5
SqlString = "select*from" + TalNaStr + " where " + FindField.Text + " " + Exp1.Text + " " + Range1.Text
Case 10
SqlString = "select*from " + TalNaStr + " where " + FindField.Text + "" + Exp1.Text + "" + "'" + Range1.Text + "'"
Case 8
SqlString = "select*from " + TalNaStr + " where " + FindField.Text + Exp1.Text + "CDate(" + "'" + Range1.Text + "')"
End Select
OrderStr = FindField.Text
QueryData SqlString, OrderStr
End Sub
Private Sub Combo1_Click()
On Error Resume Next
TalNaStr = Data1.Caption
Data1.RecordSource = "select" + " " + Combo1.Text + " " + "from" + " " + TalNaStr + " " + "group by " + " " + Combo1.Text
'Data1.RecordSource = "select *from order by name"
Data1.Refresh
DBGrid1.Refresh
Data1.Recordset.MoveLast
Me.Label8.Caption = Me.Data1.Recordset.RecordCount
Me.Refresh
End Sub
Private Sub ComFind_Click()
FindField.Text = ComFind.Text
Range1.Text = ""
ComSort.Text = ComFind.Text
Me.Refresh
End 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) = "" Then
List2.SetFocus
List2.Text = List2.List(0)
End If
End Sub
Private Sub Command10_Click()
Dim sfile As String
With dlgCommonDialog
.DialogTitle = "打开数据库文件"
.CancelError = False
'ToDo: 设置 common dialog 控件的标志和属性
.Filter = "所有数据库文件*.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.Refresh
End Sub
Private Sub Command2_Click()
'Set db = OpenDatabase(datalistfrm.Text1.Text)
'Set rs = db.OpenRecordset(datalistfrm.Combo1.Text)
Set db = Data1.Database
Set rs = Data1.Recordset
Data1.Refresh
Set WordApp = New Word.Application
WordApp.Documents.Add
Set doc = WordApp.ActiveDocument
Set se1 = WordApp.Selection
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
.LayoutMode = wdLayoutModeLineGrid
End With
se1.TypeText Text:="20" & CStr(Date) & " " & CStr(Time())
If List2.ListCount = 0 Then
Call Command6_Click
End If
doc.Tables.Add Range:=se1.Range, numrows:=1, numcolumns:=List2.ListCount
For i = 0 To List2.ListCount - 1
Screen.MousePointer = 11
'se1.TypeText Text:=rs.Fields(i).Name
se1.TypeText Text:=List2.List(i)
se1.MoveRight unit:=12
Next
'se1.TypeText Text:="产品名称"
'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(List2.List(i)).Value
se1.MoveRight unit:=12
Next
'se1.TypeText Text:=rs!产品名称
'se1.MoveRight unit:=12
'se1.TypeText Text:=rs!中止
'se1.MoveRight unit:=12
rs.MoveNext
Loop
WordApp.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 = Nothing
Screen.MousePointer = 1
End Sub
Private Sub Command3_Click()
'CrystalReport1.
End Sub
Private Sub Command4_Click()
Unload queryprintfrm
End Sub
Private Sub Command5_Click()
End
End Sub
Private Sub Command6_Click()
For i = 0 To List1.ListCount - 1 Step 1
List2.AddItem List1.List(i)
Next
List1.Clear
List2.SetFocus
List2.Text = List2.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) = "" Then
List1.SetFocus
List1.Text = List1.List(0)
End If
End Sub
Private Sub Command8_Click()
For i = 0 To List2.ListCount - 1 Step 1
List1.AddItem List2.List(i)
Next
List2.Clear
List1.SetFocus
List1.Text = List1.List(0)
End Sub
Private Sub Command9_Click()
On Error Resume Next
'On Error GoTo Errlist:
'Errlist:
' If MsgBox("没有选定字段或所选字段不合要求，请重新选择字段再浏览！", vbOKOnly) = vbOK Then Exit Sub
Dim ListStr As String
If List2.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" + " " + ListStr + " " + "from" + " " + Data1.Caption
Me.Data1.Refresh
Me.DBGrid1.Refresh
Me.Refresh
End Sub
Private Sub ComSort_Click()
OrderStr = ComSort.Text
QueryData SqlString, OrderStr
End Sub
Function QueryData(ByVal SqlString As String, ByVal OrderStr As String) As String
On Error Resume Next
SqlString = SqlString + "order by " + " " + OrderStr
Data1.RecordSource = SqlString
'Data1.RecordSource = "select *from order by name"
Data1.Refresh
DBGrid1.Refresh
Me.Refresh
End Function
Private Sub Form_Load()
On Error Resume Next
queryprintfrm.Data1.DatabaseName = datalistfrm.Text1.Text
queryprintfrm.Data1.RecordSource = datalistfrm.Combo1.Text
queryprintfrm.Caption = datalistfrm.Combo1.Text
queryprintfrm.Data1.Refresh
'Me.Data1.RecordSource = datalistfrm.Combo1.Text
'Me.Caption = datalistfrm.Combo1.Text
'Me.Data1.Refresh
For i = 0 To Data1.Recordset.Fields.Count - 1 Step 1
queryprintfrm.ComFind.AddItem Data1.Recordset.Fields(i).Name
queryprintfrm.ComSort.AddItem Data1.Recordset.Fields(i).Name
Me.List1.AddItem Data1.Recordset.Fields(i).Name
'Me.List2.AddItem Data1.Recordset.Fields(i).Name
Me.Combo1.AddItem Data1.Recordset.Fields(i).Name
Next
queryprintfrm.Refresh
For i = 0 To Data1.Recordset.Fields.Count - 1
DataType(i) = Data1.Recordset(i).Type
Next
'error:
'MsgBox "数据库文件出错,请重新选择数据库！"
End Sub
Private Sub List1_DblClick()
Call Command1_Click
End Sub
Private Sub List2_DblClick()
Call Command7_Click
End Sub
Private Sub open_Click()
Call Command10_Click
End Sub
