一个简单的MDB之Table输出到Word的vb小程序，包括简单的查询、排序和分组功能。　欢迎批评交流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" ThenOrderStr = FindField.Textqueryprintfrm.Data1.RecordSource = "select * from" + " " + TalNaStr + " " + "where" + " " + Me.FindField.Text + " " + "like" + " " + "'" + Me.Range1.Text + "'" + " " + "order by " + " " + OrderStrMe.Data1.RefreshMe.DBGrid1.RefreshMe.RefreshEnd If If Me.Exp1.Text = "In" ThenOrderStr = FindField.Textqueryprintfrm.Data1.RecordSource = "select * from" + " " + TalNaStr + " " + "where" + " " + Me.FindField.Text + " " + "In" + " " + "(" + "'" + Me.Range1.Text + "'" + ")" + " " + "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 + " where " + FindField.Text + "" + Exp1.Text + "" + "'" + Range1.Text + "'"Case 8SqlString = "select*from " + TalNaStr + " where " + FindField.Text + Exp1.Text + "CDate(" + "'" + Range1.Text + "')" End SelectOrderStr = FindField.TextQueryData SqlString, OrderStr End Sub   Private Sub Combo1_Click()On Error Resume NextTalNaStr = Data1.CaptionData1.RecordSource = "select" + " " + Combo1.Text + " " + "from" + " " + TalNaStr + " " + "group by " + " " + Combo1.Text'Data1.RecordSource = "select *from  order by name"Data1.RefreshDBGrid1.RefreshData1.Recordset.MoveLastMe.Label8.Caption = Me.Data1.Recordset.RecordCountMe.RefreshEnd Sub Private 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) = "" Then            List2.SetFocus            List2.Text = List2.List(0)            End IfEnd 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.RefreshEnd Sub Private 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.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_ClickEnd If doc.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:="产品名称"'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   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 Command4_Click()Unload queryprintfrmEnd Sub Private Sub Command5_Click()EndEnd 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 StringIf 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.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 Resume 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 'error:'MsgBox "数据库文件出错,请重新选择数据库！" 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

评论