qqcf_myfunction.asp

动态自定义报表,真正的中国式报表,可自行编辑

<%
'==================================
' 乘风网址 v3.1
' 制　作：乘　风
' 开发网站：http://www.qqcf.com
' 程序演示：http://www.qqcf.com/?action=try
' 最新版本下载：http://www.qqcf.com/?action=down
' 声 明:	
' 本软件系免费程序,提供给个人免费使用,除保留版权外无其它任何限制。
' 我们为付费版用户提供升级服务和技术支持。
' 在程序首页保留乘风原创程序版权和链接的免费用户我们也提供一些的升级服务和技术支持。
' 未经作者许可禁止用于任何商业用途。
' 乘风网址功能：
' 1.同时支持Access和Mssql数据库
' 2.完全生成静态页面，包括每个网址转向页面
' 3.支持修改模板，支持二级栏目
' 4.自带4000多条网址数据，支持系统放在网站子目录
' 乘风其它作品：乘风多用户计数器.net,php,access,MsSql版、乘风电影程序、
'　　　　　　　 乘风网站推广系统、乘风广告管理系统、乘风论坛等。
' 此段版权注释不会影响网页打开速度，请勿删除!
'　　　　　　　　　　　2006年12月25日									
'===================================
%>
<%'以下为公用函数
Function goback(str,alertstr) '为空时后退
 if str="" then 
  response.write "<script>" 
  response.write "alert('"&alertstr&"');" 
  response.write "history.go(-1)" 
  response.write "</script>" 
  response.end 
 else
  goback=str
 end if
End Function

Function alertback(alertstr,backnum) 
  response.write "<script>" 
  response.write "alert('"&alertstr&"');" 
  response.write "history.go(-"&backnum&")" 
  response.write "</script>" 
  response.end 
End Function

Function AlertUrl(alertstr,url) 
  response.write "<script>" 
  response.write "alert('"&alertstr&"');" 
  response.write "location.href='"&url&"';" 
  response.write "</script>" 
  response.end 
End Function

Function GotoUrl(url) 
  response.write "<script>" 
  response.write "location.href='"&url&"';" 
  response.write "</script>" 
  response.end 
End Function

function checkinput_letter(inputstr) '检查用户名输入的合法性
for i = 1 to Len(inputstr)
 c = Lcase(Mid(inputstr, i, 1)) '------------分割成每个字母或数字------------------
  if InStr("abcdefghijklmnopqrstuvwxyz_", c) <= 0 and not IsNumeric(c) then
  response.write "<script language='javascript'>" & VbCRlf
  response.write "alert('请不要在用户名中输入中文,空格或其它非法字符,合法字符为大小写字母,下划线,数字!');" & VbCrlf
  response.write "history.go(-1);" & vbCrlf
  response.write "</script>" & VbCRLF
  response.end
  end if
next
 checkinput_letter=inputstr
end function

function checkinput_blank(inputstr) '检查密码输入的合法性
for i = 1 to Len(inputstr)
 c = Lcase(Mid(inputstr, i, 1)) '------------分割成每个字母或数字------------------
  if InStr(" ", c) > 0 or InStr("　", c) > 0 then
  response.write "<script language='javascript'>" & VbCRlf
  response.write "alert('请不要输入空格!');" & VbCrlf
  response.write "history.go(-1);" & vbCrlf
  response.write "</script>" & VbCRLF
  response.end
  end if
next
 checkinput_blank=inputstr
end function

Function ChkStr(ByVal ParaValue,ByVal ParaType)'参数类型-数字型(1是字符，2是数字，3是日期
 If ParaType = 1 then
  ChkStr = Replace(ParaValue,"'","''")
 ElseIf ParaType = 2 then
  If ParaValue<>"" And (IsNumeric(ParaValue) = False) then
   Response.Write "传递的参数类型有错误！" 
   Response.End
  Else
   ChkStr = ParaValue
  End If
 ElseIf ParaType = 3 then
  If ParaValue<>"" And (IsDate(ParaValue) = False) then
   Response.Write "传递的参数类型有错误！" 
   Response.End
  Else
   ChkStr = ParaValue
  End If
 End If
End Function

Function HttpPath(Assort)
 Ser=Request.servervariables("SERVER_NAME")
 Scr=Request.servervariables("SCRIPT_NAME")
 Port=Request.Servervariables("SERVER_PORT")

 Scr_2=StrReverse(Mid(StrReverse(Scr),Instr(StrReverse(Scr),"/")))

 If Assort=1 Then
  HttpPath=Ser 
 ElseIf Assort=2 Then
  If Port="80" Then
   HttpPath="http://"&Ser&Scr_2
  Else
   HttpPath="http://"&Ser&":"&Port&Scr_2
  End If 
 ElseIf Assort=3 Then
  If Port="80" Then
   HttpPath="http://"&Ser&Scr
  Else
   HttpPath="http://"&Ser&":"&Port&Scr
  End If
 End If
End Function

Function GetFieldValues(TalbeName,FieldNmae,Fieldvalues,FieldType,GetFieldName)  '通用,通过一个表的字段，得到表中某个字段的值
 if FieldType=1 then
	sql="select "&GetFieldName&" from "& TalbeName &" where "& FieldNmae &"="& Fieldvalues
 elseif FieldType=2 then
	sql="select "&GetFieldName&" from "& TalbeName &" where "& FieldNmae &"='"& Fieldvalues &"'"
 end if
 set FieldValues=server.createobject("adodb.recordset")
 FieldValues.open sql,conn,1,1
	if Not FieldValues.eof then
	 GetFieldValues=FieldValues(0)
	end if
	FieldValues.close
End function


function FSOFileRead(filename)
Dim objFSO,objCountFile,FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FSOFileRead = objCountFile.ReadAll
objCountFile.Close
Set objCountFile=Nothing
Set objFSO = Nothing
End Function

Sub CreateFolder(Foldername)
 Set Afso = Server.CreateObject("Scripting.FileSystemObject")
  If Afso.FolderExists(Server.MapPath(Foldername))=True Then
  Else
   Afso.CreateFolder(Server.MapPath(foldername))
  End If
 Set Afso=Nothing
End Sub

Function getCategories(aspfile)
on error resume next
Dim oXMLHTTP ' As Object
Dim oCategories ' As Object
Dim BodyText
Dim Pos,Pos1
Set oXMLHTTP = CreateObject("Microsoft.XMLHTTP")
oXMLHTTP.open "GET",aspfile,False  '这个地方换成你自己的地址
oXMLHTTP.send 
 BodyText=oXMLHTTP.responsebody
 BodyText=BytesToBstr(BodyText,"gb2312")
 getCategories=BodyText
Set oXMLHTTP = Nothing 
if err.number<>0 then
response.write "出错了，错误描述："&err.description & "<br>错误来源"& err.source
response.End()
end if
End Function 

Function GetCurrWeb()
 Url=HttpPath(3)&"?"&Request.QueryString&"&"&Request.Form
 If Mid(Url,Len(Url))="&" Then Url=Left(Url,Len(Url)-1)
 Session("Url")=Url
End Function

Function PxFilter(ByVal px,ByVal pxok)
 px=Lcase(px)
 pxok=Lcase(pxok)

 PxArrary=Split(Pxok,",")

 For I= 0 To Ubound(PxArrary)
  If PxArrary(I)=Px Then J=1
 Next

 If J<>1 Then Call AlertBack("禁止此类排序",1)
End Function

Function GetMySet(ByVal MyStr)

 If IsEmpty(Application("Cfwz_MySet")) Then
  Sql = "Select OtherSet From WWW_QQCF_COM_CfWz_Admin"
  Set Rs_MySet = Conn.Execute(Sql)
  Application("Cfwz_MySet") = Rs_MySet("OtherSet")
  Rs_MySet.Close
 End If
 
 MyArray_MySet = Split(Application("Cfwz_MySet"), "|")
 For I_MySet = 0 To UBound(MyArray_MySet)
  If LCase(Left(MyArray_MySet(I_MySet), Len(MyStr)+1)) = LCase(MyStr)&"=" Then GetMySet = Mid(MyArray_MySet(I_MySet), Len(MyStr) + 2)
 Next

End Function

Function BytesToBstr(body,Cset)
        dim objstream
        set objstream = Server.CreateObject("adodb.stream")
        objstream.Type = 1
        objstream.Mode =3
        objstream.Open
        objstream.Write body
        objstream.Position = 0
        objstream.Type = 2
        objstream.Charset = Cset
        BytesToBstr = objstream.ReadText 
        objstream.Close
        set objstream = nothing
End Function
Public Function HTMLEncode(fString)
  If Not IsNull(fString) Then
   fString = replace(fString, ">", "&gt;")
   fString = replace(fString, "<", "&lt;")
   fString = Replace(fString, CHR(32), " ")  '&nbsp;
   fString = Replace(fString, CHR(9), " ")   '&nbsp;
   fString = Replace(fString, CHR(34), "&quot;")
   fString = Replace(fString, CHR(39), "&#39;") '单引号过滤
   fString = Replace(fString, CHR(13), "")
   fString = Replace(fString, CHR(10) & CHR(10), "</P><P> ")
   fString = Replace(fString, CHR(10), "<BR> ")
   HTMLEncode = fString
  End If
 End Function
 
Function IndexGx()
 IndexCode=FSOFileRead("qqcf_mb/qqcf_index.htm")

 IndexTopCode=FSOFileRead("qqcf_mb/qqcf_top.htm")
 IndexTopCode=Replace(IndexTopCode,"|folderpath|","")

 IndexBottomCode=FSOFileRead("qqcf_mb/qqcf_bottom.htm")
 IndexBottomCode=Replace(IndexBottomCode,"|folderpath|","")
 
 IndexClassCode=GetIndexClass()

 IndexCode=Replace(IndexCode,"|indextop|",IndexTopCode)
 IndexCode=Replace(IndexCode,"|indexbottom|",IndexBottomCode)
 IndexCode=Replace(IndexCode,"|incdexclass|",IndexClassCode)

 Set fso = Server.CreateObject("Scripting.FileSystemObject")
 Set fout = fso.Createtextfile(server.mappath("Index.htm"),true)
 Fout.WriteLine IndexCode
 Fout.Close
 
End Function

Function ClassGx(ByVal ClassID,ByVal WebsiteUpdate)
 
 ClassCode=FSOFileRead("qqcf_mb/qqcf_list.htm")

 
 ClassTopCode=FSOFileRead("qqcf_mb/qqcf_top.htm")