📄 frmdataexporttype.frm
字号:
VERSION 5.00
Begin VB.Form FrmDataExportType
BorderStyle = 1 'Fixed Single
Caption = "文件输出"
ClientHeight = 4140
ClientLeft = 45
ClientTop = 330
ClientWidth = 3405
ControlBox = 0 'False
LinkTopic = "Form1"
MaxButton = 0 'False
MDIChild = -1 'True
MinButton = 0 'False
ScaleHeight = 4140
ScaleWidth = 3405
Begin VB.CommandButton Command2
Caption = "取 消"
BeginProperty Font
Name = "楷体_GB2312"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 450
Left = 1920
TabIndex = 2
Top = 3600
Width = 1020
End
Begin VB.CommandButton Command1
Caption = "输 出"
Enabled = 0 'False
BeginProperty Font
Name = "楷体_GB2312"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 450
Left = 240
TabIndex = 1
Top = 3600
Width = 1020
End
Begin VB.ListBox List1
Height = 2400
Left = 90
TabIndex = 0
Top = 930
Width = 3180
End
Begin VB.Label Label2
Caption = "数据类型："
Height = 255
Left = 120
TabIndex = 4
Top = 600
Width = 1230
End
Begin VB.Label Label1
Caption = "请选择输出文件的格式："
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 120
TabIndex = 3
Top = 120
Width = 3135
End
End
Attribute VB_Name = "FrmDataExportType"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Command1_Click()
Dim ExportString, ExportedFields
Select Case List1.ListIndex
Case 0 ' ACCESS
ExportString = "DATABASE="
Case 1 ' dbase iii
ExportString = "[dBASE III;Database="
Case 2 ' dbase iv
ExportString = "[dBASE IV;Database="
Case 3 ' dbase 5
ExportString = "[dBASE 5.0;Database="
Case 4 ' paradox 3.x
ExportString = "[Paradox 3.x;Database="
Case 5 ' paradox 4.x
ExportString = "[Paradox 4.x;Database="
Case 6 ' paradox 5.x
ExportString = "[Paradox 5.x;Database="
Case 7 ' excel 3.0
ExportString = "[Excel 3.0;Database="
Case 8 ' excel 4.0
ExportString = "[Excel 4.0;Database="
Case 9 ' excel 5.0
ExportString = "[Excel 5.0;Database="
Case 10 ' excel 95
ExportString = "[Excel 5.0;Database="
Case 11 ' excel 97
ExportString = "[Excel 8.0;Database="
Case 12 ' lotus 123 wks wk1
ExportString = "[Lotus WK1;Database="
Case 13 ' lotus 123 wk3
ExportString = "[Lotus WK3;Database="
Case 14 ' lotus 123 wk4
ExportString = "[Lotus WK4;Database="
Case 15 ' HTML
ExportString = "[HTML Export;Database="
Case 16 ' Text
ExportString = "[TEXT;Database="
Case 17 ' OBDC
MsgBox ("Currently not availiable")
Exit Sub
Case 18 ' Microsoft Exchange
MsgBox ("Currently not availiable")
Exit Sub
End Select
For x = 0 To FrmDataFields.ExportList.ListCount - 1
If x < FrmDataFields.ExportList.ListCount - 1 Then
ExportedFields = ExportedFields & "[" & FrmDataFields.ExportList.List(x) & "],"
End If
If x = FrmDataFields.ExportList.ListCount - 1 Then
ExportedFields = ExportedFields & "[" & FrmDataFields.ExportList.List(x) & "]"
End If
Next x
'Fix empty field at end of string.
If Mid$(ExportedFields, (Len(ExportedFields) - 2)) = ",[]" Then
ExportedFields = Mid$(ExportedFields, 1, (Len(ExportedFields) - 3))
End If
Select Case List1.ListIndex
Case 0
MDIFrmMain.CommonDialog.Filter = "Access文档|*.mdb"
Case 7, 8, 9, 10, 11
MDIFrmMain.CommonDialog.Filter = "Excel文档|*.xls"
Case Else
MDIFrmMain.CommonDialog.Filter = "所有文档|*.*"
End Select
MDIFrmMain.CommonDialog.ShowSave
On Error Resume Next
Kill (StripFileName(MDIFrmMain.CommonDialog.FileName) & "\schema.ini")
On Error GoTo 0
If Len(MDIFrmMain.CommonDialog.FileName) > 0 Then
Select Case List1.ListIndex
Case 7, 8, 9, 10, 11
ExportString = ExportString & MDIFrmMain.CommonDialog.FileName & ExcelExport(MDIFrmMain.CommonDialog.FileName)
Case Else
ExportString = ExportString & ExportFileName(MDIFrmMain.CommonDialog.FileName)
End Select
On Error GoTo ExportError
Dim db As Database
Set db = Workspaces(0).OpenDatabase(DataLocation)
Screen.MousePointer = 11
Me.Enabled = False
DoEvents
db.Execute "SELECT " & ExportedFields & " INTO " & ExportString & " FROM [" & FrmDataExport.lstTables.Text & "]"
db.Close
Screen.MousePointer = 0
Me.Enabled = True
MsgBox ("输出数据完毕： " & MDIFrmMain.CommonDialog.FileName)
ExportError:
If Err.Number = 3010 Then
msg = MsgBox(MDIFrmMain.CommonDialog.FileName & " 文件已经存在，是否覆盖?", vbYesNo, "覆盖文件?")
Select Case msg
Case vbYes
Kill MDIFrmMain.CommonDialog.FileName
Screen.MousePointer = 11
Me.Enabled = False
DoEvents
db.Execute "SELECT " & ExportedFields & " INTO " & ExportString & " FROM [" & FrmDataExport.lstTables.Text & "]"
db.Close
Screen.MousePointer = 0
Me.Enabled = True
MsgBox ("数据输出完毕: " & MDIFrmMain.CommonDialog.FileName)
Case vbNo
Exit Sub
End Select
Else
If Err.Number <> 0 Then
MsgBox ("SQL Statement: " & vbCrLf & "SELECT " & ExportedFields & " INTO " & ExportString & " FROM [" & FrmDataExport.lstTables.Text & "]" & vbCrLf & vbCrLf & Err.Number & vbCrLf & Err.Description)
End If
End If
End If
Screen.MousePointer = 0
Unload FrmDataExport
Unload FrmDataFields
Unload FrmDataExportType
End Sub
Private Sub Command2_Click()
FrmDataFields.Enabled = True
Unload Me
End Sub
Private Sub Form_Load()
Me.Top = FrmDataFields.Top + 400
Me.Left = FrmDataFields.Left + 400
List1.AddItem "Microsoft Jet (Access)"
List1.AddItem "dBASE III"
List1.AddItem "dBASE IV"
List1.AddItem "dBASE 5"
List1.AddItem "Paradox 3.x"
List1.AddItem "Paradox 4.x"
List1.AddItem "Paradox 5.x"
List1.AddItem "Excel 3.0"
List1.AddItem "Excel 4.0"
List1.AddItem "Excel 5.0"
List1.AddItem "Excel 95"
List1.AddItem "Excel 97"
List1.AddItem "Lotus 123 WKS and WK1"
List1.AddItem "Lotus 123 WK3"
List1.AddItem "Lotus 123 WK4"
List1.AddItem "HTML"
List1.AddItem "Text (Comma Delimited)"
List1.AddItem "OBDC"
List1.AddItem "Microsoft Exchange"
End Sub
Private Sub List1_Click()
Command1.Enabled = True
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -