📄 user_export.asp
字号:
<!--#include file=INC/skin.asp-->
<%
on error resume next
dim const_txl_HomeUrl,errstr,i,sql,tmpstr
Dim aryData, aryHeaders
Dim intRecFirst, intRecLast
Dim intFieldFirst, intFieldLast, intRecordCount
Dim Rs
errstr=""
const_txl_HomeUrl=""
OpenDatabase
'txl_SiteHead const_txlname&"- 会员资料"
call online
call main
CloseDatabase
'web_end
Sub main
If Session("username")="" Then
errstr=errstr&"<li>你现在还没有登录或者会话超时,点<a href='user_login.asp'>这里登录</a>!</li>"
errstr=errstr&"<li>如果还有疑问请与管理员联系!</li>"
txl_SiteHead const_txlname&"- 会员资料"
Call printerror("导出会员资料出错！",errstr,779)
web_end
Exit Sub
End If
If Session("usertype")="" or Session("usertype")=0 or Session("usertype")=1 or Session("usertype")=2 Then
errstr=errstr&"<li>影音好友和准影音成员没有这个权限</li>"
errstr=errstr&"<li>如果还有疑问请与管理员联系!</li>"
txl_SiteHead const_txlname&"- 会员资料"
Call printerror("导出会员资料出错！",errstr,779)
web_end
Exit Sub
End IF
Dim where
Select Case Request("usertype")
Case "1":where=" usertype=1 "
Case "2":where=" usertype=2 "
Case "3":where=" usertype=3 "
Case "4":where=" usertype=4 "
Case Else:where=" 1=1 "
End Select
Set Rs=Server.CreateObject("Adodb.Recordset")
Rs.open "Select studentid,sname,sex,oicq,email,homephone,homeaddr,homezip,newphone,newaddr,newzip,birthday from ec where "&where&" order by studentid",conn,1
If Rs.EOF Then
Response.Write "No records returned"
Response.End
End if
ReDim aryHeaders(Rs.Fields.Count)
For i=0 To Rs.Fields.Count - 1
aryHeaders(i) = Rs.Fields(i).Name
Next
aryData = Rs.GetRows
Rs.Close
Set Rs = Nothing
intRecFirst = LBound(aryData, 2)
intRecLast = UBound(aryData, 2)
intFieldFirst = LBound(aryData, 1)
intFieldLast = UBound(aryData, 1)
intRecordCount = UBound(aryData, 2) + 1
Dim fileName, format, contentType
select case Request.QueryString("fm")
case "excel": PrintExcel
case "txt": PrintText
case "xml": PrintXML
case else: PrintText
end select
End Sub
Sub SetHeaders(fileName, contentType)
Response.ContentType = contentType
Response.AddHeader "Content-Disposition", "attachment; filename=" & fileName
End Sub
Sub PrintExcel
SetHeaders "ClassData" & month(now) & "_" & day(now) & ".xls", "Application/vnd.excel"
Response.Write "<html xmlns:x=""urn:schemas-microsoft-com:office:excel"">"
Response.Write "<head>"
Response.Write "<!--[if gte mso 9]><xml>"
Response.Write "<x:ExcelWorkbook>"
Response.Write "<x:ExcelWorksheets>"
Response.Write "<x:ExcelWorksheet>"
Response.Write "<x:Name>EC Report</x:Name>"
Response.Write "<x:WorksheetOptions>"
Response.Write "<x:Print>"
Response.Write "<x:ValidPrinterInfo/>"
Response.Write "</x:Print>"
Response.Write "</x:WorksheetOptions>"
Response.Write "</x:ExcelWorksheet>"
Response.Write "</x:ExcelWorksheets>"
Response.Write "</x:ExcelWorkbook>"
Response.Write "</xml>"
Response.Write "<![endif]--> "
Response.Write "</head>"
Response.Write "<body>"
PrintTable "<td>","</td>","<tr>","</tr>","<table>","</table>"
Response.Write "</body>"
Response.Write "</html>"
End Sub
Sub PrintCSV
SetHeaders strReportName & month(now) & "_" & day(now) & ".csv","text/csv"
PrintTable Chr(34),Chr(34) & Chr(44),"",Chr(10),"",""
End Sub
Sub PrintText
SetHeaders "ClassData" & month(now) & "_" & day(now) & ".txt","text/txt"
PrintTable "",vbTab,"",vbCrlf,"",""
End Sub
Sub PrintXML
SetHeaders "ClassData" & month(now) & "_" & day(now) & ".xml","text/xml"
Dim objDom
Dim objRoot
Dim objField
Dim objFieldValue
Dim objcolName
Dim objattTabOrder
Dim objPI
Dim x,j
Dim objRow
Set objDom = Server.CreateObject("Microsoft.XMLDOM")
objDom.async = false
Set objPI = objDom.createProcessingInstruction("xml","version=""1.0"" encoding=""GB2312""")
objDom.insertBefore objPI,objDom.childNodes(0)
Set objRoot = objDom.createElement("root")
objDom.appendChild objRoot
For i = intRecFirst To intRecLast
Set objRow = objDom.CreateElement("record")
For j = intFieldFirst To intFieldLast
Set objField = objDom.createElement("field")
Set objcolName = objDom.createAttribute("name")
objcolName.Text = aryHeaders(j)
objField.SetAttributeNode(objColName)
Set objFieldValue = objDom.createElement("value")
objFieldValue.Text =""&aryData(j, i)
objField.appendChild objFieldValue
objRow.appendChild objField
Next
objRoot.appendChild objRow
Next
'Response.Write(objDom.xml)
tmpstr=objDom.xml
tmpstr=Replace(tmpstr,"<?xml version=""1.0""?>","<?xml version=""1.0"" encoding=""GB2312""?>")
Response.Write tmpstr
Set objFieldValue = Nothing
Set objRoot = Nothing
Set objField = Nothing
Set objcolName = Nothing
Set objattTabOrder = Nothing
Set objPI = Nothing
Set objDom = Nothing
End Sub
Sub PrintTable(f1,f2,r1,r2,t1,t2)
dim i,j
Response.Write t1
Response.Write r1
For i=0 To UBound(aryHeaders)
Response.Write f1 & aryHeaders(i) & f2
Next
Response.Write r2
For i = intRecFirst To intRecLast
Response.Write r1
For j = intFieldFirst To intFieldLast
Response.Write f1 & aryData(j, i) & f2
Next
Response.Write r2
Next
Response.Write t2
End Sub
%>⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -