ASP的自定义实用函数表(2)
时间：2010-04-30 来源：mx11
'CFS編碼加密
Function CfsEnCode(CodeStr)
Dim CodeLen
Dim CodeSpace
Dim NewCode
CodeLen = 30
CodeSpace = CodeLen - Len(CodeStr)
If Not CodeSpace < 1 Then
For cecr = 1 To CodeSpace
CodeStr = CodeStr & Chr(21)
Next
End If
NewCode = 1
Dim Been
For cecb = 1 To CodeLen
Been = CodeLen + Asc(Mid(CodeStr,cecb,1)) * cecb
NewCode = NewCode * Been
Next
CodeStr = NewCode
NewCode = Empty
For cec = 1 To Len(CodeStr)
NewCode = NewCode & CfsCode(Mid(CodeStr,cec,3))
Next
For cec = 20 To Len(NewCode) - 18 Step 2
CfsEnCode = CfsEnCode & Mid(NewCode,cec,1)
Next
End Function
Function CfsCode(Word)
For cc = 1 To Len(Word)
CfsCode = CfsCode & Asc(Mid(Word,cc,1))
Next
CfsCode = Hex(CfsCode)
End Function
編碼函式 CfsEncode() 的使用：
Var = CfsEncode(字串來源)
範例：
<%Dim SourceDim Var1Source = "test"Var1 = CfsEncode(Source)Response.Write Var1%>
-------------------------------------------
用正则表达式写的HTML分离函数
存成.asp文件，执行，你用ASPHTTP抓内容的时候用这个很爽，当然自己要改进一下了
<%
Option Explicit
Function stripHTML(strHTML)
'Strips the HTML tags from strHTML
Dim objRegExp, strOutput
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<.+?>"
'Replace all HTML tag matches with the empty string
strOutput = objRegExp.Replace(strHTML, "")
'Replace all < and > with < and >
strOutput = Replace(strOutput, "<", "<")
strOutput = Replace(strOutput, ">", ">")
stripHTML = strOutput 'Return the value of strOutput
Set objRegExp = Nothing
End Function
%>
<form method="post" id=form1 name=form1>
<b>Enter an HTML String:</b><br>
<textarea name="txtHTML" cols="50" rows="8" wrap="virtual"><%=Request("txtHTML")%></textarea>
<p>
<input type="submit" value="Strip HTML Tags!" id=submit1 name=submit1>
</form>
<% if Len(Request("txtHTML")) > 0 then %>
<p><hr><p>
<b><u>View of string <i>with no</i> HTML stripping:</u></b><br>
<xmp>
<%=Request("txtHTML")%>
</xmp><p>
<b><u>View of string <i>with</i> HTML stripping:</u></b><br>
<pre>
<%=StripHTML(Request("txtHTML"))%>
</pre>
<% End If %>
---------------------------------------
如何检测备注字段的字节数
视服务器操作系统语种不同,而采取不同的方法:
1.E文下,len(rs("field")),就行了.len("中文abc")=7
2.Z文下,复杂一点,len("中文abc")=5
lenB("中文abc")=10,所以需要自己写程序判断其长度.
function strLen(str)
dim i,l,t,c
l=len(str)
t=l
for i=1 to l
c=asc(mid(str,i,1))
if c<0 then c=c+65536
if c>255 then
t=t+1
end if
next
strLen=t
end function
------------------------------------
FSO自写自用的几个函数
''''使用FSO修改文件特定内容的函数
function FSOchange(filename,Target,String)
Dim objFSO,objCountFile,FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FiletempData = objCountFile.ReadAll
objCountFile.Close
FiletempData=Replace(FiletempData,Target,String)
Set objCountFile=objFSO.CreateTextFile(Server.MapPath(filename),True)
objCountFile.Write FiletempData
objCountFile.Close
Set objCountFile=Nothing
Set objFSO = Nothing
End Function
''''使用FSO读取文件内容的函数
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
''''使用FSO读取文件某一行的函数
function FSOlinedit(filename,lineNum)
if linenum < 1 then exit function
dim fso,f,temparray,tempcnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
set f = nothing
temparray = split(tempcnt,chr(13)&chr(10))
if lineNum>ubound(temparray)+1 then
exit function
else
FSOlinedit = temparray(lineNum-1)
end if
end if
end function
''''使用FSO写文件某一行的函数
function FSOlinewrite(filename,lineNum,Linecontent)
if linenum < 1 then exit function
dim fso,f,temparray,tempCnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
temparray = split(tempcnt,chr(13)&chr(10))
if lineNum>ubound(temparray)+1 then
exit function
else
temparray(lineNum-1) = lineContent
end if
tempcnt = join(temparray,chr(13)&chr(10))
set f = fso.createtextfile(server.mappath(filename),true)
f.write tempcnt
end if
f.close
set f = nothing
end function
''''使用FSO添加文件新行的函数
function FSOappline(filename,Linecontent)
dim fso,f
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),8,1)
f.write chr(13)&chr(10)&Linecontent
f.close
set f = nothing
end function
''''读文件最后一行的函数
function FSOlastline(filename)
dim fso,f,temparray,tempcnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
set f = nothing
temparray = split(tempcnt,chr(13)&chr(10))
FSOlastline = temparray(ubound(temparray))
end if
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
用法，createfolder(foldername)
----------------------------------------
''检查字符串是否包含非法字符串
FUNCTION BadWords(strContent)
DIM objRegExp
Set objRegExp = new RegExp
objRegExp.IgnoreCase = true
objRegExp.Global = true
objRegExp.Pattern = "李.{0,10}某.{0,10}人|他.{0,10}妈.{0,10}的|你.{0,10}他.{0,10}妈.{0,10}的|我操.{0,10}你妈"
BadWords = objRegExp.Test(strContent)
Set objRegExp = Nothing
END FUNCTION
---------------------------------------
取得网站的URL的根目录
'******************************
'||Function GetRootDir()
'||Created by Cj, 2000/8/28
'||取得网站的URL的根目录
'******************************
Function GetRootDir()
If Application("RootDir") <> "" And Not isNull(Application("RootDir")) then
GetRootDir = Application("RootDir")
Exit Function
End if
dim strRoot, intRootEnd
strRoot = Request.ServerVariables("SCRIPT_NAME")
intRootEnd = Instr(2, strRoot, "/")
if intRootEnd > 1 then
strRoot = Left(strRoot, intRootEnd)
End if
Application.Lock()
Application("RootDir") = strRoot
Application.UnLock()
GetRootDir = strRoot
End Function
------------------------------------
这是一个后台管理的文章发布系统里的一个将copy的文字转换成html代码的函数，如果是空格会自动加 如果换行会自动加<br>也可以自己直接写HTML代码
<%
'自建Asp函数库
'HTML/*********************
'将部分字符串转化为Html代码
function htmlencode2(str)
dim result
dim l
if isNULL(str) then
htmlencode2=""
exit function
end if
l=len(str)
result=""
dim i
for i = 1 to l
select case mid(str,i,1)
case "'"
result=result+"’"
'case ""
' result=result+">"
case chr(13)
result=result+"<br>"
'case chr(34)
' result=result+""
case "&"
result=result+"&"
case chr(32)
'result=result+" "
if i+1<=l and i-1>0 then
if mid(str,i+1,1)=chr(32) or mid(str,i+1,1)=chr(9) or mid(str,i-1,1)=chr(32) or mid(str,i-1,1)=chr(9) then
result=result+" "
else
result=result+" "
end if
else
result=result+" "
end if
case chr(9)
result=result+" "
case else
result=result+mid(str,i,1)
end select
next
htmlencode2=result
end function
'字符串验证**************
'Emailcheck
Function isEmail(val)
isEmail=False
if len(val)>0 then
if instr(val,"@")>0 and instr(val,".")>0 and len(val)>5 then
else
exit function
end if
else
exit function
end if
isEmail=true
end function
%>
----------------------------------------
无级分类的函数，分表格显示与下拉列表显示两种：
数据库Db_category: CategoryID | ParentID | CategoryName
调用：Sub CategoryType(CategoryID,num,Action,SelectedID,Style)
Category.asp:
<%
Sub CategoryType(CategoryID,num,Action,SelectedID,Style)
'style = 1 , 以表格显示
'style = 2 , 以下拉列表显示
if Style = 0 then
response.write "<table border='1' width='100%' cellspacing='0' cellpadding='2' bordercolorlight='#000000' bordercolordark='#FFFFFF' class='p9'>"
response.write "<tr align='center'>"
response.write "<td width='10%'> 分类ID </td>"
response.write "<td width='10%'> 上级ID </td>"
response.write "<td width='*'> 分类名称 </td>"
response.write "<td width='15%'> 操作 </td></tr>"
call CategoryList(CategoryID,num,Action)
response.write "</table>"
else
response.write "<select name='Category'>"
response.write "<option value='0'> ---产品根目录--- </option>"
call CategorySel(CategoryID,num,SelectedID)
response.write "</select>"
end if
end sub
Sub CategoryList(ParentID,num,Action)
sql="select CategoryID,ParentID,CategoryName from Db_Category where ParentID="&ParentID
set rs=server.createobject("adodb.recordset")
rs.open sql,conn,1,1
if not rs.eof then
Category = rs.getrows
end if
rs.close
set rs=nothing
snum = num + 1
str = Makeblank(snum,0)
if isArray(Category) then
for l=0 to ubound(Category,2)
response.Write("<tr>")
for k=0 to ubound(Category,1)
if k = ubound(Category,1) then '当显示CategoryName 时加[],其他不加
response.Write("<td>"&str&" [ "&Category(k,l)&"] "&"</td>")
else
response.Write("<td> "&Category(k,l)&" "&"</td>")
end if
next
if Action = 1 then '添加目录
response.Write("<td align='center'> <a href='CategoryAdd.asp?CategoryID="&Category(0,l)&"'>添加子类</a> </td></tr>")
elseif Action = 2 then '修改目录
response.Write("<td align='center'> <a href='CategoryEdit.asp?CategoryID="&Category(0,l)&"'>修改类别</a> </td></tr>")
elseif Action = 3 then '删除目录
response.Write("<td align='center'> <a href='CategoryDel.asp?CategoryID="&Category(0,l)&"'>删除类别</a> </td></tr>")
else '没有操作，仅浏览
response.Write("<td align='center'> --------- </td></tr>")
end if
'调用递归函数，列出下级目录
call CategoryList(Category(0,l),snum,Action)
next
set Category = nothing
end if
End Sub
Sub CategorySel(CategoryID,num,SelectedID)
sql="select CategoryID,ParentID,CategoryName from Db_Category where ParentID="&CategoryID
set rs=server.createobject("adodb.recordset")
rs.open sql,conn,1,1
if not rs.eof then
Category = rs.getrows
end if
rs.close
set rs = nothing
snum = num + 1
str = Makeblank(snum,1)
if isArray(Category) then
for l=0 to ubound(Category,2)
if Category(0,l) = SelectedID then '当显示已选择的ID时加[Selected],表示已选择
response.Write("<option value='"&Category(0,l)&"' Selected>"&str&Category(2,l)&"</option>")
else
response.Write("<option value='"&Category(0,l)&"'>"&str&Category(2,l)&"</option>")
end if
'调用递归函数，列出下级目录
call CategorySel(Category(0,l),snum,SelectedID)
next
set Category = nothing
end if
End Sub
Function Makeblank(num,Style)
if Style = 0 then
for i = 2 to num
TempStr = TempStr&" "
next
Makeblank = TempStr&"├"
else
for i = 2 to num
TempStr = TempStr&" "
next
Makeblank = TempStr&"└ "
end if
'不同的表格线:└┌┍┕┎┖┐┘┑┙┒┚┓┛├ ┤┝ ┥┞ ┦┼ ╄ ┽ ╅┣ ┫
End function
%>
----------------------------------------
qq在线显示程序核心代码
<%
Function GetURL(url)
Set Retrieval = CreateObject("Microsoft.XMLHTTP")
With Retrieval
.Open "GET", url, False, "", ""
.Send
GetURL = .ResponseText
End With
Set Retrieval = Nothing
End Function
Function qqonline(qqid)
Dim T,Start,Length,PicURL
'找到该用户界面的源代码
T=GetURL("http://search.tencent.com/cgi-bin/friend/oicq_find?oicq_no=";&qqid)
'查找字符串ShowResult(的位置
Start=Instr(1,T,"ShowResult("+chr(34))
'查找字符串http://的位置
Start=Instr(Start,T,"http://"/;)
'查找包含字符串的长度
Length=Instr(Start,T,chr(34)+","+chr(34))-Start
PicURL=Mid(T,Start,Length)
pic_right=right(picurl,5)
pic_left=left(pic_right,1)
if pic_left="2" then
qqonline="在线"
else
qqonline="离线"
end if
End Function
%><%=qqonline(24080411)%>
------------------------------------------
vbs类生成xml文件
有两文件:
objXML.asp:测试文件
clsXML.asp:vbs类文件
代码:
objXML.asp
<%@ Language=VBScript %>
<% Option Explicit %>
<!--#INCLUDE FILE="clsXML.asp"-->
<%
Dim objXML, strPath, str
Set objXML = New clsXML
strPath = Server.MapPath(".") & "\New.xml"
objXML.createFile strPath, "Root"
'Or If using an existing XML file:
'objXML.File = "C:\File.xml"
objXML.createRootChild "Images"
'Here only one attribute is added to the Images/Image Node
objXML.createChildNodeWAttr "Images", "Image", "id", "1"
objXML.updateField "Images//Image[@id=1]", "super.gif"
objXML.createRootNodeWAttr "Jobs", Array("Size", "Length", "Width"), _
Array(24, 31, 30)
objXML.createRootNodeWAttr "Jobs", Array("Size", "Length", "Width"), _
Array(24, 30, 29)
objXML.createRootNodeWAttr "Jobs", Array("Size", "Length", "Width"), _
Array(24, 31, 85)
'Notice that all three job nodes have size 24, all of those
'nodes will be updated
objXML.updateField "Jobs[@Size=24]", "24's"
'Notice that only two nodes have the specified XPath, hence
'only two new child nodes will be added
objXML.createChildNodeWAttr "Jobs[@Size=24 and @Length=31]", "Specs", _
Array("Wood", "Metal", "Color"), _
Array("Cedar", "Aluminum", "Green")
'It is always important to iterate through all of the nodes
'returned by this XPath query.
For Each str In objXML.getField("Jobs[@Size=24]")
Response.Write(str & "<br>")
Next
Set objXML = Nothing
Response.Redirect "New.xml"
%>
clsXML.asp:
<%
Class clsXML
'strFile must be full path to document, ie C:\XML\XMLFile.XML
'objDoc is the XML Object
Private strFile, objDoc
'*********************************************************************
' Initialization/Termination
'*********************************************************************
'Initialize Class Members
Private Sub Class_Initialize()
strFile = ""
End Sub
'Terminate and unload all created objects
Private Sub Class_Terminate()
Set objDoc = Nothing
End Sub
'*********************************************************************
' Properties
'*********************************************************************
'Set XML File and objDoc
Public Property Let File(str)
Set objDoc = Server.CreateObject("Microsoft.XMLDOM")
objDoc.async = False
strFile = str
objDoc.Load strFile
End Property
'Get XML File
Public Property Get File()
File = strFile
End Property
'*********************************************************************
' Functions
'*********************************************************************
'Create Blank XML File, set current obj File to newly created file
Public Function createFile(strPath, strRoot)
Dim objFSO, objTextFile
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.CreateTextFile(strPath, True)
objTextFile.WriteLine("<?xml version=""1.0""?>")
objTextFile.WriteLine("<" & strRoot & "/>")
objTextFile.Close
Me.File = strPath
Set objTextFile = Nothing
Set objFSO = Nothing
End Function
'Get XML Field(s) based on XPath input from root node
Public Function getField(strXPath)
Dim objNodeList, arrResponse(), i
Set objNodeList = objDoc.documentElement.selectNodes(strXPath)
ReDim arrResponse(objNodeList.length)
For i = 0 To objNodeList.length - 1
arrResponse(i) = objNodeList.item(i).Text
Next
getField = arrResponse
End Function
'Update existing node(s) based on XPath specs
Public Function updateField(strXPath, strData)
Dim objField
For Each objField In objDoc.documentElement.selectNodes(strXPath)
objField.Text = strData
Next
objDoc.Save strFile
Set objField = Nothing
updateField = True
End Function
'Create node directly under root
Public Function createRootChild(strNode)
Dim objChild
Set objChild = objDoc.createNode(1, strNode, "")
objDoc.documentElement.appendChild(objChild)
objDoc.Save strFile
Set objChild = Nothing
End Function
'Create a child node under root node with attributes
Public Function createRootNodeWAttr(strNode, attr, val)
Dim objChild, objAttr
Set objChild = objDoc.createNode(1, strNode, "")
If IsArray(attr) And IsArray(val) Then
If UBound(attr)-LBound(attr) <> UBound(val)-LBound(val) Then
Exit Function
Else
Dim i
For i = LBound(attr) To UBound(attr)
Set objAttr = objDoc.createAttribute(attr(i))
objChild.setAttribute attr(i), val(i)
Next
End If
Else
Set objAttr = objDoc.createAttribute(attr)
objChild.setAttribute attr, val
End If
objDoc.documentElement.appendChild(objChild)
objDoc.Save strFile
Set objChild = Nothing
End Function
'Create a child node under the specified XPath Node
Public Function createChildNode(strXPath, strNode)
Dim objParent, objChild
For Each objParent In objDoc.documentElement.selectNodes(strXPath)
Set objChild = objDoc.createNode(1, strNode, "")
objParent.appendChild(objChild)
Next
objDoc.Save strFile
Set objParent = Nothing
Set objChild = Nothing
End Function
'Create a child node(s) under the specified XPath Node with attributes
Public Function createChildNodeWAttr(strXPath, strNode, attr, val)
Dim objParent, objChild, objAttr
For Each objParent In objDoc.documentElement.selectNodes(strXPath)
Set objChild = objDoc.createNode(1, strNode, "")
If IsArray(attr) And IsArray(val) Then
If UBound(attr)-LBound(attr) <> UBound(val)-LBound(val) Then
Exit Function
Else
Dim i
For i = LBound(attr) To UBound(attr)
Set objAttr = objDoc.createAttribute(attr(i))
objChild.SetAttribute attr(i), val(i)
Next
End If
Else
Set objAttr = objDoc.createAttribute(attr)
objChild.setAttribute attr, val
End If
objParent.appendChild(objChild)
Next
objDoc.Save strFile
Set objParent = Nothing
Set objChild = Nothing
End Function
'Delete the node specified by the XPath
Public Function deleteNode(strXPath)
Dim objOld
For Each objOld In objDoc.documentElement.selectNodes(strXPath)
objDoc.documentElement.removeChild objOld
Next
objDoc.Save strFile
Set objOld = Nothing
End Function
End Class
%>
--------------------------------------------
利用ASP怎么实现对指定文件夹下的内容（包括子文件夹的）进行搜索？
搜索出来的结果再分页显示？
这是Lshdic以前写过的,在Lshdic2002中有更详细的FSO对象浏览器<p>
做成ASP你可以手工改一改，这里方便浏览<p>
<script language=vbs>
Set fso=CreateObject("Scripting.FileSystemObject")
set getfso=fso.GetFolder("c:\windows\desktop").files
document.write "以下是桌面所有文件"
for each i in getfso
document.write i & "<br>"
next
document.write "<p>以下是桌面所有文件子文件夹包含的文件夹和文件<p>"
set getfso=fso.GetFolder("c:\windows\desktop").SubFolders
for each r in getfso
document.write r & " 文件夹包含<p>"
set getfso1=fso.GetFolder(r).files
for each n in getfso1
document.write n & "<br>"
next
next
</script>
------------------------------------------
身份证真伪
'id 省份证号
'birthday生日,yyyy-mm-dd格式
'sex性别,值为"男:1","女:0"
id = "460102800925121"
birthday = "1980-09-25"
sex = 1
IF idcard_check(id,birthday,sex) Then
response.write "不错"
else
response.write "**"
End if
Function idcard_check(id,birthday,sex)
If len(id)<>15 and len(id)<>18 then
idcard_check=false
Exit Function
Else
For i=1 to len(id)
temp=mid(id,i,1)
If temp<"0" or temp>"9" Then
idcard_check=False
Exit Function
End if
Next
bdl=left(birthday,4) & mid(birthday,6,2) & mid(birthday,9,2)
bds=mid(birthday,3,2) & mid(birthday,6,2) & mid(birthday,9,2)
If len(id)=15 Then
If mid(id,7,6)<>bds Then
idcard_check=False
Exit Function
End if
If int(mid(id,15,1)) Mod 2 = 1 And sex=1 Then
idcard_check=True
Exit Function
ElseIf int(mid(id,15,1)) Mod 2 = 0 And sex=0 Then
idcard_check=True
Exit Function
Else
idcard_check=False
Exit Function
End if
Else
If mid(id,7,8)<>bdl Then
idcard_check=False
Exit Function
End if
If int(mid(id,17,1)) Mod 2 = 1 And sex=1 Then
idcard_check=False
Exit Function
ElseIf int(mid(id,17,1)) Mod 2 = 0 And sex=0 Then
idcard_check=False
Exit Function
Else
idcard_check=False
Exit Function
End if
End if
End if
idcard_check=True
End function
11="北京"
12="天津"
13="河北"
14="山西"
15="内蒙古"
21="辽宁"
22="吉林"
23="黑龙江"
31="上海"
32="江苏"
33="浙江"
34="安徽"
35="福建"
36="江西"
37="山东"
41="河南"
42="湖北"
43="湖南"
44="广东"
45="广西"
46="海南"
50="重庆"
51="四川"
52="贵州"
53="云南"
54="西藏"
61="陕西"
62="甘肃"
63="青海"
64="宁夏"
65="新疆"
71="台湾"
81="香港"
82="澳门"
91="国外"
-------------------------------------------
检测上载图片尺寸的
用aspjpeg组件
up.htm
<html>
<body>
<form action="up.asp" ENCTYPE="multipart/form-data" method="post">
<table border=0 width=100% cellspacing="0">
<tr>
<td width="30%">请选择您要上传的gif图片:</td>
<td width="70%"><input type="file" name="pic" style="font-size:10pt;"></td>
</tr>
</table>
<p align="center"><input type="submit" value="提交" style="font-size:9pt;background-color:#54B060;color:white;">
</form>
</body>
</html>
up.asp
<%
FormSize = Request.TotalBytes
FormData = Request.BinaryRead( FormSize )
bncrlf=chrb(13) & chrb(10)
divider=leftb(formdata,instrb(formdata,bncrlf)-1)
datastart=instrb(formdata,bncrlf & bncrlf)+4
dataend=instrb(datastart+1,formdata,divider)-datastart
Image=midb(formdata,datastart,dataend)
head_version = Ascb( midb( Image,1,3 ) )
head_subversion = Ascb( midb( Image,4,3 ) )
head_width_l = Ascb( midb( Image,7,1 ) )
head_width_h = Ascb( midb( Image,8,1 ) )
head_height_l = Ascb( midb( Image,9,1 ) )
head_height_h = Ascb( midb( Image,10,1 ) )
head_colors = Ascb( midb( Image, 11, 1 ) )
head_width_h = head_width_h * 256
head_height_h = head_height_h * 256
head_colors = head_colors And &H07
Response.Write "图像大小为" & head_width_h + head_width_l & "x" & head_height_h + head_height_l _
& "x" & 2^( head_colors + 1 )
%>
-----------------------------------------------
程序说明:函数ShowChar(num)可根据num值返回0-9的位图。注意num取值范围0-9。当前只可生成一位数字代码，任意位数代码待续开放~
ShowChar(2)
function ShowChar(num)
dim tempstr
tempstr="0x3c,0x42,0x42,0x42,0x42,0x42,0x42,0x42,0x42,0x3c|0x20,0x30,0x28,0x20,0x20,0x20,0x20,0x20,0x20,0x20|0x3c,0x66,0x60,0x60,0x30,0x18,0x0c,0x06,0x06,0x7e|0x3c,0x42,0x40,0x40,0x38,0x40,0x40,0x40,0x42,0x3c|0x20,0x30,0x30,0x28,0x28,0x24,0x24,0x7e,0x20,0x20|0x7c,0x04,0x04,0x02,0x3e,0x42,0x40,0x40,0x42,0x3c|0x3c,0x42,0x02,0x02,0x3a,0x46,0x42,0x42,0x42,0x3c|0x7e,0x20,0x20,0x10,0x10,0x08,0x08,0x04,0x04,0x04|0x3c,0x42,0x42,0x42,0x3c,0x42,0x42,0x42,0x42,0x3c|0x3c,0x42,0x42,0x42,0x5c,0x40,0x40,0x40,0x22,0x1c"
CharItem=split(tempstr,"|")
Response.ContentType ="image/x-xbitmap"
response.write "#define counter_width 8"&chr(10)&chr(13)
response.write "#define counter_height 10"&chr(10)&chr(13)
response.write "static unsigned char counter_bits[]={"&chr(10)&chr(13)
response.write CharItem(num)
response.write "};"&chr(10)&chr(13)
end function
%>
------------------------------------------------------------
<%
sub show_img(num)
Dim Image
Dim Width, Height
Dim digtal
Dim Length
Dim sort
Dim imgdata(10,10)
imgdata(0,1)="0x3c":imgdata(0,2)="0x42":imgdata(0,3)="0x42":imgdata(0,4)="0x42":imgdata(0,5)="0x42":imgdata(0,6)="0x42":imgdata(0,7)="0x42":imgdata(0,8)="0x42":imgdata(0,9)="0x42":imgdata(0,10)="0x3c"
imgdata(1,1)="0x20":imgdata(1,2)="0x30":imgdata(1,3)="0x28":imgdata(1,4)="0x20":imgdata(1,5)="0x20":imgdata(1,6)="0x20":imgdata(1,7)="0x20":imgdata(1,8)="0x20":imgdata(1,9)="0x20":imgdata(1,10)="0x20"
imgdata(2,1)="0x3c":imgdata(2,2)="0x66":imgdata(2,3)="0x60":imgdata(2,4)="0x60":imgdata(2,5)="0x30":imgdata(2,6)="0x18":imgdata(2,7)="0x0c":imgdata(2,8)="0x06":imgdata(2,9)="0x06":imgdata(2,10)="0x7e"
imgdata(3,1)="0x3c":imgdata(3,2)="0x42":imgdata(3,3)="0x40":imgdata(3,4)="0x40":imgdata(3,5)="0x38":imgdata(3,6)="0x40":imgdata(3,7)="0x40":imgdata(3,8)="0x40":imgdata(3,9)="0x42":imgdata(3,10)="0x3c"
imgdata(4,1)="0x20":imgdata(4,2)="0x30":imgdata(4,3)="0x30":imgdata(4,4)="0x28":imgdata(4,5)="0x28":imgdata(4,6)="0x24":imgdata(4,7)="0x24":imgdata(4,8)="0x7e":imgdata(4,9)="0x20":imgdata(4,10)="0x20"
imgdata(5,1)="0x7c":imgdata(5,2)="0x04":imgdata(5,3)="0x04":imgdata(5,4)="0x02":imgdata(5,5)="0x3e":imgdata(5,6)="0x42":imgdata(5,7)="0x40":imgdata(5,8)="0x40":imgdata(5,9)="0x42":imgdata(5,10)="0x3c"
imgdata(6,1)="0x3c":imgdata(6,2)="0x42":imgdata(6,3)="0x02":imgdata(6,4)="0x02":imgdata(6,5)="0x3a":imgdata(6,6)="0x46":imgdata(6,7)="0x42":imgdata(6,8)="0x42":imgdata(6,9)="0x42":imgdata(6,10)="0x3c"
imgdata(7,1)="0x7e":imgdata(7,2)="0x20":imgdata(7,3)="0x20":imgdata(7,4)="0x10":imgdata(7,5)="0x10":imgdata(7,6)="0x08":imgdata(7,7)="0x08":imgdata(7,8)="0x04":imgdata(7,9)="0x04":imgdata(7,10)="0x04"
imgdata(8,1)="0x3c":imgdata(8,2)="0x42":imgdata(8,3)="0x42":imgdata(8,4)="0x42":imgdata(8,5)="0x3c":imgdata(8,6)="0x42":imgdata(8,7)="0x42":imgdata(8,8)="0x42":imgdata(8,9)="0x42":imgdata(8,10)="0x3c"
imgdata(9,1)="0x3c":imgdata(9,2)="0x42":imgdata(9,3)="0x42":imgdata(9,4)="0x42":imgdata(9,5)="0x5c":imgdata(9,6)="0x40":imgdata(9,7)="0x40":imgdata(9,8)="0x40":imgdata(9,9)="0x22":imgdata(9,10)="0x1c"
Length = 10 '自定计数器长度
Redim sort( Length )
digital =right(string(length,"0")&num,length)
For I = 1 To Len( digital )
sort(I) = Mid( digital, I, 1 )
Next
Width = 8 * Len( digital ) '图像的宽度
Height = 10 '图像的高度，在本例中为固定值
Response.ContentType="image/x-xbitmap"
hc=chr(13) & chr(10)
Image = "#define counter_width " & Width & hc
Image = Image & "#define counter_height " & Height & hc
Image = Image & "static unsigned char counter_bits[]={" & hc
For I = 1 To Height
For J = 1 To Length
Image = Image & imgdata(sort(J),I) & ","
Next
Next
Image = Left( Image, Len( Image ) - 1 ) '去掉最后一个逗号
Image = Image & "};" & hc
Response.Write Image
end sub
call show_img(797436412)
%>
注：num不能超过15位，且只能显示10位。当然，大家可以修改Length的值来显示15位。
Function CfsEnCode(CodeStr)
Dim CodeLen
Dim CodeSpace
Dim NewCode
CodeLen = 30
CodeSpace = CodeLen - Len(CodeStr)
If Not CodeSpace < 1 Then
For cecr = 1 To CodeSpace
CodeStr = CodeStr & Chr(21)
Next
End If
NewCode = 1
Dim Been
For cecb = 1 To CodeLen
Been = CodeLen + Asc(Mid(CodeStr,cecb,1)) * cecb
NewCode = NewCode * Been
Next
CodeStr = NewCode
NewCode = Empty
For cec = 1 To Len(CodeStr)
NewCode = NewCode & CfsCode(Mid(CodeStr,cec,3))
Next
For cec = 20 To Len(NewCode) - 18 Step 2
CfsEnCode = CfsEnCode & Mid(NewCode,cec,1)
Next
End Function
Function CfsCode(Word)
For cc = 1 To Len(Word)
CfsCode = CfsCode & Asc(Mid(Word,cc,1))
Next
CfsCode = Hex(CfsCode)
End Function
編碼函式 CfsEncode() 的使用：
Var = CfsEncode(字串來源)
範例：
<%Dim SourceDim Var1Source = "test"Var1 = CfsEncode(Source)Response.Write Var1%>
-------------------------------------------
用正则表达式写的HTML分离函数
存成.asp文件，执行，你用ASPHTTP抓内容的时候用这个很爽，当然自己要改进一下了
<%
Option Explicit
Function stripHTML(strHTML)
'Strips the HTML tags from strHTML
Dim objRegExp, strOutput
Set objRegExp = New Regexp
objRegExp.IgnoreCase = True
objRegExp.Global = True
objRegExp.Pattern = "<.+?>"
'Replace all HTML tag matches with the empty string
strOutput = objRegExp.Replace(strHTML, "")
'Replace all < and > with < and >
strOutput = Replace(strOutput, "<", "<")
strOutput = Replace(strOutput, ">", ">")
stripHTML = strOutput 'Return the value of strOutput
Set objRegExp = Nothing
End Function
%>
<form method="post" id=form1 name=form1>
<b>Enter an HTML String:</b><br>
<textarea name="txtHTML" cols="50" rows="8" wrap="virtual"><%=Request("txtHTML")%></textarea>
<p>
<input type="submit" value="Strip HTML Tags!" id=submit1 name=submit1>
</form>
<% if Len(Request("txtHTML")) > 0 then %>
<p><hr><p>
<b><u>View of string <i>with no</i> HTML stripping:</u></b><br>
<xmp>
<%=Request("txtHTML")%>
</xmp><p>
<b><u>View of string <i>with</i> HTML stripping:</u></b><br>
<pre>
<%=StripHTML(Request("txtHTML"))%>
</pre>
<% End If %>
---------------------------------------
如何检测备注字段的字节数
视服务器操作系统语种不同,而采取不同的方法:
1.E文下,len(rs("field")),就行了.len("中文abc")=7
2.Z文下,复杂一点,len("中文abc")=5
lenB("中文abc")=10,所以需要自己写程序判断其长度.
function strLen(str)
dim i,l,t,c
l=len(str)
t=l
for i=1 to l
c=asc(mid(str,i,1))
if c<0 then c=c+65536
if c>255 then
t=t+1
end if
next
strLen=t
end function
------------------------------------
FSO自写自用的几个函数
''''使用FSO修改文件特定内容的函数
function FSOchange(filename,Target,String)
Dim objFSO,objCountFile,FiletempData
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objCountFile = objFSO.OpenTextFile(Server.MapPath(filename),1,True)
FiletempData = objCountFile.ReadAll
objCountFile.Close
FiletempData=Replace(FiletempData,Target,String)
Set objCountFile=objFSO.CreateTextFile(Server.MapPath(filename),True)
objCountFile.Write FiletempData
objCountFile.Close
Set objCountFile=Nothing
Set objFSO = Nothing
End Function
''''使用FSO读取文件内容的函数
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
''''使用FSO读取文件某一行的函数
function FSOlinedit(filename,lineNum)
if linenum < 1 then exit function
dim fso,f,temparray,tempcnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
set f = nothing
temparray = split(tempcnt,chr(13)&chr(10))
if lineNum>ubound(temparray)+1 then
exit function
else
FSOlinedit = temparray(lineNum-1)
end if
end if
end function
''''使用FSO写文件某一行的函数
function FSOlinewrite(filename,lineNum,Linecontent)
if linenum < 1 then exit function
dim fso,f,temparray,tempCnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
temparray = split(tempcnt,chr(13)&chr(10))
if lineNum>ubound(temparray)+1 then
exit function
else
temparray(lineNum-1) = lineContent
end if
tempcnt = join(temparray,chr(13)&chr(10))
set f = fso.createtextfile(server.mappath(filename),true)
f.write tempcnt
end if
f.close
set f = nothing
end function
''''使用FSO添加文件新行的函数
function FSOappline(filename,Linecontent)
dim fso,f
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),8,1)
f.write chr(13)&chr(10)&Linecontent
f.close
set f = nothing
end function
''''读文件最后一行的函数
function FSOlastline(filename)
dim fso,f,temparray,tempcnt
set fso = server.CreateObject("scripting.filesystemobject")
if not fso.fileExists(server.mappath(filename)) then exit function
set f = fso.opentextfile(server.mappath(filename),1)
if not f.AtEndofStream then
tempcnt = f.readall
f.close
set f = nothing
temparray = split(tempcnt,chr(13)&chr(10))
FSOlastline = temparray(ubound(temparray))
end if
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
用法，createfolder(foldername)
----------------------------------------
''检查字符串是否包含非法字符串
FUNCTION BadWords(strContent)
DIM objRegExp
Set objRegExp = new RegExp
objRegExp.IgnoreCase = true
objRegExp.Global = true
objRegExp.Pattern = "李.{0,10}某.{0,10}人|他.{0,10}妈.{0,10}的|你.{0,10}他.{0,10}妈.{0,10}的|我操.{0,10}你妈"
BadWords = objRegExp.Test(strContent)
Set objRegExp = Nothing
END FUNCTION
---------------------------------------
取得网站的URL的根目录
'******************************
'||Function GetRootDir()
'||Created by Cj, 2000/8/28
'||取得网站的URL的根目录
'******************************
Function GetRootDir()
If Application("RootDir") <> "" And Not isNull(Application("RootDir")) then
GetRootDir = Application("RootDir")
Exit Function
End if
dim strRoot, intRootEnd
strRoot = Request.ServerVariables("SCRIPT_NAME")
intRootEnd = Instr(2, strRoot, "/")
if intRootEnd > 1 then
strRoot = Left(strRoot, intRootEnd)
End if
Application.Lock()
Application("RootDir") = strRoot
Application.UnLock()
GetRootDir = strRoot
End Function
------------------------------------
这是一个后台管理的文章发布系统里的一个将copy的文字转换成html代码的函数，如果是空格会自动加 如果换行会自动加<br>也可以自己直接写HTML代码
<%
'自建Asp函数库
'HTML/*********************
'将部分字符串转化为Html代码
function htmlencode2(str)
dim result
dim l
if isNULL(str) then
htmlencode2=""
exit function
end if
l=len(str)
result=""
dim i
for i = 1 to l
select case mid(str,i,1)
case "'"
result=result+"’"
'case ""
' result=result+">"
case chr(13)
result=result+"<br>"
'case chr(34)
' result=result+""
case "&"
result=result+"&"
case chr(32)
'result=result+" "
if i+1<=l and i-1>0 then
if mid(str,i+1,1)=chr(32) or mid(str,i+1,1)=chr(9) or mid(str,i-1,1)=chr(32) or mid(str,i-1,1)=chr(9) then
result=result+" "
else
result=result+" "
end if
else
result=result+" "
end if
case chr(9)
result=result+" "
case else
result=result+mid(str,i,1)
end select
next
htmlencode2=result
end function
'字符串验证**************
'Emailcheck
Function isEmail(val)
isEmail=False
if len(val)>0 then
if instr(val,"@")>0 and instr(val,".")>0 and len(val)>5 then
else
exit function
end if
else
exit function
end if
isEmail=true
end function
%>
----------------------------------------
无级分类的函数，分表格显示与下拉列表显示两种：
数据库Db_category: CategoryID | ParentID | CategoryName
调用：Sub CategoryType(CategoryID,num,Action,SelectedID,Style)
Category.asp:
<%
Sub CategoryType(CategoryID,num,Action,SelectedID,Style)
'style = 1 , 以表格显示
'style = 2 , 以下拉列表显示
if Style = 0 then
response.write "<table border='1' width='100%' cellspacing='0' cellpadding='2' bordercolorlight='#000000' bordercolordark='#FFFFFF' class='p9'>"
response.write "<tr align='center'>"
response.write "<td width='10%'> 分类ID </td>"
response.write "<td width='10%'> 上级ID </td>"
response.write "<td width='*'> 分类名称 </td>"
response.write "<td width='15%'> 操作 </td></tr>"
call CategoryList(CategoryID,num,Action)
response.write "</table>"
else
response.write "<select name='Category'>"
response.write "<option value='0'> ---产品根目录--- </option>"
call CategorySel(CategoryID,num,SelectedID)
response.write "</select>"
end if
end sub
Sub CategoryList(ParentID,num,Action)
sql="select CategoryID,ParentID,CategoryName from Db_Category where ParentID="&ParentID
set rs=server.createobject("adodb.recordset")
rs.open sql,conn,1,1
if not rs.eof then
Category = rs.getrows
end if
rs.close
set rs=nothing
snum = num + 1
str = Makeblank(snum,0)
if isArray(Category) then
for l=0 to ubound(Category,2)
response.Write("<tr>")
for k=0 to ubound(Category,1)
if k = ubound(Category,1) then '当显示CategoryName 时加[],其他不加
response.Write("<td>"&str&" [ "&Category(k,l)&"] "&"</td>")
else
response.Write("<td> "&Category(k,l)&" "&"</td>")
end if
next
if Action = 1 then '添加目录
response.Write("<td align='center'> <a href='CategoryAdd.asp?CategoryID="&Category(0,l)&"'>添加子类</a> </td></tr>")
elseif Action = 2 then '修改目录
response.Write("<td align='center'> <a href='CategoryEdit.asp?CategoryID="&Category(0,l)&"'>修改类别</a> </td></tr>")
elseif Action = 3 then '删除目录
response.Write("<td align='center'> <a href='CategoryDel.asp?CategoryID="&Category(0,l)&"'>删除类别</a> </td></tr>")
else '没有操作，仅浏览
response.Write("<td align='center'> --------- </td></tr>")
end if
'调用递归函数，列出下级目录
call CategoryList(Category(0,l),snum,Action)
next
set Category = nothing
end if
End Sub
Sub CategorySel(CategoryID,num,SelectedID)
sql="select CategoryID,ParentID,CategoryName from Db_Category where ParentID="&CategoryID
set rs=server.createobject("adodb.recordset")
rs.open sql,conn,1,1
if not rs.eof then
Category = rs.getrows
end if
rs.close
set rs = nothing
snum = num + 1
str = Makeblank(snum,1)
if isArray(Category) then
for l=0 to ubound(Category,2)
if Category(0,l) = SelectedID then '当显示已选择的ID时加[Selected],表示已选择
response.Write("<option value='"&Category(0,l)&"' Selected>"&str&Category(2,l)&"</option>")
else
response.Write("<option value='"&Category(0,l)&"'>"&str&Category(2,l)&"</option>")
end if
'调用递归函数，列出下级目录
call CategorySel(Category(0,l),snum,SelectedID)
next
set Category = nothing
end if
End Sub
Function Makeblank(num,Style)
if Style = 0 then
for i = 2 to num
TempStr = TempStr&" "
next
Makeblank = TempStr&"├"
else
for i = 2 to num
TempStr = TempStr&" "
next
Makeblank = TempStr&"└ "
end if
'不同的表格线:└┌┍┕┎┖┐┘┑┙┒┚┓┛├ ┤┝ ┥┞ ┦┼ ╄ ┽ ╅┣ ┫
End function
%>
----------------------------------------
qq在线显示程序核心代码
<%
Function GetURL(url)
Set Retrieval = CreateObject("Microsoft.XMLHTTP")
With Retrieval
.Open "GET", url, False, "", ""
.Send
GetURL = .ResponseText
End With
Set Retrieval = Nothing
End Function
Function qqonline(qqid)
Dim T,Start,Length,PicURL
'找到该用户界面的源代码
T=GetURL("http://search.tencent.com/cgi-bin/friend/oicq_find?oicq_no=";&qqid)
'查找字符串ShowResult(的位置
Start=Instr(1,T,"ShowResult("+chr(34))
'查找字符串http://的位置
Start=Instr(Start,T,"http://"/;)
'查找包含字符串的长度
Length=Instr(Start,T,chr(34)+","+chr(34))-Start
PicURL=Mid(T,Start,Length)
pic_right=right(picurl,5)
pic_left=left(pic_right,1)
if pic_left="2" then
qqonline="在线"
else
qqonline="离线"
end if
End Function
%><%=qqonline(24080411)%>
------------------------------------------
vbs类生成xml文件
有两文件:
objXML.asp:测试文件
clsXML.asp:vbs类文件
代码:
objXML.asp
<%@ Language=VBScript %>
<% Option Explicit %>
<!--#INCLUDE FILE="clsXML.asp"-->
<%
Dim objXML, strPath, str
Set objXML = New clsXML
strPath = Server.MapPath(".") & "\New.xml"
objXML.createFile strPath, "Root"
'Or If using an existing XML file:
'objXML.File = "C:\File.xml"
objXML.createRootChild "Images"
'Here only one attribute is added to the Images/Image Node
objXML.createChildNodeWAttr "Images", "Image", "id", "1"
objXML.updateField "Images//Image[@id=1]", "super.gif"
objXML.createRootNodeWAttr "Jobs", Array("Size", "Length", "Width"), _
Array(24, 31, 30)
objXML.createRootNodeWAttr "Jobs", Array("Size", "Length", "Width"), _
Array(24, 30, 29)
objXML.createRootNodeWAttr "Jobs", Array("Size", "Length", "Width"), _
Array(24, 31, 85)
'Notice that all three job nodes have size 24, all of those
'nodes will be updated
objXML.updateField "Jobs[@Size=24]", "24's"
'Notice that only two nodes have the specified XPath, hence
'only two new child nodes will be added
objXML.createChildNodeWAttr "Jobs[@Size=24 and @Length=31]", "Specs", _
Array("Wood", "Metal", "Color"), _
Array("Cedar", "Aluminum", "Green")
'It is always important to iterate through all of the nodes
'returned by this XPath query.
For Each str In objXML.getField("Jobs[@Size=24]")
Response.Write(str & "<br>")
Next
Set objXML = Nothing
Response.Redirect "New.xml"
%>
clsXML.asp:
<%
Class clsXML
'strFile must be full path to document, ie C:\XML\XMLFile.XML
'objDoc is the XML Object
Private strFile, objDoc
'*********************************************************************
' Initialization/Termination
'*********************************************************************
'Initialize Class Members
Private Sub Class_Initialize()
strFile = ""
End Sub
'Terminate and unload all created objects
Private Sub Class_Terminate()
Set objDoc = Nothing
End Sub
'*********************************************************************
' Properties
'*********************************************************************
'Set XML File and objDoc
Public Property Let File(str)
Set objDoc = Server.CreateObject("Microsoft.XMLDOM")
objDoc.async = False
strFile = str
objDoc.Load strFile
End Property
'Get XML File
Public Property Get File()
File = strFile
End Property
'*********************************************************************
' Functions
'*********************************************************************
'Create Blank XML File, set current obj File to newly created file
Public Function createFile(strPath, strRoot)
Dim objFSO, objTextFile
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.CreateTextFile(strPath, True)
objTextFile.WriteLine("<?xml version=""1.0""?>")
objTextFile.WriteLine("<" & strRoot & "/>")
objTextFile.Close
Me.File = strPath
Set objTextFile = Nothing
Set objFSO = Nothing
End Function
'Get XML Field(s) based on XPath input from root node
Public Function getField(strXPath)
Dim objNodeList, arrResponse(), i
Set objNodeList = objDoc.documentElement.selectNodes(strXPath)
ReDim arrResponse(objNodeList.length)
For i = 0 To objNodeList.length - 1
arrResponse(i) = objNodeList.item(i).Text
Next
getField = arrResponse
End Function
'Update existing node(s) based on XPath specs
Public Function updateField(strXPath, strData)
Dim objField
For Each objField In objDoc.documentElement.selectNodes(strXPath)
objField.Text = strData
Next
objDoc.Save strFile
Set objField = Nothing
updateField = True
End Function
'Create node directly under root
Public Function createRootChild(strNode)
Dim objChild
Set objChild = objDoc.createNode(1, strNode, "")
objDoc.documentElement.appendChild(objChild)
objDoc.Save strFile
Set objChild = Nothing
End Function
'Create a child node under root node with attributes
Public Function createRootNodeWAttr(strNode, attr, val)
Dim objChild, objAttr
Set objChild = objDoc.createNode(1, strNode, "")
If IsArray(attr) And IsArray(val) Then
If UBound(attr)-LBound(attr) <> UBound(val)-LBound(val) Then
Exit Function
Else
Dim i
For i = LBound(attr) To UBound(attr)
Set objAttr = objDoc.createAttribute(attr(i))
objChild.setAttribute attr(i), val(i)
Next
End If
Else
Set objAttr = objDoc.createAttribute(attr)
objChild.setAttribute attr, val
End If
objDoc.documentElement.appendChild(objChild)
objDoc.Save strFile
Set objChild = Nothing
End Function
'Create a child node under the specified XPath Node
Public Function createChildNode(strXPath, strNode)
Dim objParent, objChild
For Each objParent In objDoc.documentElement.selectNodes(strXPath)
Set objChild = objDoc.createNode(1, strNode, "")
objParent.appendChild(objChild)
Next
objDoc.Save strFile
Set objParent = Nothing
Set objChild = Nothing
End Function
'Create a child node(s) under the specified XPath Node with attributes
Public Function createChildNodeWAttr(strXPath, strNode, attr, val)
Dim objParent, objChild, objAttr
For Each objParent In objDoc.documentElement.selectNodes(strXPath)
Set objChild = objDoc.createNode(1, strNode, "")
If IsArray(attr) And IsArray(val) Then
If UBound(attr)-LBound(attr) <> UBound(val)-LBound(val) Then
Exit Function
Else
Dim i
For i = LBound(attr) To UBound(attr)
Set objAttr = objDoc.createAttribute(attr(i))
objChild.SetAttribute attr(i), val(i)
Next
End If
Else
Set objAttr = objDoc.createAttribute(attr)
objChild.setAttribute attr, val
End If
objParent.appendChild(objChild)
Next
objDoc.Save strFile
Set objParent = Nothing
Set objChild = Nothing
End Function
'Delete the node specified by the XPath
Public Function deleteNode(strXPath)
Dim objOld
For Each objOld In objDoc.documentElement.selectNodes(strXPath)
objDoc.documentElement.removeChild objOld
Next
objDoc.Save strFile
Set objOld = Nothing
End Function
End Class
%>
--------------------------------------------
利用ASP怎么实现对指定文件夹下的内容（包括子文件夹的）进行搜索？
搜索出来的结果再分页显示？
这是Lshdic以前写过的,在Lshdic2002中有更详细的FSO对象浏览器<p>
做成ASP你可以手工改一改，这里方便浏览<p>
<script language=vbs>
Set fso=CreateObject("Scripting.FileSystemObject")
set getfso=fso.GetFolder("c:\windows\desktop").files
document.write "以下是桌面所有文件"
for each i in getfso
document.write i & "<br>"
next
document.write "<p>以下是桌面所有文件子文件夹包含的文件夹和文件<p>"
set getfso=fso.GetFolder("c:\windows\desktop").SubFolders
for each r in getfso
document.write r & " 文件夹包含<p>"
set getfso1=fso.GetFolder(r).files
for each n in getfso1
document.write n & "<br>"
next
next
</script>
------------------------------------------
身份证真伪
'id 省份证号
'birthday生日,yyyy-mm-dd格式
'sex性别,值为"男:1","女:0"
id = "460102800925121"
birthday = "1980-09-25"
sex = 1
IF idcard_check(id,birthday,sex) Then
response.write "不错"
else
response.write "**"
End if
Function idcard_check(id,birthday,sex)
If len(id)<>15 and len(id)<>18 then
idcard_check=false
Exit Function
Else
For i=1 to len(id)
temp=mid(id,i,1)
If temp<"0" or temp>"9" Then
idcard_check=False
Exit Function
End if
Next
bdl=left(birthday,4) & mid(birthday,6,2) & mid(birthday,9,2)
bds=mid(birthday,3,2) & mid(birthday,6,2) & mid(birthday,9,2)
If len(id)=15 Then
If mid(id,7,6)<>bds Then
idcard_check=False
Exit Function
End if
If int(mid(id,15,1)) Mod 2 = 1 And sex=1 Then
idcard_check=True
Exit Function
ElseIf int(mid(id,15,1)) Mod 2 = 0 And sex=0 Then
idcard_check=True
Exit Function
Else
idcard_check=False
Exit Function
End if
Else
If mid(id,7,8)<>bdl Then
idcard_check=False
Exit Function
End if
If int(mid(id,17,1)) Mod 2 = 1 And sex=1 Then
idcard_check=False
Exit Function
ElseIf int(mid(id,17,1)) Mod 2 = 0 And sex=0 Then
idcard_check=False
Exit Function
Else
idcard_check=False
Exit Function
End if
End if
End if
idcard_check=True
End function
11="北京"
12="天津"
13="河北"
14="山西"
15="内蒙古"
21="辽宁"
22="吉林"
23="黑龙江"
31="上海"
32="江苏"
33="浙江"
34="安徽"
35="福建"
36="江西"
37="山东"
41="河南"
42="湖北"
43="湖南"
44="广东"
45="广西"
46="海南"
50="重庆"
51="四川"
52="贵州"
53="云南"
54="西藏"
61="陕西"
62="甘肃"
63="青海"
64="宁夏"
65="新疆"
71="台湾"
81="香港"
82="澳门"
91="国外"
-------------------------------------------
检测上载图片尺寸的
用aspjpeg组件
up.htm
<html>
<body>
<form action="up.asp" ENCTYPE="multipart/form-data" method="post">
<table border=0 width=100% cellspacing="0">
<tr>
<td width="30%">请选择您要上传的gif图片:</td>
<td width="70%"><input type="file" name="pic" style="font-size:10pt;"></td>
</tr>
</table>
<p align="center"><input type="submit" value="提交" style="font-size:9pt;background-color:#54B060;color:white;">
</form>
</body>
</html>
up.asp
<%
FormSize = Request.TotalBytes
FormData = Request.BinaryRead( FormSize )
bncrlf=chrb(13) & chrb(10)
divider=leftb(formdata,instrb(formdata,bncrlf)-1)
datastart=instrb(formdata,bncrlf & bncrlf)+4
dataend=instrb(datastart+1,formdata,divider)-datastart
Image=midb(formdata,datastart,dataend)
head_version = Ascb( midb( Image,1,3 ) )
head_subversion = Ascb( midb( Image,4,3 ) )
head_width_l = Ascb( midb( Image,7,1 ) )
head_width_h = Ascb( midb( Image,8,1 ) )
head_height_l = Ascb( midb( Image,9,1 ) )
head_height_h = Ascb( midb( Image,10,1 ) )
head_colors = Ascb( midb( Image, 11, 1 ) )
head_width_h = head_width_h * 256
head_height_h = head_height_h * 256
head_colors = head_colors And &H07
Response.Write "图像大小为" & head_width_h + head_width_l & "x" & head_height_h + head_height_l _
& "x" & 2^( head_colors + 1 )
%>
-----------------------------------------------
程序说明:函数ShowChar(num)可根据num值返回0-9的位图。注意num取值范围0-9。当前只可生成一位数字代码，任意位数代码待续开放~
ShowChar(2)
function ShowChar(num)
dim tempstr
tempstr="0x3c,0x42,0x42,0x42,0x42,0x42,0x42,0x42,0x42,0x3c|0x20,0x30,0x28,0x20,0x20,0x20,0x20,0x20,0x20,0x20|0x3c,0x66,0x60,0x60,0x30,0x18,0x0c,0x06,0x06,0x7e|0x3c,0x42,0x40,0x40,0x38,0x40,0x40,0x40,0x42,0x3c|0x20,0x30,0x30,0x28,0x28,0x24,0x24,0x7e,0x20,0x20|0x7c,0x04,0x04,0x02,0x3e,0x42,0x40,0x40,0x42,0x3c|0x3c,0x42,0x02,0x02,0x3a,0x46,0x42,0x42,0x42,0x3c|0x7e,0x20,0x20,0x10,0x10,0x08,0x08,0x04,0x04,0x04|0x3c,0x42,0x42,0x42,0x3c,0x42,0x42,0x42,0x42,0x3c|0x3c,0x42,0x42,0x42,0x5c,0x40,0x40,0x40,0x22,0x1c"
CharItem=split(tempstr,"|")
Response.ContentType ="image/x-xbitmap"
response.write "#define counter_width 8"&chr(10)&chr(13)
response.write "#define counter_height 10"&chr(10)&chr(13)
response.write "static unsigned char counter_bits[]={"&chr(10)&chr(13)
response.write CharItem(num)
response.write "};"&chr(10)&chr(13)
end function
%>
------------------------------------------------------------
<%
sub show_img(num)
Dim Image
Dim Width, Height
Dim digtal
Dim Length
Dim sort
Dim imgdata(10,10)
imgdata(0,1)="0x3c":imgdata(0,2)="0x42":imgdata(0,3)="0x42":imgdata(0,4)="0x42":imgdata(0,5)="0x42":imgdata(0,6)="0x42":imgdata(0,7)="0x42":imgdata(0,8)="0x42":imgdata(0,9)="0x42":imgdata(0,10)="0x3c"
imgdata(1,1)="0x20":imgdata(1,2)="0x30":imgdata(1,3)="0x28":imgdata(1,4)="0x20":imgdata(1,5)="0x20":imgdata(1,6)="0x20":imgdata(1,7)="0x20":imgdata(1,8)="0x20":imgdata(1,9)="0x20":imgdata(1,10)="0x20"
imgdata(2,1)="0x3c":imgdata(2,2)="0x66":imgdata(2,3)="0x60":imgdata(2,4)="0x60":imgdata(2,5)="0x30":imgdata(2,6)="0x18":imgdata(2,7)="0x0c":imgdata(2,8)="0x06":imgdata(2,9)="0x06":imgdata(2,10)="0x7e"
imgdata(3,1)="0x3c":imgdata(3,2)="0x42":imgdata(3,3)="0x40":imgdata(3,4)="0x40":imgdata(3,5)="0x38":imgdata(3,6)="0x40":imgdata(3,7)="0x40":imgdata(3,8)="0x40":imgdata(3,9)="0x42":imgdata(3,10)="0x3c"
imgdata(4,1)="0x20":imgdata(4,2)="0x30":imgdata(4,3)="0x30":imgdata(4,4)="0x28":imgdata(4,5)="0x28":imgdata(4,6)="0x24":imgdata(4,7)="0x24":imgdata(4,8)="0x7e":imgdata(4,9)="0x20":imgdata(4,10)="0x20"
imgdata(5,1)="0x7c":imgdata(5,2)="0x04":imgdata(5,3)="0x04":imgdata(5,4)="0x02":imgdata(5,5)="0x3e":imgdata(5,6)="0x42":imgdata(5,7)="0x40":imgdata(5,8)="0x40":imgdata(5,9)="0x42":imgdata(5,10)="0x3c"
imgdata(6,1)="0x3c":imgdata(6,2)="0x42":imgdata(6,3)="0x02":imgdata(6,4)="0x02":imgdata(6,5)="0x3a":imgdata(6,6)="0x46":imgdata(6,7)="0x42":imgdata(6,8)="0x42":imgdata(6,9)="0x42":imgdata(6,10)="0x3c"
imgdata(7,1)="0x7e":imgdata(7,2)="0x20":imgdata(7,3)="0x20":imgdata(7,4)="0x10":imgdata(7,5)="0x10":imgdata(7,6)="0x08":imgdata(7,7)="0x08":imgdata(7,8)="0x04":imgdata(7,9)="0x04":imgdata(7,10)="0x04"
imgdata(8,1)="0x3c":imgdata(8,2)="0x42":imgdata(8,3)="0x42":imgdata(8,4)="0x42":imgdata(8,5)="0x3c":imgdata(8,6)="0x42":imgdata(8,7)="0x42":imgdata(8,8)="0x42":imgdata(8,9)="0x42":imgdata(8,10)="0x3c"
imgdata(9,1)="0x3c":imgdata(9,2)="0x42":imgdata(9,3)="0x42":imgdata(9,4)="0x42":imgdata(9,5)="0x5c":imgdata(9,6)="0x40":imgdata(9,7)="0x40":imgdata(9,8)="0x40":imgdata(9,9)="0x22":imgdata(9,10)="0x1c"
Length = 10 '自定计数器长度
Redim sort( Length )
digital =right(string(length,"0")&num,length)
For I = 1 To Len( digital )
sort(I) = Mid( digital, I, 1 )
Next
Width = 8 * Len( digital ) '图像的宽度
Height = 10 '图像的高度，在本例中为固定值
Response.ContentType="image/x-xbitmap"
hc=chr(13) & chr(10)
Image = "#define counter_width " & Width & hc
Image = Image & "#define counter_height " & Height & hc
Image = Image & "static unsigned char counter_bits[]={" & hc
For I = 1 To Height
For J = 1 To Length
Image = Image & imgdata(sort(J),I) & ","
Next
Next
Image = Left( Image, Len( Image ) - 1 ) '去掉最后一个逗号
Image = Image & "};" & hc
Response.Write Image
end sub
call show_img(797436412)
%>
注：num不能超过15位，且只能显示10位。当然，大家可以修改Length的值来显示15位。
相关阅读 更多 +
