mdb.frm

小型VB报表系统

  '显示页数
  Print #1, "<caption>" & "分页报表" & CStr(p \ Lines + 1) & "</caption>"
  '报表项目名称
  For i = 0 To n - 1
    Print #1, "<th>" & Data1.Recordset.Fields(i).Name & "</th>"
  Next
  '分页处理
  For k = 1 To Lines
    Print #1, "<tr>"
    '读取个字段的数据
    For i = 0 To n - 1
      V = "<td>" & Data1.Recordset.Fields(i).Value & "</td>"
      Print #1, V
    Next i
    Data1.Recordset.MoveNext
    p = p + 1
    If Data1.Recordset.EOF Then Exit For
  Next k
  Print #1, "</table>"
Wend
Print #1, "</body>"
Print #1, "</html>"
Data1.Database.Close
Close #1
'打开超文本报表
Shell "C:\Program Files\Internet Explorer\IEXPLORE.EXE " & HtmlFn, vbMaximizedFocus
End Sub

Private Sub Command1_Click()
cd1.FileName = ""
cd1.ShowOpen
If cd1.FileName <> "" Then
  Text1.Text = cd1.FileName
  List1.Clear
  Command2.Enabled = False
  Command3.Enabled = False
  Command4.Enabled = False
  Command5.Enabled = False
  Set db = DBEngine.Workspaces(0).OpenDatabase(Text1.Text)
  For Each tbl In db.TableDefs
    If Left(tbl.Name, 4) <> "MSys" And Left(tbl.Name, 4) <> "USys" Then
      List1.AddItem tbl.Name
     End If
  Next
  If List1.ListCount > 0 Then
    List1.ListIndex = 0
    dbfn = Text1.Text
  Else
    Text1.Text = ""
    MsgBox Chr(13) + cd1.FileName + "  " + Chr(13) + Chr(13) + "此数据库中没有数据表！ ", vbCritical
  End If
End If


End Sub

Private Sub Command2_Click()
List1.SetFocus
Me.Hide
ms.Label1.Caption = "正在装入数据，请稍后..."
ms.Visible = True
ms.Refresh
mdbd.Timer1.Enabled = True
Sleep (500)
mdbd.Show

End Sub

Private Sub Command3_Click()
Dim wdApp As Word.Application  '定义word变量
Dim wdDoc '定义word文档变量
Dim wdTable '定义WORD表格变量
Dim FieldLen()  '存放字段长度值
Dim FieldLen1 As Integer  '存放每列的最大宽度
Dim FieldValue As String
Dim iRow, iCol As Integer
Dim iRowCount, iColCount As Integer
List1.SetFocus
If MsgBox(Chr(13) + "是否转换成WORD数据？  ", vbQuestion + vbYesNo) = vbNo Then Exit Sub
Label6.Caption = "正在转换，请稍后..."
On Error Resume Next
Data1.DatabaseName = Text1.Text
Data1.RecordSource = List1.Text
Data1.Refresh
With Data1.Recordset
  .MoveLast
  If .RecordCount < 1 Then
    Data1.Database.Close
    Exit Sub  '没有记录时退出
  End If
  iRowCount = .RecordCount + 1 '记录总数
  iColCount = .Fields.Count  '字段总数
  .MoveFirst
End With
'重新定义列数
ReDim FieldLen(iColCount)
'添加一个word文档及表
Set wdApp = CreateObject("Word.Application")
Set wdDoc = wdApp.Documents.Add
Set wdTable = wdApp.Selection.Tables.Add(wdApp.Selection.Range, iRowCount, iColCount, wdWord9TableBehavior, wdAutoFitFixed)
'生成word
With Data1.Recordset
  '读取标题宽度作为列宽初始值
  For iCol = 1 To iColCount
    FieldLen(iCol) = LenB(StrConv(.Fields(iCol - 1).Name, vbFromUnicode))
  Next iCol
  For iRow = 1 To iRowCount
    For iCol = 1 To iColCount
      '读取字段值，返回为文本型
      If .Fields(iCol - 1).Type = 10 Then
        FieldValue = Trim(.Fields(iCol - 1).Value)
      Else
        FieldValue = CStr(.Fields(iCol - 1).Value)
      End If
      Select Case iRow
      Case 1  '在表中的第一行加标题
        wdTable.Cell(iRow, iCol).Range.InsertAfter (.Fields(iCol - 1).Name)  'Word表
      Case Else
        '计算字段值长度，返回值的单位是字节长度
        FieldLen1 = LenB(StrConv(FieldValue, vbFromUnicode))
        '自动设置表格列宽
        If FieldLen(iCol) < FieldLen1 Then
          '表格列宽等于较长字段长
          wdTable.Columns(iCol).PreferredWidth = 8 * FieldLen1 'Word表
          '数组Fieldlen(iCol)中存放最大字段长度值
          FieldLen(iCol) = FieldLen1
        Else
          '表格列宽等于当前字段宽度
          wdTable.Columns(iCol).PreferredWidth = 8 * FieldLen(iCol)  'Word表
        End If
        '向表单元格中写入字段值
        wdTable.Cell(iRow, iCol).Range.InsertAfter (FieldValue) 'Word表
      End Select
      DoEvents
    Next iCol
    If iRow <> 1 Then
      If Not .EOF Then .MoveNext
    End If
    DoEvents
  Next iRow
  Data1.Database.Close  '关闭数据库
  wdApp.Visible = True  '显示Word表格
  Set wdApp = Nothing  '交还控制给Word
End With
End Sub

Private Sub Command4_Click()
List1.SetFocus
Me.Hide
ms.Label1.Caption = "正在装入数据，请稍后..."
ms.Visible = True
ms.Refresh
mdbf.Timer1.Enabled = True
Sleep (500)
mdbf.Show

End Sub

Private Sub Command5_Click()
List1.SetFocus
Me.Visible = False
ms.Label1.Caption = "正在装入数据，请稍后..."
ms.Visible = True
ms.Refresh
mdbbb.Timer1.Enabled = True
Sleep (500)
mdbbb.Show

End Sub

Private Sub Command6_Click()
Dim iRow, iCol As Integer
Dim iRowCount, iColCount As Integer
Dim FieldLen() '存字段长度值
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
List1.SetFocus
    
On Error Resume Next
If MsgBox(Chr(13) + "是否转换成EXCEL数据？  ", vbQuestion + vbYesNo) = vbNo Then Exit Sub
    
Label6.Caption = "正在转换，请稍后..."
Data1.DatabaseName = Text1.Text
Data1.RecordSource = List1.Text
Data1.Refresh
    
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets(1)
With Data1.Recordset
  .MoveLast
  If .RecordCount < 1 Then
  MsgBox Chr(13) + "Error 没有记录!  ", vbCritical
    Label6.Caption = "转换失败！  "
    Exit Sub
  End If
  iRowCount = .RecordCount '记录总数
  iColCount = .Fields.Count '字段总数
  ReDim FieldLen(iColCount)
  .MoveFirst
  For iRow = 1 To iRowCount + 1
    For iCol = 1 To iColCount
      Select Case iRow
      Case 1 '在Excel中的第一行加标题
        xlSheet.Cells(iRow, iCol).Value = .Fields(iCol - 1).Name
      Case 2 '将数组FIELDLEN()存为第一条记录的字段长
        If IsNull(.Fields(iCol - 1)) = True Then
          FieldLen(iCol) = LenB(.Fields(iCol - 1).Name)
          '如果字段值为NULL,则将数组Filelen(Icol)的值设为标题名的宽度
        Else
          FieldLen(iCol) = LenB(.Fields(iCol - 1))
        End If
        xlSheet.Columns(iCol).ColumnWidth = FieldLen(iCol)
        'Excel列宽等于字段长
        xlSheet.Cells(iRow, iCol).Value = .Fields(iCol - 1)
        '向Excel的CellS中写入字段值
      Case Else
        FieldLen1 = LenB(.Fields(iCol - 1))
        If FieldLen(iCol) < FieldLen1 Then
          xlSheet.Columns(iCol).ColumnWidth = FieldLen1
          '表格列宽等于较长字段长
          FieldLen(iCol) = FieldLen1
          '数组Fieldlen(Icol)中存放最大字段长度值
        Else
          xlSheet.Columns(iCol).ColumnWidth = FieldLen(iCol)
        End If
        xlSheet.Cells(iRow, iCol).Value = .Fields(iCol - 1)
      End Select
      DoEvents
    Next iCol
    If iRow <> 1 Then
      If Not .EOF Then .MoveNext
    End If
    DoEvents
    Label6.Caption = "正在转换，完成: " + CStr(Int(100 * iRow / iRowCount)) + "%"
  Next iRow
  With xlSheet
    .Range(.Cells(1, 1), .Cells(1, iCol - 1)).Font.Name = "黑体"
    '设标题为黑体字
    .Range(.Cells(1, 1), .Cells(1, iCol - 1)).Font.Bold = True
    '标题字体加粗
    .Range(.Cells(1, 1), .Cells(iRow, iCol - 1)).Borders.LineStyle = xlContinuous
    '设表格边框样式
  End With
  xlApp.Visible = True '显示表格
  xlBook.Save  '保存数据
  Set xlApp = Nothing '交还控制给Excel
End With
    
Data1.Database.Close
Label6.Caption = "转换完毕！ "

End Sub

Private Sub Command7_Click()
List1.SetFocus
Label6.Caption = "正在转换，请稍后..."
mdb2html Text1.Text, List1.Text, "c:\temp.html", -1
End Sub

Private Sub Form_Activate()
List1.SetFocus
End Sub

Private Sub Form_Load()

Label1.Font.Size = 25
Label2.Font.Size = Label1.Font.Size
Label3.Font.Size = Label1.Font.Size

Label3.Left = (Me.Width - Label3.Width) \ 2 - 30
Label1.Left = Label3.Left - 20
Label2.Left = Label3.Left + 20
Label1.Top = Label3.Top - 20
Label2.Top = Label3.Top + 20


End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
End
End Sub

Private Sub List1_Click()
If List1.Text <> "" Then
  Command2.Enabled = True
  Command3.Enabled = True
  Command4.Enabled = True
  Command5.Enabled = True
  Command6.Enabled = True
  Command7.Enabled = True
  tbfn = List1.Text
End If
End Sub