如果提示“找不到可安装的ISAM”参考我下一个文章
Sub TrnSAAccDataImExcel()
Dim sDept As String = ""
Dim sCode As String = ""
Try
Dim connectionString As String = ""
Dim strSQL As String = ""
Dim BInfoQ_str As String = ""
Dim rDepartment_id As String = ""
Dim i As Integer = 0
Dim j As Integer = 0
Dim sInsertSQL As String = ""
Dim BInfoQConn As Status.PowerKernel.Connection = New Status.PowerKernel.Connection
Dim BInfoQRs As ADODB.Recordset = New ADODB.Recordset
Dim BInfoQCount As Integer = 0
Dim sm As String = "0"
Dim monthisnull As String = ""
Dim smnum As String = "" '金额
Dim strBudgetCode As String = "" '科目代码
'connectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" + Me.ViewState("SourcePath") + ";Extended Properties=Excel 8.0;"
'connectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Me.ViewState("SourcePath") & ";Extended Properties=""Excel 8.0;HDR=Yes;IMEX=1"""
connectionString = "Provider=Microsoft.Ace.OleDb.12.0;" + "data source=" + Me.ViewState("SourcePath") + ";Extended Properties='Excel 12.0; HDR=Yes; IMEX=1'"
Dim excelConnection As OleDbConnection = New OleDbConnection(connectionString)
strSQL = "SELECT * FROM [Sheet1$]"
excelConnection.Open()
Dim dbCommand As OleDbCommand = New OleDbCommand(strSQL, excelConnection)
Dim dataAdapter As OleDbDataAdapter = New OleDbDataAdapter(dbCommand)
Dim dTable As DataTable = New DataTable()
dataAdapter.Fill(dTable)
Dim stryear As String = "" '要导入的文档第一行的年
Dim strdeptcode As String = "" '要导入的文档第一行的部门代码
stryear = dTable.Rows(0).Item(0).ToString().Trim() '取到的年份
strdeptcode = dTable.Rows(0).Item(1).ToString().Trim() ' 取到的部门代码，默认是去0的，再补0够10位
Dim strdeptcodeLength As Integer = strdeptcode.Length '部门代码的长度
Dim strendcode As String = "" '存放部门不足10位时候的0的个数
If strdeptcodeLength < 10 Then
For i = 0 To 10 - strdeptcodeLength - 1
strendcode += "0"
Next
End If
strdeptcode = strendcode & strdeptcode '最终拼接成的10位部门 代码
'根据部门编码取部门ID
BInfoQConn = New Status.PowerKernel.Connection
BInfoQRs = Nothing
BInfoQCount = 0
BInfoQ_str = ""
BInfoQ_str = "select department_id from department where dept_code = '" & strdeptcode & "'; "
BInfoQRs = BInfoQConn.OpenRs(BInfoQ_str, "2")
BInfoQCount = 0
BInfoQCount = BInfoQRs.RecordCount
If BInfoQCount > 0 Then
rDepartment_id = BInfoQRs.Fields.Item("department_id").Value
End If
'根据部门编码取部门ID
'一：如果是当前月以前的月份，则忽略不导入
'二：如果是当前月以后的数据，先判断数据库里有没有存在，有存在则更新此行数据
Dim nowyear As String '当前年
Dim nowmonth As String '当前月
nowyear = DateTime.Today.Year()
nowmonth = DateTime.Today.Month()
i = 0
For i = 0 To dTable.Rows.Count() - 1
strBudgetCode = dTable.Rows(i).Item(1).ToString().Trim() '取每行第二列的科目代码
If rDepartment_id <> "" And strBudgetCode <> "" Then
Dim linsimonth As String = IIf(nowmonth.ToString().Length = 1, "0" & nowmonth.ToString(), nowmonth.ToString()) '检查临时当前月份是一位数，则在前面补0
If dTable.Rows.Count() > 4 Then '先删除当前月及以以后月的预算数据。再循环增加
Dim delbudgetsql As String = "delete from budget where annual='" & nowyear & "' and month>='" & linsimonth & "' AND Department_id ='" & rDepartment_id & "' AND Budget_Code = '" & strBudgetCode & "' "
BInfoQConn.Commit(delbudgetsql, 0)
End If
End If
monthisnull = dTable.Rows(i).Item(1).ToString().Trim() '这里判断科目代码是否为空格，是空格则此行都不存入数据库
If monthisnull = "" Then '如果此行是空，则不操作
Else
If rDepartment_id <> "" Then
If i > 1 Then '从第三行开遍历
For j = 2 To 13 '循环每行的12个月的列
recordMonth = IIf((j - 1).ToString().Length = 1, "0" & (j - 1).ToString(), (j - 1).ToString()) '检查如果Excel里的月份是一位数，则在前面补0
Dim isindb As String = "0"
'如果Excel里当前列的月份大于当前月，或者当前列的年份大于当前年，才存入数据库，否则不存入数据库
If (stryear = nowyear And Convert.ToInt32(recordMonth) >= Convert.ToInt32(nowmonth)) Or (stryear > nowyear) Then '如果Excel里当前列的月份大于当前月，才存入数据库，否则不存入数据库
isindb = "1"
End If
If isindb = "1" Then
smnum = dTable.Rows(i).Item(j).ToString().Trim()
'sm = IIf(smnum = "", "0", smnum) '预算金额
If smnum = "" Then
Else '如果金额有填写。才存入数据库
sInsertSQL = sInsertSQL + " if not exists (select * from Budget where Annual='" & stryear & "' and Month='" & recordMonth & "' and Department_id='" & rDepartment_id & "' and Budget_Code='" & strBudgetCode & "' ) begin "
sInsertSQL = sInsertSQL & " Insert Into Budget ( Annual,Month,Department_id,Budget_Code,Budget_Amount,Modify_Employ,Modify_Date ) Values ("
sInsertSQL = sInsertSQL & " '" & stryear & "','" & recordMonth & "','" & rDepartment_id & "','" & strBudgetCode & "'," & smnum & ",'" & Session("Login_Employ_No") & "',getdate() )"
sInsertSQL = sInsertSQL & " end "
sInsertSQL = sInsertSQL & " else "
sInsertSQL = sInsertSQL & " begin "
'sInsertSQL = sInsertSQL & " update Budget SET Budget_Amount='" & sm & "',Modify_Employ='" & Session("Login_Employ_No") & "',Modify_Date=getdate() where Annual='" & stryear & "' and Month='" & recordMonth & "' and Department_id='" & rDepartment_id & "' and Budget_Code='" & strBudgetCode & "' "
sInsertSQL = sInsertSQL & " update Budget SET Budget_Amount=" & smnum & "+(select Budget_Amount from budget where Annual='" & stryear & "' and Month='" & recordMonth & "' and Department_id='" & rDepartment_id & "' and Budget_Code='" & strBudgetCode & "' ),Modify_Employ='" & Session("Login_Employ_No") & "',Modify_Date=getdate() where Annual='" & stryear & "' and Month='" & recordMonth & "' and Department_id='" & rDepartment_id & "' and Budget_Code='" & strBudgetCode & "' "
sInsertSQL = sInsertSQL & " end; "
End If
End If
Next
End If
End If
End If
Next
'Response.Write("<script language='javascript' type='text/javascript'>window.open(" & sInsertSQL & "); </script>")
My.Computer.FileSystem.WriteAllText("D:\a1.txt", sInsertSQL, True)
dTable.Dispose()
dataAdapter.Dispose()
dbCommand.Dispose()
excelConnection.Close()
excelConnection.Dispose()
objImportSQL(sInsertSQL) '调用执行批量SQL的方法
Response.Write("<script>alert('转入资料成功!!');</script>")
Catch ex As Exception
Response.Write("<script>alert('无资料转入，'" & ex.Message & "'，请重新執行!!');</script>")
End Try
End Sub
