CSDN博客

img cwxiao888

MDB之Table输出到Word

发表于2004/2/17 18:17:00  671人阅读

一个简单的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

0 0

相关博文

我的热门文章

img
取 消
img