Private Sub ExportExcelSheetToAccess(sSheetName As String, _
sExcelPath As String, sAccessTable As String, sAccessDBPath As String)
Dim db As Database
Dim rs As Recordset
Set db = OpenDatabase(sExcelPath, True, False, "Excel 5.0")
Call db.Execute("Select * into [;database=" & sAccessDBPath & "]." & _
sAccessTable & " FROM [" & sSheetName & "$]")
MsgBox "Table exported successfully.", vbInformation, "Yams"
End Sub
使用范例如下:將 C:\book1.xls 中的 Sheet1 导入 C:\Test.mdb 成为 TestTable
Private Function CopyExcelInfo(ByRef pcnnSvr As ADODB.Connection, _
ByRef pEInfo As ExcelInfo, _
ByVal pKdCode As String, ByVal strBC As String, _
ByVal lngRow As Long, ByVal pObj As Object) As Boolean
'// 作 者:Colin Hans
'// 日 期:2003-07-29 00:55:31
Dim strSql As String
Dim strEID As String
Dim rstTmp As New ADODB.Recordset
Dim cmd As New ADODB.Command
Dim isOk As Boolean
Dim lngCount As Long
Dim lngTmp As Long
Dim lngTmp1 As Long
Dim lngCount1 As Long
Dim intpos As Integer
Dim k As Integer
Dim lngXh As Long
Dim prgTmp As Object
Dim strTmp As String
Dim pxdName As String
Dim strSfzh As String
Dim strLxdh As String
Dim strName As String
Dim strJxjylb As String
Dim strJxjyjb As String
Dim strDwmc As String
Dim strJxjynd As String
Dim strKjzyzg As String
Dim strXl As String
Dim strXzq As String
Dim strShy As String
Dim dtType As ADODB.DataTypeEnum
On Error GoTo PROC_ERR
Set prgTmp = CreateObject("Common.CProgressBar")
strSql = "Select * from Tester Where Testercode='" & _
pKdCode & "'"
isOk = InitRecordset(rstTmp, strSql, pcnnSvr)
If Not isOk Then GoTo PROC_ERR
Select Case rstTmp.RecordCount
Case Is = 0
MsgBox "请设置考点数据!", vbExclamation, "系统信息"
GoTo PROC_ERR
Case Is = 1
pxdName = rstTmp.Fields("Tester")
If MsgBox("是否删除以前导入的数据?", vbQuestion + vbYesNo, "系统信息!") = vbYes Then
pcnnSvr.Execute "Delete from Examinee Where ImportCode='" & pKdCode & "'"
End If
Case Else
pxdName = ""
End Select
rstTmp.Close
strSql = "select count(*) as SumNumber from examinee"
isOk = InitRecordset(rstTmp, strSql, pcnnSvr)
If Not isOk Then GoTo PROC_ERR
If rstTmp.RecordCount > 0 And Not IsNull(rstTmp.Fields("SumNumber")) And rstTmp.Fields("sumNumber") > 0 Then
lngXh = rstTmp.Fields("SumNumber") + 1
Else
lngXh = 1
End If
rstTmp.Close
If lngRow > 1 Then
prgTmp.Min = 0
prgTmp.Max = lngRow
prgTmp.Caption = " 正在复制Excel信息到服务器, 请稍候..."
prgTmp.Show
End If
For lngTmp = mStartRow To lngRow + 1 '
If Asc(Right(pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(1).Col), 1)) = 255 Then
strEID = CStr(Left(CStr(pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(1).Col)), _
Len(CStr(pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(1).Col))) - 1))
Else
strEID = CStr(pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(1).Col))
End If
strSql = "Select * from Examinee Where EID='" & _
strEID & "'"
isOk = InitRecordset(rstTmp, strSql, pcnnSvr)
If Not isOk Then GoTo PROC_ERR
If rstTmp.RecordCount < 1 Then rstTmp.AddNew
k = Int(Rnd * 100)
rstTmp.Fields("ordid") = k
rstTmp.Fields("EID") = strEID
strName = pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(2).Col)
rstTmp.Fields("name") = strName
strJxjylb = pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(3).Col)
rstTmp.Fields("jxjylb") = strJxjylb
strJxjyjb = pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(4).Col)
rstTmp.Fields("jxjyjb") = strJxjyjb
strSql = "Select * from TestSetup Where TesterCode='" & pKdCode & "'"
isOk = InitRecordset(rstTmp, strSql, pcnnSvr)
If isOk Then
If rstTmp.RecordCount >= 1 Then
If MsgBox("该考点的场次信息已存在,是否删除此场次信息?", vbQuestion + vbYesNo) = vbYes Then
strSql = "Delete from TestSetup Where TesterCode='" & pKdCode & "'"
pcnnSvr.Execute strSql
End If
End If
End If
Exit Function
PROC_ERR:
CopyExcelInfo = False
End Function
Private Function InitRecordset(ByRef rstTmp As ADODB.Recordset, ByVal strSql As String, _
ByRef mcnnObj As ADODB.Connection) As Boolean
On Error GoTo PROC_ERR
With rstTmp
Set .ActiveConnection = mcnnObj
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open strSql
End With
PROC_EXT:
InitRecordset = True
Exit Function
PROC_ERR:
InitRecordset = False
End Function
Private Function GetColInfo(ByRef pObj As Object, _
ByRef pEInfo As ExcelInfo, ByVal strBC As String) As Integer
'// 作 者:Colin Hans
'// 日 期:2003-07-28 22:16:58
Dim strTmp As String
Dim lngTmp As Long
Dim lngCount As Long
Dim rstTmp As New ADODB.Recordset
Dim strSql As String
Dim isOk As Boolean
Dim strYes As String
Dim i As Integer
On Error GoTo PROC_ERR
For lngTmp = 1 To 255
strTmp = pObj.sheets(1).cells(lngTmp, 1)
If strBC = "" Then
If UCase(strTmp) = UCase("xh") Then
mStartRow = lngTmp + 1
Exit For
End If
Else
If UCase(strTmp) = UCase("Eid") Then
mStartRow = lngTmp + 1
Exit For
End If
End If
Next lngTmp
If mStartRow >= 255 Then GoTo PROC_ERR
For lngTmp = mStartRow To mStartRow + 32767
strTmp = pObj.sheets(1).cells(lngTmp, 4)
strTmp = Trim(strTmp)
If Len(strTmp) = 0 Then
mRowsCount = lngTmp - mStartRow
Exit For
End If
Next lngTmp
If lngTmp >= 32767 Then GoTo PROC_ERR
If lngTmp = mStartRow Then
GetColInfo = 0
Exit Function
End If
For lngTmp = 1 To FeildCount
strTmp = pObj.sheets(1).cells(mStartRow - 1, lngTmp)
Select Case UCase(strTmp)
Case Is = UCase("bmrq")
i = 6
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("xm")
i = 2
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("Name")
i = 2
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("sysno") '//eid
i = 1
pEInfo.Feilds(i).Col = lngTmp
eidCol = lngTmp
strTmp = pObj.sheets(1).cells(2, 4)
strSql = "select eid from examinee where eid='" & strTmp & "'"
isOk = mCommon.gcomnTmp.InitRecordset(rstTmp, strSql)
If Not isOk Then GoTo PROC_ERR
If rstTmp.RecordCount > 0 Then
strYes = MsgBox("该考点数据已经存在!是否要覆盖?", vbYesNo, "系统提示")
If strYes = vbNo Then
GetColInfo = 0
Exit Function
End If
End If
Case Is = UCase("Eid")
i = 1
pEInfo.Feilds(i).Col = lngTmp
eidCol = lngTmp
strTmp = pObj.sheets(1).cells(2, 1)
If strBC = pObj.sheets(1).cells(2, 10) Then
strSql = "select eid from examinee where eid='" & strTmp & "'"
isOk = mCommon.gcomnTmp.InitRecordset(rstTmp, strSql)
If Not isOk Then GoTo PROC_ERR
If rstTmp.RecordCount > 0 Then
strYes = MsgBox("该考点数据已经存在!是否要覆盖?", vbYesNo, "系统提示")
If strYes = vbNo Then
GetColInfo = 0
Exit Function
End If
End If
End If
Case Is = UCase("sfzh")
i = 5
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("dwmc")
i = 7
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("lxdh")
i = 8
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("bc")
i = 9
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("fdd2")
i = 15
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("kssj")
i = 15
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("shy")
i = 14
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("xl")
i = 12
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("kjzyzg")
i = 11
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("jxjynd")
i = 10
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("jxjylb")
i = 3
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("jxjyjb")
i = 4
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("xzq")
i = 13
pEInfo.Feilds(i).Col = lngTmp
Case Else
End Select
Next lngTmp
PROC_EXT:
GetColInfo = mRowsCount
Exit Function
PROC_ERR:
GetColInfo = False
End Function
Option Explicit
Private Const FeildCounts = 15
Private Const FeildCount = 28
Private Type FeildInfo
Col As Integer
End Type
Private Type ExcelInfo
Feilds(1 To FeildCounts) As FeildInfo
End Type
Private mStartRow As Long
Private mRowsCount As Long
Private eidCol As Integer
Public Function ImportKS(ByRef pcnnSvr As ADODB.Connection) As Boolean
'// 作 者:Colin Hans
'// 日 期:2003-07-28 21:22:55
Dim dlgTmp As Object
Dim exlTmp As Object
Dim mEInfo As ExcelInfo
Dim frmTmp As New FTime
' Dim tmpFrm As New frmQueKao
Dim lngRow As Long
Dim lngCol As Long
Dim strFile As String
Dim isOk As Boolean
Dim strYes As String
Dim strSql As String
Dim strKdCode As String
Dim iPos As Integer
Dim strName As String
Dim strBC As String
On Error GoTo PROC_ERR
'//Init Var
mStartRow = 0
mRowsCount = 0
Load frmTmp
Set dlgTmp = frmTmp.Cdlg
If Dir(strFile, vbNormal) = "" Then
MsgBox "无法找到指定的Excel文件,系统将中止操作。", _
vbCritical, "系统提示!"
GoTo PROC_ERR
End If
iPos = InStrRev(strFile, "\")
If iPos = 0 Then GoTo PROC_ERR
strKdCode = Right(strFile, Len(strFile) - iPos)
strName = Left(strKdCode, 2)
If strName = "缺考" Then
' Load tmpFrm
'
' tmpFrm.Show 1
'
' If Not tmpFrm.mIsok Then
' ImportKS = False
' Load tmpFrm
' Exit Function
' End If
strKdCode = mID(strKdCode, 3, Len(strKdCode))
iPos = InStr(1, strKdCode, "_")
If iPos = 0 Then GoTo PROC_ERR
strKdCode = Left(strKdCode, iPos - 1)
' strBC = tmpFrm.txtBc
Else
strBC = ""
End If
If strBC = "" Then
iPos = InStr(1, strKdCode, ".")
If iPos = 0 Then GoTo PROC_ERR
strKdCode = Left(strKdCode, iPos - 1)
If Len(strKdCode) < 1 Then GoTo PROC_ERR
End If
Set exlTmp = GetObject(strFile)
lngRow = GetColInfo(exlTmp, mEInfo, strBC)
If lngRow = 0 Then Exit Function
isOk = CopyExcelInfo(pcnnSvr, mEInfo, strKdCode, strBC, lngRow, exlTmp)
If Not isOk Then
MsgBox "复制Excel信息到服务器时出错,系统将中止操作。", _
vbCritical, "系统提示!"
GoTo PROC_ERR
End If
PROC_EXT:
ImportKS = True
Exit Function
PROC_ERR:
ImportKS = False
End Function
Public Sub saveExcelInput()
With dlgExcelSave
.FileName = ""
.CancelError = True
.DialogTitle = "保存"
.Filter = "Excel数据文件|*.xls"
On Error GoTo aaa
.ShowSave
End With
If Dir(dlgExcelSave.FileName) <> "" Then
If MsgBox("¡°" & dlgExcelSave.FileName & "¡±ÎļþÒѾ´æÔÚ£¬ÊÇ·ñ´ú»»£¿", 16 + vbYesNo, "ÌáÎÊ") = vbYes Then
Kill dlgExcelSave.FileName
Else
Exit Sub
End If
End If
Dim i As Integer
Dim exstring As String
Dim exConn As ADODB.Connection
Dim exRs As ADODB.Recordset
Dim exPath As String
Dim exName As String
Dim exPos As Integer
'''
Dim rs As ADODB.Recordset
Dim sql As String
Dim j As Integer
Set rs = New ADODB.Recordset
sql = "select * from " & sqlTable
conndbOpen
rs.Open sql, conn, 1, 1
If rs.RecordCount = 0 Then
MsgBox "ûÓÐÊý¾Ý£¬µ«Äܵ¼³öÊý¾Ý¿â½á¹¹£¡", 48, "Ìáʾ"
End If
ProgressExcel.Visible = True
ProgressExcel.Max = rs.RecordCount
If sqlTable = "Apparatus" Or sqlTable = "Consignment" Then '''µ±Ñ¡ÔñÁ˱íApparatus»òÕßConsignmentµÄʱºò
Do While Not rs.EOF
exRs.AddNew
For i = 0 To ListFieldPrint.ListCount - 1
If ListFieldPrint.List(i) = "Ê¡±àºÅ" Then '''»ñµÃÊ¡Ãû
Dim Prs As ADODB.Recordset
Dim Psql As String
Set Prs = New ADODB.Recordset
Psql = "select * from Province where Ê¡±àºÅ='" & rs.Fields("" & ListFieldPrint.List(i) & "").Value & "'"
Prs.Open Psql, conn, 1, 1
If Not (Prs.BOF And Prs.EOF) Then
exRs.Fields(i).Value = Prs.Fields("Ê¡Ãû").Value
Else
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
End If
ElseIf ListFieldPrint.List(i) = "ÊбàºÅ" Then '''»ñµÃ³ÇÊÐÃû
Dim Crs As ADODB.Recordset
Dim Csql As String
Set Crs = New ADODB.Recordset
Csql = "select * from City where ÊбàºÅ='" & rs.Fields("" & ListFieldPrint.List(i) & "").Value & "'"
Crs.Open Csql, conn, 1, 1
If Not (Crs.BOF And Crs.EOF) Then
exRs.Fields(i).Value = Crs.Fields("ÊÐÃû").Value
Else
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
End If
ElseIf ListFieldPrint.List(i) = "µ¥Î»±àºÅ" Then '''»ñµÃµ¥Î»Ãû
Dim Srs As ADODB.Recordset
Dim Ssql As String
Set Srs = New ADODB.Recordset
Ssql = "select * from School where µ¥Î»´úÂë='" & rs.Fields("" & ListFieldPrint.List(i) & "").Value & "'"
Srs.Open Ssql, conn, 1, 1
If Not (Srs.BOF And Srs.EOF) Then
exRs.Fields(i).Value = Srs.Fields("µ¥Î»").Value
Else
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
End If
Else
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
End If
Next
exRs.Update
j = j + 1
ProgressExcel.Value = j
rs.MoveNext
Loop
Else
Do While Not rs.EOF
exRs.AddNew
For i = 0 To ListFieldPrint.ListCount - 1
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
Next
exRs.Update
j = j + 1
ProgressExcel.Value = j
rs.MoveNext
Loop
End If
MsgBox "µ¼³öÍê³É£¡", 64, "Ìáʾ"
' ProgressExcel.Value = 0
'''
Prs.Close
Set Prs = Nothing
Crs.Close
Set Crs = Nothing
Srs.Close
Set Srs = Nothing
rs.Close
Set rs = Nothing
conn.Close
Set conn = Nothing
exRs.Close
Set exRs = Nothing
exConn.Close
Set exConn = Nothing
aaa:
' Exit Sub
End Sub