📄 frmexcelzh2.frm
字号:
VERSION 5.00
Object = "{90F3D7B3-92E7-44BA-B444-6A8E2A3BC375}#1.0#0"; "ACTSKIN4.OCX"
Object = "{D76D7130-4A96-11D3-BD95-D296DC2DD072}#1.0#0"; "VSFLEX7D.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form FRMEXCELZH2
Caption = "选择EXCEL文件"
ClientHeight = 1080
ClientLeft = 60
ClientTop = 450
ClientWidth = 3255
Icon = "FRMEXCELZH2.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 1080
ScaleWidth = 3255
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton Command3
Caption = "开始操作"
Height = 465
Left = 420
TabIndex = 6
Top = 360
Width = 1125
End
Begin VB.Data Data1
Caption = "Data1"
Connect = "Access 2000;"
DatabaseName = ""
DefaultCursorType= 0 '缺省游标
DefaultType = 2 '使用 ODBC
Exclusive = 0 'False
Height = 405
Left = 4950
Options = 0
ReadOnly = 0 'False
RecordsetType = 1 'Dynaset
RecordSource = ""
Top = 6120
Visible = 0 'False
Width = 1560
End
Begin VB.TextBox Text1
DataSource = "Data1"
Height = 345
Left = 3030
TabIndex = 5
Text = "Text1"
Top = 4740
Visible = 0 'False
Width = 1185
End
Begin VB.TextBox Text2
DataSource = "Data1"
Height = 345
Left = 2970
TabIndex = 4
Text = "Text2"
Top = 5160
Visible = 0 'False
Width = 1335
End
Begin VB.TextBox Text3
DataSource = "Data1"
Height = 405
Left = 2970
TabIndex = 3
Text = "Text3"
Top = 5580
Visible = 0 'False
Width = 1305
End
Begin VB.TextBox Text4
DataSource = "Data1"
Height = 405
Left = 2940
TabIndex = 2
Text = "Text4"
Top = 6090
Visible = 0 'False
Width = 1335
End
Begin VB.CommandButton Command2
Caption = "关闭窗口"
Height = 465
Left = 1860
TabIndex = 0
Top = 360
Width = 1125
End
Begin VSFlex7DAOCtl.VSFlexGrid VSFlexGrid1
Bindings = "FRMEXCELZH2.frx":08CA
Height = 2895
Left = 4590
TabIndex = 1
Top = 2430
Visible = 0 'False
Width = 2745
_cx = 4842
_cy = 5106
_ConvInfo = -1
Appearance = 1
BorderStyle = 1
Enabled = -1 'True
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
MousePointer = 0
BackColor = -2147483643
ForeColor = -2147483640
BackColorFixed = -2147483633
ForeColorFixed = -2147483630
BackColorSel = -2147483635
ForeColorSel = -2147483634
BackColorBkg = -2147483636
BackColorAlternate= -2147483643
GridColor = -2147483633
GridColorFixed = -2147483632
TreeColor = -2147483632
FloodColor = 192
SheetBorder = -2147483642
FocusRect = 1
HighLight = 1
AllowSelection = -1 'True
AllowBigSelection= -1 'True
AllowUserResizing= 0
SelectionMode = 0
GridLines = 1
GridLinesFixed = 2
GridLineWidth = 1
Rows = 50
Cols = 10
FixedRows = 1
FixedCols = 1
RowHeightMin = 0
RowHeightMax = 0
ColWidthMin = 0
ColWidthMax = 0
ExtendLastCol = 0 'False
FormatString = ""
ScrollTrack = 0 'False
ScrollBars = 3
ScrollTips = 0 'False
MergeCells = 0
MergeCompare = 0
AutoResize = -1 'True
AutoSizeMode = 0
AutoSearch = 0
AutoSearchDelay = 2
MultiTotals = -1 'True
SubtotalPosition= 1
OutlineBar = 0
OutlineCol = 0
Ellipsis = 0
ExplorerBar = 0
PicturesOver = 0 'False
FillStyle = 0
RightToLeft = 0 'False
PictureType = 0
TabBehavior = 0
OwnerDraw = 0
Editable = 0
ShowComboButton = 1
WordWrap = 0 'False
TextStyle = 0
TextStyleFixed = 0
OleDragMode = 0
OleDropMode = 0
DataMode = 0
VirtualData = -1 'True
ComboSearch = 3
AutoSizeMouse = -1 'True
FrozenRows = 0
FrozenCols = 0
AllowUserFreezing= 0
BackColorFrozen = 0
ForeColorFrozen = 0
WallPaperAlignment= 9
End
Begin MSComDlg.CommonDialog Cmd1
Left = 7290
Top = 5580
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin ACTIVESKINLibCtl.Skin Skin1
Left = 1530
OleObjectBlob = "FRMEXCELZH2.frx":08DE
Top = 30
End
End
Attribute VB_Name = "FRMEXCELZH2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim astr As String
Dim dbAdd As Database
Dim GYXE As String
Dim rs As Recordset
Dim NUM As Long
Dim FU As Long
Dim STR As String
Private Sub ExportExcelSheetToAccess(sSheetName As String, sExcelPath As String, sAccessTable As String, sAccessDBPath As String)
On Error GoTo 3125
Dim db As Database
Dim rs As Recordset
Set db = OpenDatabase(sExcelPath, True, False, "Excel 8.0")
Call db.Execute("Select * into [;database=" & sAccessDBPath & "]." & sAccessTable & " FROM [" & sSheetName & "$]")
3125:
Select Case Err.Number
Case 3125
MsgBox "您输入的工作表名称有误", 32, "无法操作"
FRMEXCEL.Command2.Enabled = False
Exit Sub
Case 3010
MsgBox "数据已存在", 32, "无法操作"
Exit Sub
End Select
End Sub
'Private Sub Command1_Click()
' On Error GoTo 32755
' MsgBox "自动导入操作前,程序将删除当前所有已录入的数据！！！", vbOKOnly, "警告！"
' Set db = OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
' STR = "DELETE * from 学生"
' db.Execute STR
' db.Close
' Data1.DatabaseName = App.Path & "\TEMP\" & DD & ".NHB"
' Data1.RecordSource = XS
' Data1.Refresh
' Set dbAdd = OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
' Set rs = dbAdd.OpenRecordset("SELECT * FROM 年级")
' GYXE = rs![班级数]
' dbAdd.Close
' Data1.DatabaseName = Cmd1.filename
' Data1.RecordSource = "select * FROM 学生 WHERE 班级<" & GYXE & " OR 班级=" & GYXE & ""
' Data1.Refresh
' Text1.DataField = "学号"
' Text2.DataField = "姓名"
' Text3.DataField = "班级"
' Text4.DataField = "学籍"
' Data1.Recordset.MoveFirst
' Select Case MsgBox("是否真的导入记录吗？", vbOKCancel, "警告！")
' Case vbOK
' MousePointer = vbHourglass
' Set db = OpenDatabase(Cmd1.filename)
' Set rs = db.OpenRecordset("select * FROM 学生 WHERE 班级<" & GYXE & " OR 班级=" & GYXE & "")
' NUM = 0
' rs.MoveFirst
' Do While Not rs.EOF()
' NUM = NUM + 1
' rs.MoveNext
' Loop
' For FU = 0 To NUM - 1
' Data1.Recordset.AbsolutePosition = FU
' Set dbAdd = OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
' astr = "INSERT INTO 学生 (学号,姓名,班级,学籍) VALUES ('" & Text1 & "','" & Text2 & "','" & Text3 & "','" & Text4 & "' )"
' dbAdd.Execute astr
' dbAdd.Close
' Next FU
' Dim III As Long
' For III = 1 To NUM
' VSFlexGrid1.TextMatrix(III, 0) = III
' Next
' MousePointer = vbDefault
' Unload Me
' Case Else
' Cancel = True
' Unload Me
' End Select
'32755:
' Select Case Err.Number
' Case 3343
' MsgBox "此数据格式不对,请使用正确的NHB数据库进行导入", 32, "无法导入"
' MousePointer = vbDefault
' Unload Me
' Case 3061
' MsgBox "此数据被破坏,请使用数据恢复来修复此数据库", 32, "无法导入"
' MousePointer = vbDefault
' Unload Me
' Case 3078
' MsgBox "此数据格式不对或被破坏", 32, "无法导入"
' MousePointer = vbDefault
' Unload Me
' End Select
'End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Command3_Click()
On Error Resume Next
Dim 科目 As String
Dim a
科目 = InputBox("请输入要导入的工作表名：", "指定数据对象")
If 科目 = "" Then
Exit Sub
Else
Dim astr As String
Dim dbAdd As Database
Set dbAdd = DBEngine.Workspaces(0).OpenDatabase(App.Path & "\TEMP\" & DD & ".NHB")
astr = "DROP TABLE EXCLE"
dbAdd.Execute astr
dbAdd.Close
Set dbAdd = Nothing
ExportExcelSheetToAccess 科目, Cmd1.filename, "EXCLE", App.Path & "\TEMP\" & DD & ".NHB"
FRMEXCEL1.Show
Unload Me
End If
End Sub
Private Sub Form_Load()
On Error GoTo 32755
MAIN.Enabled = False
' Skin1.LoadSkin App.Path & "\SKIN\6.sk"
Skin1.ApplySkin Me.hwnd
Cmd1.CancelError = True
Cmd1.InitDir = App.Path
Cmd1.Flags = cdlOFNHideReadOnly
Cmd1.Filter = "EXCEL文件(*.XLS)|*.XLS|"
Cmd1.ShowOpen
' Me.Caption = CMD1.Filter
' If CMD1.Filter = "EXCEL文件(*.XLS)|*.XLS|" Then Me.Caption = "EXCEL"
32755:
Select Case Err.Number
Case 32755
Unload Me
End Select
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
MAIN.Enabled = True
Dim ws As Workspace
Dim db As Database
Dim rs As Recordset
For Each ws In Workspaces
For Each db In ws.Databases
For Each rs In db.Recordsets
rs.Close
Set rs = Nothing
Next
db.Close
Set db = Nothing
Next
ws.Close
Set ws = Nothing
Next
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -