JaAcc_Excel.Asp

<!--#include file=common.asp-->
<%
'**********************************************
'       Code by ASP导出EXCEL通用
' 修改引用 By 子言(JaStudio)
' QQ:23638564 Email:kpggdf@163.com
' web:www.gdsspt.com    
'**********************************************
Dim xibua
Dim mysql
xibua = Request.QueryString("ids")
if xibua="all" Then
mysql = "select * from singup"
Else
mysql = "select * from singup where [系部]='"&xibua&"'"
End If
server.scripttimeout=100000   '处理时间较长，设置值应大一点
On Error Resume Next
set objExcelApp = CreateObject("Excel.Application")
objExcelApp.DisplayAlerts = false
objExcelApp.Application.Visible = false
objExcelApp.WorkBooks.add
set objExcelBook = objExcelApp.ActiveWorkBook
set objExcelSheets = objExcelBook.Worksheets
set objSpreadsheet = objExcelBook.Sheets(1)
Dim objRS
Set objRS = Server.CreateObject("ADODB.Recordset")
objRS.Open mysql,conn,1,3
If objRS.EOF then
response.write("Error")
respose.end
End if

Dim objField, iCol, iRow
iCol = 1  '取得列号
iRow = 1 '取得行号
objSpreadsheet.Cells(iRow, iCol).Value = ""&xibua&"部的报名情况"  '单元格插入数据
objSpreadsheet.Columns(iCol).ShrinkToFit=true  '设定是否自动适应表格单元大小(单元格宽不变）
'设置Excel表里的字体
objSpreadsheet.Cells(iRow, iCol).Font.Bold = True  '单元格字体加粗
objSpreadsheet.Cells(iRow, iCol).Font.Italic = False  '单元格字体倾斜
objSpreadsheet.Cells(iRow, iCol).Font.Size = 20  '设置单元格字号
objSpreadsheet.Cells(iRow, iCol).ParagraphFormat.Alignment=1 '设置单元格对齐格式:居中
objspreadsheet.Cells(iRow,iCol).font.name="宋体" '设置单元格字体
objspreadsheet.Cells(iRow,iCol).font.ColorIndex=2 '设置单元格文字的颜色，颜色可以查询，2为白色
objSpreadsheet.Range("A1:F1").merge   '合并单元格(单元区域)
objSpreadsheet.Range("A1:F1").Interior.ColorIndex = 1  '设计单元络背景色
'objSpreadsheet.Range("A2:F2").WrapText=true '设置字符回卷（自动换行）
iRow=iRow+1
For Each objField in objRS.Fields
'objSpreadsheet.Columns(iCol).ShrinkToFit=true
objSpreadsheet.Cells(iRow, iCol).Value = objField.Name
'设置Excel表里的字体
objSpreadsheet.Cells(iRow, iCol).Font.Bold = True
objSpreadsheet.Cells(iRow, iCol).Font.Italic = False
objSpreadsheet.Cells(iRow, iCol).Font.Size = 20
objSpreadsheet.Cells(iRow, iCol).Halignment = 2 '居中
iCol = iCol + 1
Next 'objField
'Display all of the data
Do While Not objRS.EOF
iRow = iRow + 1
iCol = 1
For Each objField in objRS.Fields
If IsNull(objField.Value) then
objSpreadsheet.Cells(iRow, iCol).Value = ""
Else
objSpreadsheet.Columns(iCol).ShrinkToFit=true
objSpreadsheet.Cells(iRow, iCol).Value = objField.Value
objSpreadsheet.Cells(iRow, iCol).Halignment = 2
objSpreadsheet.Cells(iRow, iCol).Font.Bold = False
objSpreadsheet.Cells(iRow, iCol).Font.Italic = False
objSpreadsheet.Cells(iRow, iCol).Font.Size = 10
'objSpreadsheet.Cells(iRow, iCol).Halignment = 2
objSpreadsheet.Cells(iRow, iCol).ParagraphFormat.Alignment=1
End If
iCol = iCol + 1
Next    'objField
objRS.MoveNext
Loop

Dim SaveName
SaveName=xibua
Dim objExcel
Dim ExcelPath
ExcelPath = "" & SaveName & ".xls"
objExcelBook.SaveAs server.mappath(ExcelPath)
Response.Write "<center><b>导出成功,请选择继续操作</b></center>"
response.Write "<table width=90% bgcolor=gray bgcolor=CCCCCC cellspacing=1 cellpadding=3 align=center>"
Response.Write "<tr align=center bgcolor=#6699CC style=color:white> <td>"
response.write("<font color=green>√</font><a href='" & ExcelPath & "'>下载 </a>") & "&nbsp;&nbsp;<font color=green>√</font><A href=javascript:history.back()>返回上一页</a>"
Response.Write "</td></tr></table>"
objExcelApp.Quit
set objExcelApp = Nothing
%>

JaExcel_Acc.Asp

<style>
td,input,select,textarea,body{font-size:9pt}
a{color:blue}
a:hover{color:green}
</style>
<%
if session("xibu")="administrator" then
'**********************************************
'       Code by 子言(JaStudio)
' 作用:ASP操作Excel导入ACCESS
' QQ:23638564 Email:kpggdf@163.com
' web:www.gdsspt.com
'       编写时间:2005.03.13 历时:4小时 文件 JaExcel.Asp JaAcc_Save.Asp
'       难点:Excel文件无确定字段的数据处理
'       解决方法: 循环输出所有,分开处理写进ACCESS    
'**********************************************
If Request.QueryString("action")="do" Then
Dim conn
Dim StrConn
Dim Rs
Dim Sql
Dim i
Dim ExName
ExName = Request.Form("ExName")
ExTName = Request.Form("ExTName")
Set conn =Server.CreateObject("ADODB.Connection")
StrConn="Driver={Microsoft Excel Driver (*.xls)};DBQ="& Server.MapPath("Excel/"&ExName)
conn.Open StrConn
Set rs = Server.CreateObject("ADODB.Recordset")
Sql="select * from ["&ExTName&"$]"
rs.Open Sql,conn,1,1
%>
<center>[ <a href=admin.asp?action=exit>注销</a> | <a href=admin.asp>管理首页</a> | <a href=admin_item.asp>系统设置</a> <a href=javascript:backup()>备份数据库</a> | <a href=admin_JaMo.asp>报名模块编辑</a> | <a href=admin_JaSys.asp>系统帮助编辑</a> | <a href=admin_JaShow.asp>报名信息编辑</a> | <a href=JaExcel_Acc.Asp>导入Excel数据到ACCESS</a> ]</center>
<br/>
<form method=post action="JaAcc_Save.Asp" name=form1 onSubmit="return chk(this)">
<table width="500" border="0" align=center cellspacing=1 bgcolor=#CCCCCC>
<tr align=center height=20 bgcolor=#6699CC style=color:white>
      <td colspan="4">导入数据列表(请确保字段没有错误)</td>
    </tr>
  <tr>
<td align="center">
<input name=Count type=hidden value="<%=rs.Fields.Count%>">
<%
for i=0 to rs.Fields.Count-1
%>
<input name=ExFName<%=i%> value="<%=Rs(i).Name%>" size="10">
<%
Next
Response.Write "</td></tr></table><table width=500 border=0 align=center cellspacing=1 bgcolor=#CCCCCC>"
Response.Write "<tr bgcolor=white><td align=center>"
Dim a
a=0
do while not rs.eof
for i=0 to rs.Fields.Count-1
if i mod rs.Fields.Count = 0 then
Response.Write "<br/>"
End if
%>
<input name=ExCName<%=a%> value="<%=Rs(i)%>" size="10">

<%
a = a +1
next
rs.MoveNext
Loop
Response.Write "</td></tr><tr><td align=center><input name='A' type=hidden value="&a&"><input type=submit value=导入数据></td></tr></table>"
Response.Write "</form>"
rs.close
set rs=nothing
conn.close
set StrConn=nothing
Response.End
End if
%>

<style>
td,input,select,textarea,body{font-size:9pt}
a{color:blue}
a:hover{color:green}
</style>

<script language="JavaScript" type="text/JavaScript">
function chk()
{
  if (document.form1.ExName.value=="")
  {
    alert("Excel文件名称不能为空！");
    document.form1.ExName.focus();
    return false;
  }
    if (document.form1.ExTname.value=="")
  {
    alert("Excel数据表文件名称不能为空！");
    document.form1.ExTname.focus();
    return false;
  }
}
</script>

<center>[ <a href=admin.asp?action=exit>注销</a> | <a href=admin.asp>管理首页</a> | <a href=admin_item.asp>系统设置</a> <a href=javascript:backup()>备份数据库</a> | <a href=admin_JaMo.asp>报名模块编辑</a> | <a href=admin_JaSys.asp>系统帮助编辑</a> | <a href=admin_JaShow.asp>报名信息编辑</a> | <a href=JaExcel_Acc.Asp>导入Excel数据到ACCESS</a> ]</center>
<br/>
<table width="500" align=center cellpadding=5 cellspacing=1 bgcolor=#006699>
<tr bgcolor=#6699CC style=color:white align=center>
<td>
<b>导入数据注意事项</b><br/>
1:请确保你清楚Excel文件内容字段与导入数据库的字段相同<p>
2:请确保你清楚Excel文件的表名正确 如 Sheet1<p>
3:请确保服务器上有该Excel文件存在于Excel文件夹里，如没有，请上传并记下文件名称<p>
4:如有不明白请参考Excel文件夹里的[副本学生信息资料.xls],如填写：[Excel地址:副本学生信息资料.xls] [Excel导入数据表名:学生信息]<p>
5:如有不明白可以直接联系我获得技术支持： QQ23638564 Email:kpggdf@163.com
</td>
</tr>
</table>
<form method="post" action="upload2.asp" enctype="multipart/form-data" name="form2">
<table width="500" align=center cellpadding=5 cellspacing=1 bgcolor=#006699>
<tr bgcolor=#6699CC style=color:white align=center>
<td>
<input type=file name="sf_upfile" size="30" class=box>
<input type="submit" name="submit" value="上 传" class="box">
</td>
</tr>
</table>
</form>
</body></html>
<form method=post action="?action=do" name=form1 onSubmit="return chk(this)">
  <table width="500" align=center cellpadding=5 cellspacing=1 bgcolor=#006699>
    <tr bgcolor=#6699CC style=color:white align=center>
      <td width="183">Excel地址(如:JaStudio.xls)</td>
      <td width="217">Excel导入数据表名 (如:Sheet1)</td>
      <td width="64"></td>
    </tr>
    <tr bgcolor=white>
      <td><input name=ExName value="" size="30"></td>
      <td><input name=ExTname value="" size="30">
      <td><input type=submit value=导入数据> </tr>
  </table>
</form> 

<meta http-equiv="content-type" content="text/html;charset=gb2312">
<style>
   td,input,select,body{font-size:9pt}
</style>

<script>
function backup()
{
window.open("admin_backupdata.asp","","Width=400,Height=300")
}
</script>
<%
Else
Response.Redirect "admin_xibu.asp"
End If
%>

JaAcc_Save.Asp

<!--#include file=common.asp-->
<%
if session("xibu")="administrator" then
'**********************************************
'       Code by 子言(JaStudio)
' 数据分离与保存，其中数据分离写的辛苦
'       没这么上下也写不出来哈,真是累人。
' QQ:23638564 Email:kpggdf@163.com
' web:www.gdsspt.com    
'**********************************************
Dim a
Dim FCount
Dim Fname
Dim Cname
Dim i
Dim ccc
Dim b
a = Cint(Request.Form("A"))
Fcount = Cint(Trim(Request.Form("Count")))
for i=0 to Fcount-1
if i=Fcount-1 Then
Fname = Fname & Request.Form("ExFName"&i&"")
else
Fname = Fname & Request.Form("ExFName"&i&"") & ","
end if
next
for i=0 to a
Cname = Cname & Request.Form("ExCName"&i&"") & "|"
next
Cname = split(Cname,"|")

for i=0 to a
if i>0 and i mod Fcount = 0  and i<a then
Response.Write "<br/>"
for b=0 to Fcount-1
if b<> Fcount-1 Then
ccc = ccc & "'" & cname(i+b) & "',"
Else
ccc = ccc & "'" & cname(i+b) & "'"
End if
next
Sql ="Insert into SingUp("&Fname&")values("&ccc&")"
'Response.Write Sql
ccc =""
Conn.ExeCute(Sql)
Response.Write "<br/>"
End If
next
Response.write "<script language='javascript'>" & chr(13)
  Response.write "alert('记录导入成功!');" & Chr(13)
  Response.write "window.document.location.href='JaExcel_Acc.Asp';"&Chr(13)
  Response.write "</script>" & Chr(13)
      Response.End
erase Cname
Else
Response.Redirect "admin_xibu.asp"
End If
%>