📄 excel-access.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "EXCEL(*.XLS) <--> ACCESS(*.MDB)互换工具"
ClientHeight = 3510
ClientLeft = 4050
ClientTop = 2625
ClientWidth = 6015
Icon = "EXCEL-ACCESS.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3510
ScaleWidth = 6015
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton Command5
Caption = "说明"
Height = 615
Left = 2160
TabIndex = 13
Top = 2760
Width = 1815
End
Begin VB.CommandButton Command4
Caption = "退出"
Height = 615
Left = 4080
TabIndex = 12
Top = 2760
Width = 1815
End
Begin VB.CommandButton Command3
Caption = "转换"
Height = 615
Left = 120
TabIndex = 11
Top = 2760
Width = 1935
End
Begin VB.Frame Frame1
Caption = "参数设置"
Height = 2535
Left = 120
TabIndex = 0
Top = 120
Width = 5775
Begin VB.OptionButton Option2
Caption = "ACCESS->EXCEL"
Height = 255
Left = 1920
TabIndex = 15
Top = 360
Width = 1815
End
Begin VB.OptionButton Option1
Caption = "EXCEL->ACCESS"
Height = 255
Left = 120
TabIndex = 14
Top = 360
Value = -1 'True
Width = 1695
End
Begin VB.TextBox Text4
ForeColor = &H000000FF&
Height = 375
Left = 4200
TabIndex = 10
Text = "table1"
Top = 1920
Width = 1455
End
Begin VB.TextBox Text3
ForeColor = &H00FF0000&
Height = 375
Left = 1200
TabIndex = 9
Text = "Sheet1"
Top = 1920
Width = 1455
End
Begin VB.TextBox Text2
Height = 375
Left = 1200
TabIndex = 4
Top = 720
Width = 3375
End
Begin VB.CommandButton Command2
Caption = "打开文件"
Height = 375
Left = 4680
TabIndex = 3
Top = 720
Width = 975
End
Begin VB.TextBox Text1
Height = 375
Left = 1200
TabIndex = 2
Top = 1320
Width = 3375
End
Begin VB.CommandButton Command1
Caption = "保存路径"
Height = 375
Left = 4680
TabIndex = 1
Top = 1320
Width = 975
End
Begin VB.Label Label4
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "access表名:"
Height = 180
Left = 3120
TabIndex = 8
Top = 2040
Width = 990
End
Begin VB.Label Label3
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "excel表名:"
Height = 180
Left = 120
TabIndex = 7
Top = 2040
Width = 900
End
Begin VB.Label Label2
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "ACCESS文件:"
Height = 180
Left = 120
TabIndex = 6
Top = 1440
Width = 990
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "EXCEL文件:"
Height = 180
Left = 120
TabIndex = 5
Top = 840
Width = 900
End
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 5400
Top = 3000
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'工程\引用\microsoft DAO 3.6
Private Declare Function WinExec Lib "kernel32" (ByVal lpCmdLine As String, ByVal nCmdShow As Long) As Long
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Const BIF_RETURNONLYFSDIRS = 1
Const MAX_PATH = 260
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Dim thetype As String
Private Sub cratenewMDB()
If Dir(Text1.Text) <> "" Then Kill Text1.Text
'{取当前目录的话去掉路径： If Dir("NewDB.mdb") <> "" Then Kill "NewDB.mdb")}
Set wrkDefault = DBEngine.Workspaces(0)
Set dbsNew = wrkDefault.CreateDatabase(Text1.Text, dbLangGeneral, dbEncrypt)
'{取当前目录的话去掉路径： Set dbsNew = wrkDefault.CreateDatabase("NewDB.mdb", dbLangGeneral, dbEncrypt)}
'dbsNew.NewPassword "", "123" '设置数据库密码为123
Set wrkDefault = Nothing
Set dbsNew = Nothing
End Sub
Public Sub ExportExcelSheetToAccess(sSheetName As String, sExcelPath As String, sAccessTable As String, sAccessDBPath As String)
Dim db As Database
Set db = OpenDatabase(sAccessDBPath)
db.Execute ("SELECT * into " & sAccessTable & " FROM [Excel 5.0;HDR=YES;IMEX=2;DATABASE=" & sExcelPath & "].[" & sSheetName & "$];")
End Sub
Private Sub Command3_Click()
If Option1.Value = True Then
cratenewMDB
ExportExcelSheetToAccess Text3.Text, Text2.Text, Text4.Text, Text1.Text
End If
If Option2.Value = True Then
Dim dbSource As Database
Set dbSource = OpenDatabase(Text2.Text)
dbSource.Execute ("SELECT * INTO " & Text3.Text & " IN '" & Text1.Text & "' 'EXCEL 5.0;' FROM " & Text4.Text & "")
End If
MsgBox "导入成功.", vbInformation, "数据导入"
End Sub
Private Sub Command2_Click()
Dim k As Long
Dim a As String
CommonDialog1.Filter = thetype
On Error Resume Next
CommonDialog1.Action = 1
a = CommonDialog1.FileName
k = WinExec(a, 0)
Text2.Text = a
End Sub
Private Sub Command1_Click()
Dim iNull As Integer, lpIDList As Long, lResult As Long
Dim sPath As String, udtBI As BrowseInfo
With udtBI
.hWndOwner = Me.hWnd
.lpszTitle = lstrcat("请选择文件夹", "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
SHGetPathFromIDList lpIDList, sPath
CoTaskMemFree lpIDList
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
End If
If Option1.Value = True Then
Text1.Text = Replace(sPath & "\test.MDB", "\\", "\")
End If
If Option2.Value = True Then
Text1.Text = Replace(sPath & "\test.XLS", "\\", "\")
End If
End Sub
Private Sub Command4_Click()
Unload Me
End Sub
Private Sub Command5_Click()
MsgBox "此程序可以实现EXCEL的XLS文件转换成ACCESS的MDB文件，方便快捷！" & vbCrLf & vbCrLf & "使用时请设置好参数，Excel表名可根据自己表的情况填写，默认sheet1" & vbCrLf & vbCrLf & "生成的文件名默认为test.MDB,可自行修改" & vbCrLf & vbCrLf & " by WMJ Build 2008.0808（热烈庆祝北京奥运会开幕）"
End Sub
Private Sub Form_Load()
thetype = "EXCEL文件[*.XLS]|*.xls"
End Sub
Private Sub Option1_Click()
Label1.Caption = "EXCEL文件"
Label2.Caption = "ACCESS文件"
thetype = "EXCEL文件[*.XLS]|*.xls"
End Sub
Private Sub Option2_Click()
Label1.Caption = "ACCESS文件"
Label2.Caption = "EXCEL文件"
thetype = "ACCESS文件[*.MDB]|*.mdb"
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -