一个简单的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()
'Crysta

[1] [2] 下一页