file.frm

演示了由MDB数据库生成HTML表格文件的演示效果。

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Object = "{00028C01-0000-0000-0000-000000000046}#1.0#0"; "DBGRID32.OCX"
Begin VB.Form Form1 
   Caption         =   "自动生成HTML表格文件"
   ClientHeight    =   4920
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   9000
   Icon            =   "file.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   4920
   ScaleWidth      =   9000
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton exitme 
      Caption         =   "退出"
      Height          =   372
      Left            =   7200
      TabIndex        =   6
      Top             =   4440
      Width           =   1212
   End
   Begin VB.CommandButton make 
      Caption         =   "生成HTML表格文件"
      Height          =   372
      Left            =   4440
      TabIndex        =   5
      Top             =   4440
      Width           =   2172
   End
   Begin MSDBGrid.DBGrid DBGrid1 
      Bindings        =   "file.frx":000C
      Height          =   3375
      Left            =   120
      OleObjectBlob   =   "file.frx":0020
      TabIndex        =   3
      Top             =   720
      Width           =   6615
   End
   Begin VB.Data Data1 
      Caption         =   "  数据库控制"
      Connect         =   "Access"
      DatabaseName    =   ""
      DefaultCursorType=   0  'DefaultCursor
      DefaultType     =   2  'UseODBC
      Exclusive       =   0   'False
      Height          =   375
      Left            =   120
      Options         =   0
      ReadOnly        =   0   'False
      RecordsetType   =   1  'Dynaset
      RecordSource    =   ""
      Top             =   4440
      Width           =   2355
   End
   Begin VB.ListBox List1 
      Height          =   3375
      ItemData        =   "file.frx":09E3
      Left            =   6960
      List            =   "file.frx":09E5
      TabIndex        =   1
      Top             =   720
      Width           =   1935
   End
   Begin MSComDlg.CommonDialog comm1 
      Left            =   2640
      Top             =   120
      _ExtentX        =   688
      _ExtentY        =   688
      _Version        =   393216
   End
   Begin VB.CommandButton openf 
      Caption         =   "打开数据库"
      Height          =   372
      Left            =   2760
      TabIndex        =   0
      Top             =   4440
      Width           =   1212
   End
   Begin VB.Label Label2 
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   12
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H8000000D&
      Height          =   255
      Left            =   240
      TabIndex        =   4
      Top             =   240
      Width           =   1815
   End
   Begin VB.Label Label1 
      Caption         =   "请选择表:"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   14.25
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00C00000&
      Height          =   375
      Left            =   6960
      TabIndex        =   2
      Top             =   240
      Width           =   1815
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public ws As Workspace, db As Database, tb As TableDef, rs As Recordset
Public nn As Long, errS As String
Public Errstring As String
Private Sub exitme_Click()
Unload Me
End Sub

Private Sub Form_Load()
nn = 0
Form1.WindowState = 2
errS = "数据库损坏,或其他错误!"
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If Not (db Is Nothing) Then
db.Close
Set db = Nothing
End If
End Sub


Private Sub List1_Click()
On Error GoTo er
nn = 0
Dim tbname As String
tbname = List1.List(List1.ListIndex)
Set rs = db.OpenRecordset(tbname)
If rs.EOF Then
MsgBox "没有记录"
Else
rs.MoveLast
nn = rs.RecordCount
Label2 = "共有" & CStr(nn) & " 条记录"
rs.MoveFirst
Set Data1.Recordset = rs
End If
Exit Sub
er:
MsgBox errS
End Sub

Private Sub make_Click()
Dim fn As String
lens = 0
If Not (rs Is Nothing) And nn > 0 Then
If nn > 1000 Then
ff = MsgBox("共有" & CStr(nn) & "条记录,您确信要生成HTML文件", vbYesNoCancel)
If ff = vbNo Or ff = vbCancel Then Exit Sub
End If
comm1.FileName = ""
comm1.DialogTitle = "保存HTML文件"
comm1.ShowSave
fn = LCase(comm1.FileName)
If fn <> "" Then
If Right(fn, 4) <> ".htm" And Right(fn, 5) <> ".html" Then
fn = fn & ".html"
End If
maketable fn
End If
End If
End Sub

Private Sub openf_Click()
Dim filen As String, dirf As String, mm As String
mm = ""
On Error GoTo er
Errstring = "这个数据库已加密,请输入密码:"
comm1.FileName = "*.mdb;*.dbf"
comm1.Filter = "*.mdb"
comm1.DialogTitle = "打开数据库文件"
comm1.ShowOpen
filen = LCase(comm1.FileName)
For i = Len(filen) To 1 Step -1
dirf = Mid(filen, i, 1)
If dirf = "\" Then
dirf = Left(filen, i)
Exit For
End If
Next
If filen <> "*.mdb;*.dbf" Then
List1.Clear
Set ws = DBEngine.Workspaces(0)
If Right(filen, 3) = "mdb" Then
Set db = ws.OpenDatabase(filen, False, False, ";pwd=" & mm)
Else
Set db = ws.OpenDatabase(dirf, False, False, "FoxPro 2.6")
End If
Listdb
End If
Exit Sub
er:
Select Case Err.Number
Case 3031
Opendb filen
Exit Sub
End Select
MsgBox "无法打开数据库,数据库文件可能已坏!"
End Sub
Sub maketable(fn As String)
Dim ss As String, Fsum As Integer
On Error GoTo dd
dd = FileLen(fn)
yn = MsgBox("存在" & fn & "文件,是否复盖", vbYesNoCancel)
If yn = vbNo Or yn = vbCancel Then
Exit Sub
End If
If GetAttr(fn) <> vbReadOnly Then
Kill (yn)
Else
MsgBox "文件只读,请先改变文件属性"
End If
dd:
Open fn For Output Shared As #1
Form2.Show vbModal
End Sub
Sub Listdb()
On Error GoTo er
For Each tb In db.TableDefs
If Left(tb.Name, 4) <> "MSys" Then List1.AddItem (tb.Name)
Next
List1.Refresh
Exit Sub
er:
MsgBox errS
End Sub
Sub Opendb(filen As String)
On Error GoTo cc:
Dim mm As String
mm = ""
mm = InputBox(Errstring)
If mm = "" Then Exit Sub
Set db = ws.OpenDatabase(filen, False, False, ";pwd=" & mm)
Listdb
Exit Sub
cc:
If Err.Number = 3031 Then
Errstring = "密码错误,请重新输入!(按取消键退出)"
Opendb filen
Else
MsgBox "无法打数据库!!"
End If
End Sub