VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmDataFile
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "由数据库变换为数据文件"
ClientHeight = 3765
ClientLeft = 165
ClientTop = 555
ClientWidth = 7080
LinkTopic = "Form1"
ScaleHeight = 3765
ScaleWidth = 7080
StartUpPosition = 3 '窗口缺省
Begin VB.CheckBox Check3
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "有列标"
ForeColor = &H80000008&
Height = 495
Left = 2280
TabIndex = 13
Top = 3120
Value = 1 'Checked
Width = 975
End
Begin VB.CheckBox Check2
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "有行标"
ForeColor = &H80000008&
Height = 495
Left = 1200
TabIndex = 12
Top = 3120
Value = 1 'Checked
Width = 975
End
Begin VB.CheckBox Check1
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "有标题"
ForeColor = &H80000008&
Height = 495
Left = 120
TabIndex = 11
Top = 3120
Value = 1 'Checked
Width = 975
End
Begin VB.CommandButton cmdChange
Caption = "变换"
Height = 375
Left = 4800
TabIndex = 9
Top = 3240
Width = 855
End
Begin VB.TextBox txtFileName
Alignment = 2 'Center
Appearance = 0 'Flat
Height = 270
Left = 2400
TabIndex = 8
Top = 2640
Width = 1695
End
Begin VB.DirListBox Dir1
Height = 2610
Left = 4440
TabIndex = 6
Top = 360
Width = 2535
End
Begin VB.DriveListBox Drive1
Height = 300
Left = 2520
TabIndex = 3
Top = 360
Width = 1575
End
Begin VB.CommandButton cmdExit
Caption = "退出"
Height = 375
Left = 5880
TabIndex = 2
Top = 3240
Width = 855
End
Begin VB.ListBox lstTDName
Height = 2580
Left = 120
TabIndex = 1
Top = 360
Width = 1575
End
Begin MSComDlg.CommonDialog dlgFileName
Left = 2160
Top = 840
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Line Line2
X1 = 0
X2 = 7080
Y1 = 3000
Y2 = 3000
End
Begin VB.Line Line1
X1 = 1920
X2 = 1920
Y1 = 0
Y2 = 3000
End
Begin VB.Label lblNotice
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
BorderStyle = 1 'Fixed Single
Caption = "变换完成，请退出"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 255
Left = 2160
TabIndex = 10
Top = 1680
Width = 2055
End
Begin VB.Label lblFile
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "给出文件名（不带扩展名）"
ForeColor = &H80000008&
Height = 255
Left = 2040
TabIndex = 7
Top = 2280
Width = 2295
End
Begin VB.Label lblDir
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "给出保存文件的目录"
ForeColor = &H80000008&
Height = 255
Left = 4440
TabIndex = 5
Top = 120
Width = 2535
End
Begin VB.Label lblDrive
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "给出保存文件的驱动器"
ForeColor = &H80000008&
Height = 255
Left = 2280
TabIndex = 4
Top = 120
Width = 2055
End
Begin VB.Label lblTable
Alignment = 2 'Center
Appearance = 0 'Flat
BackColor = &H80000005&
Caption = "给出数据表"
ForeColor = &H80000008&
Height = 255
Left = 120
TabIndex = 0
Top = 120
Width = 1575
End
End
Attribute VB_Name = "frmDataFile"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'frmDataFile窗体
'从数据库变换为数据文件
Option Explicit
Sub GetDBName(blnNew As Boolean)
'blnNew=True为新建，blnNew=False为打开
On Error GoTo DBNameError
With dlgFileName
.DialogTitle = "提供数据库名"
.DefaultExt = "mdb" '以.mdb为扩展名,缺省
.Filter = "(*.mdb)|*.mdb"
.CancelError = True '按"取消"则作为错误
If blnNew Then
.ShowSave '新建数据库
Else
.ShowOpen '打开已有的数据库
End If
strDBName = .FileName '数据库全名
End With
Exit Sub
DBNameError:
strDBName = ""
MsgBox "数据名错误", , "数据库"
End Sub
Private Sub Form_Load()
lblNotice.Visible = False
On Error GoTo OpenError
GetDBName False '取得数据库名
Set db = DBEngine(0).OpenDatabase(strDBName) '打开数据库
'在列表框显示数据表
For Each td In db.TableDefs
If (td.Attributes And dbSystemObject) = 0 Then '甩掉系统表
If (td.Attributes dbAttachedTable) Then '甩掉附属表
lstTDName.AddItem td.Name '用户表进入列表框
End If
End If
Next
Exit Sub
OpenError:
MsgBox "打开数据库错误", , "打开数据库"
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
'单击列表框事件取得数据表名
Private Sub lstTDName_Click()
strTDName = lstTDName
Set td = db.TableDefs(strTDName) '打开数据表
Set rs = td.OpenRecordset(dbOpenDynaset) '建立动态记录集
End Sub
'变换
Private Sub cmdChange_Click()
Dim intI As Integer, intJ As Integer
Dim intRowStart As Integer
If strDBName = "" Then
MsgBox "没有提供数据库名,重作!", 0
Exit Sub
End If
If strTDName = "" Then
MsgBox "没有提供数据表名,重作!", 0
Exit Sub
End If
If txtFileName.Text = "" Then
MsgBox "没有提供数据文件名,重作!", 0
Exit Sub
End If
'取得数据文件全名
strFileName = Dir1.Path & "\" & txtFileName.Text & ".dat"
intFileNumber = FreeFile '取得空闲的文件号
'打开数据文件
Open strFileName For Output As #intFileNumber
If Check1.Value = 1 Then
blnTitle = True '有标题
Else
blnTitle = False '无标题
End If
If Check2.Value = 1 Then
blnRowLabel = True '有行标
Else
blnRowLabel = False '无行标
End If
If Check3.Value = 1 Then
blnColLabel = True '有列标
Else
blnColLabel = False '无列标
End If
intCol = td.Fields.Count '取得数据表的列数
intRow = td.RecordCount '取得数据表的行数
intRowAll = intRow + 3 '数据行数、总行数、列数各占一行
If blnTitle Then intRowAll = intRowAll + 1 '有标题
If blnRowLabel Then intRowAll = intRowAll + intRow '有行标
If blnColLabel Then intRowAll = intRowAll + 1 '有列标
ReDim dbArray(0 To intRowAll, 0 To intCol) '重新定义保存数据的数组
dbArray(0, 0) = " "
For intI = 1 To intCol '为最上面的行赋值
dbArray(0, intI) = "第" & intI & "列"
Next intI
dbArray(1, 0) = "列数"
dbArray(1, 1) = intCol '列数
If intCol >= 2 Then
For intJ = 2 To intCol
'其余的列充以*******，表示这些列没有用
dbArray(1, intJ) = "*******"
Next intJ
End If
dbArray(2, 0) = "行数"
dbArray(2, 1) = intRow '行数
If intCol >= 2 Then
For intJ = 2 To intCol
'其余的列充以*******，表示这些列没有用
dbArray(2, intJ) = "*******"
Next intJ
End If
intRowStart = 3
dbArray(3, 0) = "总行数"
dbArray(3, 1) = intRowAll '总行数
If intCol >= 2 Then
For intJ = 2 To intCol
'其余的列充以*******，表示这些列没有用
dbArray(3, intJ) = "*******"
Next intJ
End If
intRowStart = 4
If blnTitle Then '形成标题标记
dbArray(intRowStart, 0) = "标题"
dbArray(intRowStart, 1) = " "
If intCol >= 2 Then
For intJ = 2 To intCol
'其余的列充以*******，表示这些列没有用
dbArray(intRowStart, intJ) = "*******"
Next intJ
End If
intRowStart = 5
End If
If blnRowLabel Then '形成行标记
For intI = intRowStart To (intRowStart + intRow - 1)
dbArray(intI, 0) = "行标" & (intI - intRowStart + 1)
dbArray(intI, 1) = " "
If intCol >= 2 Then
For intJ = 2 To intCol
'其余的列充以*******，表示这些列没有用
dbArray(intI, intJ) = "*******"
Next intJ
End If
Next intI
intRowStart = intRowStart + intRow
End If
If blnColLabel Then '形成列标记
dbArray(intRowStart, 0) = "列标"
intJ = 1
'取得列标名称（字段名称）
For Each fd In td.Fields
dbArray(intRowStart, intJ) = fd.Name
intJ = intJ + 1
Next
intRowStart = intRowStart + 1
End If
For intI = intRowStart To intRowAll '数据行的标记
dbArray(intI, 0) = "第" & (intI - intRowStart + 1) & "行"
Next intI
'将数据表中的数据装入数组
rs.MoveFirst
Do Until rs.EOF
For intJ = 1 To intCol
dbArray(intRowStart, intJ) = rs(intJ - 1)
Next intJ
rs.MoveNext
intRowStart = intRowStart + 1
Loop
For intI = 1 To intRowAll
For intJ = 1 To intCol
'将数组中的数据写到文件上
Write #intFileNumber, dbArray(intI, intJ);
Next intJ
Next intI
'将上标记写到数据文件
For intI = 1 To intCol
Write #intFileNumber, dbArray(0, intI);
Next intI
'将左标记写到数据文件
For intI = 1 To intRowAll
Write #intFileNumber, dbArray(intI, 0);
Next intI
lblNotice.Visible = True
Close #intFileNumber
End Sub
Private Sub Check1_Click()
'确定“标题”的最优先地位
If Check1.Value = 0 Then
Check2.Value = 0
Check3.Value = 0
End If
End Sub
Private Sub Check2_Click()
'确定“行标”的次优先地位
If Check2.Value = 0 Then Check3.Value = 0
If Check2.Value = 1 Then Check1.Value = 1
End Sub
Private Sub Check3_Click()
'确定“列标”的不优先地位
If Check3.Value = 1 Then
Check1.Value = 1
Check2.Value = 1
End If
End Sub
'单击注释标签也可以退出
Private Sub lblNotice_Click()
Unload Me
frmDatabase.Show
End Sub
'退出
Private Sub cmdExit_Click()
Unload Me
frmDatabase.Show
End Sub
