DBF文件输出到WORD

Private i As Integer
Private 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 cmdAdd_Click()
  Dim sTmp As String
  sTmp = InputBox("输入要添加的新项目：")
  If Len(sTmp) = 0 Then Exit Sub
  lstItems.AddItem sTmp
End Sub

Private Sub cmdDelete_Click()
  If lstItems.ListIndex > -1 Then
    If MsgBox("删除 '" & lstItems.Text & "'?", vbQuestion + vbYesNo) = vbYes Then
      lstItems.RemoveItem lstItems.ListIndex
    End If
  End If
End Sub

Private Sub cmdUp_Click()
  On Error Resume Next
  Dim nItem As Integer
 
  With lstItems
    If .ListIndex < 0 Then Exit Sub
    nItem = .ListIndex
    If nItem = 0 Then Exit Sub  '不能将第一个项目向上移动
    '向上移动项目
    .AddItem .Text, nItem - 1
    '删除旧项目
    .RemoveItem nItem + 1
    '选择刚刚移动的项目
    .Selected(nItem - 1) = True
  End With
End Sub

Private Sub cmdDown_Click()
  On Error Resume Next
  Dim nItem As Integer
 
  With lstItems
    If .ListIndex < 0 Then Exit Sub
    nItem = .ListIndex
    If nItem = .ListCount - 1 Then Exit Sub '不能将最后的项目向下移动
    '向下移动项目
    .AddItem .Text, nItem + 2
    '删除旧的项目
    .RemoveItem nItem
    '选择刚刚移动的项目
    .Selected(nItem + 1) = True
  End With
End Sub

Private Sub lstItems_DragDrop(Source As Control, X As Single, Y As Single)
  Dim i As Integer
  Dim nID As Integer
  Dim sTmp As String
 
  If Source.Name <> "lstItems" Then Exit Sub
  If lstItems.ListCount = 0 Then Exit Sub
 
  With lstItems
    i = (Y / TextHeight("A")) + .TopIndex
    If i = .ListIndex Then
      '将它放在它自己的上面
      Exit Sub
    End If
    If i > .ListCount - 1 Then i = .ListCount - 1
    nID = .ListIndex
    sTmp = .Text
    If (nID > -1) Then
      sTmp = .Text
      .RemoveItem nID
      .AddItem sTmp, i
      .ListIndex = .NewIndex
    End If
  End With
  SetListButtons
End Sub

Sub lstItems_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If Button = vbLeftButton Then lstItems.Drag
End Sub

Private Sub lstItems_Click()
  SetListButtons
End Sub

Sub SetListButtons()
  Dim i As Integer
  i = lstItems.ListIndex
  '设置移动按钮的状态
  cmdUp.Enabled = (i > 0)
  cmdDown.Enabled = ((i > -1) And (i < (lstItems.ListCount - 1)))
  cmdDelete.Enabled = (i > -1)
End Sub

Private Sub Command1_Click()

 With dlgCommonDialog
         Label4.Caption = .InitDir
        .DialogTitle = "打开dbf文件"
        .CancelError = False
        'ToDo: 设置 common dialog 控件的标志和属性
        .Filter = "所有dbf文件 (*.dbf)|*.dbf"
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sfile = .FileName
        Label1.Caption = sfile
        Label2.Caption = .FileTitle
        Label3.Caption = Left(sfile, Len(sfile) - Len(.FileTitle) - 1)
        Data1.Caption = .FileTitle
    End With
'        Data1.Database = Label3.Caption
        Data1.DatabaseName = Label3.Caption
        Data1.RecordSource = Label2.Caption
'         On Error Resume Next
        
         Data1.Refresh
'        Form1.MSFlexGrid1.Refresh
        Form1.DBGrid1.Refresh
        Form1.Refresh
End Sub

Private Sub Command2_Click()
        End
End Sub

Private Sub Command3_Click()
 If Label2.Caption = "DbfFile:" Then
    Call Command1_Click
 End If
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())

'doc.Tables.Add Range:=se1.Range, numrows:=1, numcolumns:=List2.ListCount
 doc.Tables.Add Range:=se1.Range, numrows:=1, numcolumns:=rs.Fields.Count
      
For i = 0 To rs.Fields.Count - 1
Screen.MousePointer = 11
'se1.TypeText Text:=rs.Fields(i).Name
se1.TypeText Text:=rs.Fields(i).Name
se1.MoveRight unit:=12
Next

'se1.TypeText Text:="产品名称"
'se1.MoveRight unit:=12

Do Until rs.EOF
 For i = 0 To rs.Fields.Count - 1
 On Error Resume Next
 se1.TypeText Text:=rs.Fields(i).Value
' se1.TypeText Text:=rs.Fields(rs.Fields(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:=rs.Fields.Count
   
   
    se1.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:= _
    wdAlignPageNumberRight, FirstPage:=True
    
 WordApp.Visible = True
  
' WordApp.Run MacroName:="InsertDateTime"
Set WordApp = Nothing
Screen.MousePointer = 1
'data1.Recordset.Fields()
End Sub

Private Sub exit_Click()
            Close
            End
End Sub

Private Sub open_Click()
           Call Command1_Click
End Sub