<%@ Language="VBScript" CodePage="936" %> <% Option Explicit Server.ScriptTimeout = 600 Response.CodePage = 936 Response.CharSet = "GB2312" Dim conn %> <% Dim action : action = Trim(Request.QueryString("action") & "") If action = "import" Then ProcessImport Else ShowUploadForm "" End If Sub ShowUploadForm(msg) %> 时段目标导入

时段目标导入

<% If msg<>"" Then %>
<%= msg %>
<% End If %>
模板说明：
<% End Sub Sub ProcessImport() Dim binData, strCT, boundary, strData Dim posFileStart, posFileEnd, fileLen, binFileData Dim strFileName, uploadPath If Request.TotalBytes = 0 Then ShowUploadForm "请选择要上传的Excel文件。" : Exit Sub strCT = Request.ServerVariables("HTTP_CONTENT_TYPE") If InStr(1, strCT, "multipart/form-data", 1) = 0 Then ShowUploadForm "表单类型错误，请重新上传。" : Exit Sub binData = Request.BinaryRead(Request.TotalBytes) Dim posBoundaryDef : posBoundaryDef = InStr(1, strCT, "boundary=", 1) If posBoundaryDef = 0 Then ShowUploadForm "无法解析上传数据(boundary)。" : Exit Sub boundary = Mid(strCT, posBoundaryDef + 9) If Left(boundary, 1) = """" Then boundary = Mid(boundary, 2) If Right(boundary, 1) = """" Then boundary = Left(boundary, Len(boundary) - 1) boundary = "--" & boundary strData = BinToLatin1(binData) Dim posFilename : posFilename = InStr(1, strData, "filename=""", 1) If posFilename = 0 Then ShowUploadForm "未找到上传文件，请选择文件后再提交。" : Exit Sub posFilename = posFilename + 10 Dim posFilenameEnd : posFilenameEnd = InStr(posFilename, strData, """", 1) strFileName = Mid(strData, posFilename, posFilenameEnd - posFilename) If InStr(strFileName, "\") > 0 Then strFileName = Mid(strFileName, InStrRev(strFileName, "\") + 1) If InStr(strFileName, "/") > 0 Then strFileName = Mid(strFileName, InStrRev(strFileName, "/") + 1) If LCase(Right(strFileName, 5)) <> ".xlsx" Then ShowUploadForm "只支持.xlsx格式，当前文件：" & Server.HTMLEncode(strFileName) : Exit Sub Dim posHeadersEnd : posHeadersEnd = InStr(posFilenameEnd, strData, vbCrLf & vbCrLf, 1) If posHeadersEnd = 0 Then ShowUploadForm "无法解析文件数据起始位置。" : Exit Sub posFileStart = posHeadersEnd + 4 Dim posEndBoundary : posEndBoundary = InStr(posFileStart, strData, boundary, 1) If posEndBoundary = 0 Then ShowUploadForm "无法解析文件数据结束位置。" : Exit Sub posFileEnd = posEndBoundary - 2 fileLen = posFileEnd - posFileStart If fileLen <= 0 Then ShowUploadForm "上传的文件为空。" : Exit Sub binFileData = MidB(binData, posFileStart, fileLen) Dim tempDir : tempDir = Server.MapPath("./") If Right(tempDir, 1) <> "\" Then tempDir = tempDir & "\" Dim safeTimer : safeTimer = Replace(Timer(), ".", "_") uploadPath = tempDir & "upload_" & safeTimer & "_" & strFileName Dim fs : Set fs = Server.CreateObject("Scripting.FileSystemObject") Dim binStream : Set binStream = Server.CreateObject("ADODB.Stream") binStream.Type = 1 : binStream.Open : binStream.Write binFileData binStream.SaveToFile uploadPath, 2 : binStream.Close : Set binStream = Nothing Dim resultMsg : resultMsg = ImportFromExcel(uploadPath, strFileName) On Error Resume Next : fs.DeleteFile uploadPath, True : On Error Goto 0 Set fs = Nothing ShowResult resultMsg End Sub Function ImportFromExcel(filePath, origFileName) Dim xlsConn, xlsRs, connStr, sql Dim totalRows, successCount, updateCount, failCount, errorRows totalRows = 0 : successCount = 0 : updateCount = 0 : failCount = 0 errorRows = "" connStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & filePath & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1;""" Set xlsConn = Server.CreateObject("ADODB.Connection") On Error Resume Next : xlsConn.Open connStr If Err.Number <> 0 Then Dim errMsg : errMsg = Err.Description Err.Clear : On Error Goto 0 ImportFromExcel = BuildErrorHTML("无法打开Excel文件，请确认服务器已安装ACE.OLEDB.12.0。
错误：" & Server.HTMLEncode(errMsg)) Exit Function End If : On Error Goto 0 sql = "SELECT * FROM [Sheet1$] WHERE F1 IS NOT NULL" Set xlsRs = Server.CreateObject("ADODB.Recordset") On Error Resume Next : xlsRs.Open sql, xlsConn, 0, 1 If Err.Number <> 0 Then errMsg = Err.Description : Err.Clear : On Error Goto 0 xlsConn.Close : Set xlsConn = Nothing ImportFromExcel = BuildErrorHTML("读取Excel数据失败，请确认第1行为标题行。
错误：" & Server.HTMLEncode(errMsg)) Exit Function End If : On Error Goto 0 If xlsRs.BOF And xlsRs.EOF Then xlsRs.Close : Set xlsRs = Nothing : xlsConn.Close : Set xlsConn = Nothing ImportFromExcel = BuildErrorHTML("Excel文件中没有数据行。") : Exit Function End If Dim sCode, sName, sDateRaw, sPeriod, sTarget, sRemark Dim dDate, iPeriod, iTarget, validateErr, isUpdate Do While Not xlsRs.EOF totalRows = totalRows + 1 : validateErr = "" : isUpdate = False sCode = Trim(xlsRs(0) & "") : sName = Trim(xlsRs(1) & "") sDateRaw = Trim(xlsRs(2) & "") : sPeriod = Trim(xlsRs(3) & "") sTarget = Trim(xlsRs(4) & "") : sRemark = Trim(xlsRs(5) & "") If sCode = "" Then validateErr = "商店代码为空" If validateErr = "" And Len(sCode) <> 6 Then validateErr = "商店代码应为6位，当前为" & Len(sCode) & "位" If validateErr = "" Then Dim chkRs : Set chkRs = conn.Execute("SELECT COUNT(*) AS cnt FROM vw_cust_kehu WHERE khdm = N'" & Replace(sCode, "'", "''") & "'") If Not chkRs.EOF Then If CLng(chkRs("cnt")) = 0 Then validateErr = "商店代码 '" & sCode & "' 在客户表中不存在" chkRs.Close : Set chkRs = Nothing End If If validateErr = "" Then dDate = ExcelSerialToDate(sDateRaw) If IsNull(dDate) Or dDate = "" Then validateErr = "日期 '" & sDateRaw & "' 无法解析" End If If validateErr = "" Then If Not IsNumeric(sPeriod) Then validateErr = "时段 '" & sPeriod & "' 不是数字" Else iPeriod = CLng(sPeriod) : If iPeriod < 0 Or iPeriod > 99 Then validateErr = "时段 " & iPeriod & " 超出范围(0-99)" End If End If If validateErr = "" Then If Not IsNumeric(sTarget) Then validateErr = "时段目标 '" & sTarget & "' 不是数字" Else On Error Resume Next : iTarget = CLng(sTarget) If Err.Number <> 0 Then validateErr = "时段目标 '" & sTarget & "' 超出整数范围" : Err.Clear On Error Goto 0 End If End If If validateErr = "" Then Dim existRs : Set existRs = conn.Execute("SELECT COUNT(*) AS cnt FROM [dbo].[时段目标] WHERE [商店代码]=N'" & Replace(sCode, "'", "''") & "' AND [日期]='" & dDate & "' AND [时段]=" & iPeriod) Dim exists : exists = False If Not existRs.EOF Then If CLng(existRs("cnt")) > 0 Then exists = True existRs.Close : Set existRs = Nothing If exists Then conn.Execute "UPDATE [dbo].[时段目标] SET [商店名称]=N'" & Replace(sName, "'", "''") & "',[时段目标]=" & iTarget & ",[备注]=N'" & Replace(sRemark, "'", "''") & "',[更新时间]=GETDATE() WHERE [商店代码]=N'" & Replace(sCode, "'", "''") & "' AND [日期]='" & dDate & "' AND [时段]=" & iPeriod updateCount = updateCount + 1 : isUpdate = True Else conn.Execute "INSERT INTO [dbo].[时段目标] ([商店代码],[商店名称],[日期],[时段],[时段目标],[备注],[更新时间]) VALUES (N'" & Replace(sCode, "'", "''") & "',N'" & Replace(sName, "'", "''") & "','" & dDate & "'," & iPeriod & "," & iTarget & ",N'" & Replace(sRemark, "'", "''") & "',GETDATE())" successCount = successCount + 1 End If End If If validateErr <> "" Then failCount = failCount + 1 errorRows = errorRows & "" & totalRows & "" & Server.HTMLEncode(sCode) & "" & Server.HTMLEncode(sName) & "" & Server.HTMLEncode(sDateRaw) & "" & Server.HTMLEncode(sPeriod) & "" & Server.HTMLEncode(sTarget) & "" & Server.HTMLEncode(validateErr) & "" End If xlsRs.MoveNext Loop xlsRs.Close : Set xlsRs = Nothing : xlsConn.Close : Set xlsConn = Nothing ImportFromExcel = BuildResultHTML(origFileName, totalRows, successCount, updateCount, failCount, errorRows) End Function Function ExcelSerialToDate(serialStr) If serialStr = "" Or Not IsNumeric(serialStr) Then ExcelSerialToDate = Null : Exit Function Dim dblSerial : dblSerial = CDbl(serialStr) Dim intDays : intDays = Int(dblSerial) Dim dblTime : dblTime = dblSerial - intDays Dim h, m, s h = Int(dblTime * 24) : m = Int((dblTime * 24 - h) * 60) : s = Int(((dblTime * 24 - h) * 60 - m) * 60) Dim dt : dt = DateAdd("d", intDays, "1899-12-30") ExcelSerialToDate = Year(dt) & "-" & Month(dt) & "-" & Day(dt) & " " & Right("0" & h, 2) & ":" & Right("0" & m, 2) & ":" & Right("0" & s, 2) End Function Function BinToLatin1(binData) Dim stream : Set stream = Server.CreateObject("ADODB.Stream") stream.Type = 1 : stream.Open : stream.Write binData : stream.Position = 0 stream.Type = 2 : stream.Charset = "windows-1252" BinToLatin1 = stream.ReadText : stream.Close : Set stream = Nothing End Function Function BuildErrorHTML(msg) BuildErrorHTML = "错误" & _ "

导入错误

" & _ "
" & msg & "
" & _ "返回重试
" End Function Function BuildResultHTML(fileName, total, success, updateCount, fail, errHTML) Dim html html = "导入结果" & vbCrLf html = html & "" & vbCrLf html = html & "
" & vbCrLf html = html & "

导入结果

" & vbCrLf html = html & "

文件：" & Server.HTMLEncode(fileName) & "

" & vbCrLf html = html & "
" & vbCrLf html = html & "
" & total & "
总行数
" & vbCrLf html = html & "
" & success & "
新增
" & vbCrLf html = html & "
" & updateCount & "
更新覆盖
" & vbCrLf html = html & "
" & fail & "
失败
" & vbCrLf html = html & "
" & vbCrLf If fail > 0 Then html = html & "

失败明细：

" & vbCrLf html = html & "" & vbCrLf html = html & errHTML & vbCrLf html = html & "
#商店代码商店名称日期(原始)时段时段目标错误原因
" & vbCrLf End If html = html & "返回继续导入" & vbCrLf html = html & "
" BuildResultHTML = html End Function Sub ShowResult(html) : Response.Write html : End Sub %>