📄 frmexcel.frm
字号:
VERSION 5.00
Object = "{90F3D7B3-92E7-44BA-B444-6A8E2A3BC375}#1.0#0"; "ACTSKIN4.OCX"
Begin VB.Form FRMEXCEL
BorderStyle = 3 'Fixed Dialog
Caption = "EXCEL数据选择字段"
ClientHeight = 2700
ClientLeft = 45
ClientTop = 330
ClientWidth = 4635
Icon = "FRMEXCEL.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 2700
ScaleWidth = 4635
StartUpPosition = 2 'CenterScreen
Begin VB.CommandButton Command3
Caption = "退出导入"
Height = 525
Left = 3390
TabIndex = 12
Top = 1710
Width = 1155
End
Begin VB.CommandButton Command2
Caption = "确定导入"
Height = 525
Left = 3390
TabIndex = 11
Top = 1020
Width = 1155
End
Begin ACTIVESKINLibCtl.Skin Skin1
Left = 3840
OleObjectBlob = "FRMEXCEL.frx":1D42
Top = 270
End
Begin VB.CommandButton Command1
Caption = "Command1"
Height = 525
Left = 5580
TabIndex = 10
Top = 4170
Visible = 0 'False
Width = 1155
End
Begin VB.Frame Frame1
Caption = "基本字段选择"
Height = 2235
Left = 90
TabIndex = 0
Top = 90
Width = 3165
Begin VB.ComboBox Combo2
ForeColor = &H00FF0000&
Height = 300
Left = 1680
Style = 2 'Dropdown List
TabIndex = 4
Top = 780
Width = 1245
End
Begin VB.ComboBox Combo3
ForeColor = &H00FF0000&
Height = 300
Left = 1680
Style = 2 'Dropdown List
TabIndex = 3
Top = 1260
Width = 1245
End
Begin VB.ComboBox Combo4
ForeColor = &H00FF0000&
Height = 300
ItemData = "FRMEXCEL.frx":4C231
Left = 1680
List = "FRMEXCEL.frx":4C233
Style = 2 'Dropdown List
TabIndex = 2
Top = 1740
Width = 1245
End
Begin VB.ComboBox Combo1
ForeColor = &H00FF0000&
Height = 300
Left = 1680
Style = 2 'Dropdown List
TabIndex = 1
Top = 300
Width = 1245
End
Begin ACTIVESKINLibCtl.SkinLabel SkinLabel3
Height = 255
Index = 0
Left = 240
OleObjectBlob = "FRMEXCEL.frx":4C235
TabIndex = 5
Top = 330
Width = 1275
End
Begin ACTIVESKINLibCtl.SkinLabel SkinLabel3
Height = 255
Index = 1
Left = 240
OleObjectBlob = "FRMEXCEL.frx":4C298
TabIndex = 6
Top = 840
Width = 1275
End
Begin ACTIVESKINLibCtl.SkinLabel SkinLabel3
Height = 255
Index = 2
Left = 240
OleObjectBlob = "FRMEXCEL.frx":4C2FB
TabIndex = 7
Top = 1320
Width = 1275
End
Begin ACTIVESKINLibCtl.SkinLabel SkinLabel3
Height = 255
Index = 3
Left = 240
OleObjectBlob = "FRMEXCEL.frx":4C35E
TabIndex = 8
Top = 1830
Width = 1275
End
End
Begin ACTIVESKINLibCtl.SkinLabel SkinLabel3
Height = 225
Index = 4
Left = 120
OleObjectBlob = "FRMEXCEL.frx":4C3C1
TabIndex = 9
Top = 2430
Width = 4425
End
End
Attribute VB_Name = "FRMEXCEL"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim fd As Field
Dim astr As String
Dim dbAdd As Database
Dim db As Database
Dim GYXE As String
Dim rs As Recordset
Dim NUM As Long
Dim FU As Long
Dim STR As String
Dim lssel As String
Dim lssela As String
Private Sub Command1_Click()
On Error Resume Next
Combo1.Clear
Combo4.Clear
Combo2.Clear
Combo3.Clear
Combo1.AddItem "不导入"
Combo2.AddItem "不导入"
Combo3.AddItem "不导入"
Combo4.AddItem "不导入"
Combo6.AddItem "不导入"
Combo7.AddItem "不导入"
Combo9.AddItem "不导入"
Combo11.AddItem "不导入"
List1.Clear
Dim db As DAO.Database
Dim oTD As DAO.TableDef
Dim f As DAO.Field
Set db = Workspaces(0).OpenDatabase(App.Path & "\TEMP\" & HHVI & ".NHB")
Set oTD = db.TableDefs("EXCLE")
With oTD
lCount = .Fields.Count
For lCtr = 0 To lCount - 1
Combo1.AddItem oTD.Fields(lCtr).Name
Combo2.AddItem oTD.Fields(lCtr).Name
Combo3.AddItem oTD.Fields(lCtr).Name
Combo4.AddItem oTD.Fields(lCtr).Name
Combo6.AddItem oTD.Fields(lCtr).Name
Combo7.AddItem oTD.Fields(lCtr).Name
Combo9.AddItem oTD.Fields(lCtr).Name
List1.AddItem oTD.Fields(lCtr).Name
Next
End With
db.Close
Set db = DBEngine.Workspaces(0).OpenDatabase(App.Path & "\TEMP\" & HHVI & ".NHB")
astr = "ALTER TABLE EXCLE ADD COLUMN 不导入 TEXT(15)"
db.Execute astr
Set db = DBEngine.Workspaces(0).OpenDatabase(App.Path & "\TEMP\" & HHVI & ".NHB")
db.Execute "UPDATE EXCLE SET 不导入=''"
db.Close
Combo1.ListIndex = 0
Combo2.ListIndex = 0
Combo3.ListIndex = 0
Combo4.ListIndex = 0
Combo6.ListIndex = 0
Combo7.ListIndex = 0
Combo9.ListIndex = 0
Combo11.ListIndex = 0
List1.ListIndex = 0
End Sub
Private Sub Command2_Click()
On Error GoTo 3061
' Call Command3_Click
' Call Command4_Click
MsgBox "自动导入操作前,程序将删除当前所有已录入的数据！！！", vbOKOnly, "警告！"
Set db = OpenDatabase(App.Path & "\TEMP\" & HHVI & ".NHB")
STR = "DELETE * from NHB"
db.Execute STR
db.Close
Select Case MsgBox("是否真的导入记录吗？", vbOKCancel, "警告！")
Case vbOK
If Combo1.Text = "" Then Combo1.Text = "不导入"
If Combo2.Text = "" Then Combo2.Text = "不导入"
If Combo3.Text = "" Then Combo3.Text = "不导入"
If Combo4.Text = "" Then Combo4.Text = "不导入"
MousePointer = vbHourglass
Set dbAdd = DBEngine.Workspaces(0).OpenDatabase(App.Path & "\TEMP\" & HHVI & ".NHB")
astr = "INSERT INTO NHB (学号,姓名,性别,分数)SELECT EXCLE." & Combo1 & "," & Combo2 & "," & Combo3 & "," & Combo4 & " FROM EXCLE"
dbAdd.Execute astr
dbAdd.Close
Set dbAdd = Nothing
MousePointer = vbDefault
Unload Me
Case Else
Cancel = True
Unload Me
End Select
3061:
Select Case Err.Number
Case 3061
MsgBox "您输入的对应字段为空", 32, "无法导入"
MousePointer = vbDefault
Unload Me
Case 3078
MsgBox "对应字段数有误", 32, "无法导入"
MousePointer = vbDefault
Unload Me
Case 3075
MsgBox "字段有空格,请在EXCEL中更改后再导入", 32, "无法导入"
MousePointer = vbDefault
Unload Me
Case 3346
MsgBox "对应字段数有误", 32, "无法导入"
MousePointer = vbDefault
Unload Me
Case 3063
MsgBox "您选择的字段有重复", 32, "无法导入"
MousePointer = vbDefault
Unload Me
Case 3346
MsgBox "对应字段数有误", 32, "无法导入"
MousePointer = vbDefault
Unload Me
End Select
' '
End Sub
Private Sub Command3_Click()
Unload Me
End Sub
Private Sub Form_Load()
On Error Resume Next
Skin1.ApplySkin Me.hwnd
Call Command1_Click
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
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 + -