使用无组件文件上传时出错:

Microsoft VBScript 编译器错误 错误 '800a03f6'

缺少 'End'

/iisHelp/common/500-100.asp，行242

服务器对象 错误 'ASP 0178 : 80070005'

Server.CreateObject 访问错误

/schoolmate/include/upclass.asp，行40

检查权限时Server.CreateObject 的调用失败。对此对象的访问被拒。
第40行的代码是:
Set objData = Server.CreateObject("Scripting.Dictionary")
问题出现在 Scripting.Dictionary 上面,空间好像不支持Scripting.Dictionary
放到别的空间或本机可正常使用.

请教怎样才能让服务器支持这个功能呢？

是一个同学录中的图片上传功能！

这是UPLOADPHOTO.ASP文件的内容

<!--#INCLUDE FILE="include/upclass.asp"-->
<%
Server.ScriptTimeOut=99999
locat="班级相册"

if membername="" Then
ErrMsg=ErrMsg+"<br>"+"<li>您还没有<a href=login.asp>登录</a>。"
Call top(1,1)
Call Error("Information",ErrMsg)
Else
Dim ClsID,Degree,ClassName
ClsID=Request("ClassID")
joinstatus=chkjoinclass(ClsID)
if joinstatus<>"" Then
Call top(1,1)
Call Error("Exclamation",joinstatus)
Else
Select Case Request("action")
Case "upload"
act="上传照片"
Call uploadphoto()
Case "Add"
act="上传照片"
Call top(3,1)
Call upform()
End Select
End if
End if

Sub uploadphoto()

dim upFotoNum
Dim clsData
dim sql
dim FoundErr,ErrMsg
Dim LastUpload

if chkpost=False Then
ErrMsg=ErrMsg+"<Br>"+"<li>您提交的数据不合法，请不要从同学录外部提交信息。"
founderr=True
ElseIf BoolVar(6)=False Then
ErrMsg=ErrMsg+"<br>"+"<li>操作失败，系统管理员禁止使用此项功能."
founderr=True
ElseIf not sysadmin and IntVar(4)<>0 then
upFotoNum=request.cookies("upFotoNum")
if upFotoNum ="" then upFotoNum=0
upFotoNum=cint(upFotoNum)
if UpFotoNum>=IntVar(4) Then
ErrMsg=ErrMsg+"<br>"+"<li>操作失败，每次只能上传"&IntVar(4)&"个文件!"
founderr=True
End if
end if
if founderr Then
Call top(3,1)
Call Error("Exclamation",ErrMsg)
Exit Sub
End if

Set clsData = new cupload
clsData.CaseSensitive = False

title=clsData.binRequest("title",0).Value
if title="" Then
ErrMsg=ErrMsg+"<br>"+"<li>请输入图片标题."
founderr=True
Else
title=trim(checkstr(title))
if strlength(title)>30 or strlength(title)<2 Then
ErrMsg=ErrMsg+"<br>"+"<li>图片标题不能超过30个字符或少于2个字符。"
founderr=True
End if
End if

remark=clsData.binRequest("remark",0).Value
if remark="" Then
ErrMsg=ErrMsg+"<br>"+"<li>请输入图片说明."
founderr=True
Else
remark=trim(checkstr(remark))
if strlength(remark)>250 or strlength(remark)<2 Then
ErrMsg=ErrMsg+"<br>"+"<li>图片说明不能超过250个字符或少于2个字符。"
founderr=True
End if
End if

pictype=cint(clsData.binRequest("pictype",0).Value)

sfotofile=clsData.binRequest("UpFile",0).ShortFileName
fileExt=lcase(right(sfotofile,4))
if fileEXT<>".gif" and fileEXT<>".jpg" and fileEXT<>".bmp" and fileEXT<>".png" Then
ErrMsg=ErrMsg+"<br>"+"<li>所要上传的图片格式系统不支持！"
founderr=True
End if

chkfoto=clsData.binRequest("UpFile",0).IsImage(imgWidth,imgHeight,imgType,imgSize,imgBit)
if chkfoto=False Then
ErrMsg=ErrMsg+"<br>"+"<li>非法的图片格式！"
founderr=True
End if

if founderr=True Then
Call top(3,1)
Call Error("Information",ErrMsg)
Exit Sub
End if

if imgSize<100 Then
ErrMsg=ErrMsg+"<br>"+"<li>请选择你要上传的图片或你的图片文件太小."
founderr=True
ElseIf IntVar(2)<>0 and imgSize>(IntVar(2)*1024) Then
ErrMsg=ErrMsg+"<br>"+"<li>文件大小超过了"&IntVar(2)&"K限制."
founderr=True
Else
strsql="Select sum(filesize) from photo where classid="&clsid
Set rs=conn.execute(strsql)
if not (rs.eof and rs.bof) Then
albumsize=rs(0)
if (albumsize+imgsize)>(IntVar(3)*1024*1024) Then
ErrMsg=ErrMsg+"<br>"+"<li>上传失败！超过了班级相册容量"&IntVar(3)&"M限制."
founderr=True
End if
End if
Set rs=Nothing
End if

if founderr=True Then
Call top(3,1)
Call Error("Information",ErrMsg)
Exit Sub
End if

'if IsFSOInstalled=True Then
' Set fso = CreateObject("Scripting.FileSystemObject")
' path=server.mappath(StrVar(8))
' if fso.folderexists(path)=False Then
' fso.createfolder(path)
' End if
' Set fso=Nothing
'End if

randomize
ranNum=int(9000*rnd)+1000
dfotofile=year(now)&month(now)&day(now)&hour(now)&minute(now)&second(now)&ranNum&fileExt

upfoto=clsData.SavetoFile("UpFile",0,server.mappath(StrVar(8)&dfotofile),False)

Set clsData = Nothing

if upfoto=4 Then
ErrMsg=ErrMsg+"<br>"+"<li>图片上传失败！保存路径的目录不存在."
founderr=True
ElseIf upfoto=8 Then
ErrMsg=ErrMsg+"<br>"+"<li>图片上传失败！该文件正在被使用."
founderr=True
ElseIf upfoto=16 Then
ErrMsg=ErrMsg+"<br>"+"<li>图片上传失败！该目录没有可写权限."
founderr=True
ElseIf upfoto=32 Then
ErrMsg=ErrMsg+"<br>"+"<li>图片上传失败！文件已经存在."
founderr=True
End if

if founderr=True Then
Call top(3,1)
Call Error("Information",ErrMsg)
Exit Sub
ElseIf upfoto=0 Then

if BoolVar(13) and IntVar(5)<>0 then
sql="select max(uptime) from photo where classid="&ClsID
set rs=conn.execute(sql)
LastUpload=rs(0)
end if

if sysadmin Then fotostat=True Else fotostat=not BoolVar(7)

sql="insert into photo (filename,filesize,typeid,name,title,remark,classid,width,height,depth,"&_
"format,passed) values ('"&dfotofile&"',"&imgSize&","&pictype&",'"&membername&_
"','"&title&"','"&remark&"',"&clsid&","&imgWidth&","&imgHeight&","&imgBit&",'"&imgType&"',"&fotostat&")"

conn.execute(sql)

upFotoNum=upFotoNum+1
response.cookies("UpFotoNum")=upFotoNum

sql="update student Set point=point+"&PointSet(19)&" where userid='"&membername&"'"
conn.execute(sql)

if BoolVar(13) and IntVar(5)<>0 then

sql="Select distinct S.email from student S inner join joinclass J on S.userid=J.userid where J.classid="&_
ClsID&" and J.userid<>'"&membername&"' and J.isauditing=False and S.NewFotoFlag=True"
if not isNull(LastUpload) then sql=sql&" and J.lastvisit > #"&LastUpload&"#"
Set rs=Conn.Execute(sql)

if not (rs.eof and rs.bof) Then
mailto=rs(0)
rs.movenext
do until rs.eof
mailto=mailto&","&rs(0)
rs.movenext
loop

mailfrom=StrVar(2)
mailtopic=StrVar(1)&"-班级相片通知"
mailbody=vbcrlf&"您好！您的班级:"&ClassName&"有新的相片上传,请注意查看！"&vbcrlf&vbcrlf
mailbody=mailbody&space(20)&"-------"&StrVar(1)&vbcrlf
mailbody=mailbody&space(20)&SchoolmateURL&vbclf

select case IntVar(5)
case 1
Call jmail_smtp()
case 2
Call Cdonts()
case 3
Call aspemail()
case 4
Call jmail_msg()
End select

End if

end if

rURL="ClassAlbum.asp?ClassID="&clsid&"&Action=ShowAlbum&Catalog="&pictype
rtitle="成功上传相片"

if fotostat=True Then
rmsg="本页面将在2秒后自动返回班级相册页面<br><ul>"
rtm=2
Else
rmsg="图片成功上传，在未经系统管理员审核之前暂时还不能被其他同学看到。<br><ul>"
rtm=5
End if

rmsg=rmsg&"<li><a href="&rURL&">返回班级相册</a></li>"&_
"</ul>"
Call top(3,1)
Redirect rtm,rurl,rtitle,rmsg

End if

End Sub

Sub upform()

%><!--#INCLUDE FILE="script/sendnow.inc" --><%
Response.Write "<div id=""sponsorAdDiv"" style=""visibility:hidden"">"&_
"<table width=400 height=70 Class=TableBorder border=0 cellspacing=1>"&_
"<tr><td><table width=""100%"" height=""100%"" border=0 cellspacing=0>"&_
"<tr Class=LightTableBody><td>&nbsp;&nbsp;&nbsp;&nbsp;正在上传图片，请稍候......</td>"&_
"</tr></table>"&_
"</td></tr></table></div>"&_
"<script language=JavaScript src=""script/upload.js""></script>"&_
"<form name=""frmupload"" action=""UploadPhoto.asp?ClassID="&ClsID&"&Action=upload"" method=post enctype=""multipart/form-data"" onsubmit=""submitonce(this);initAd();"">"&_
"<input type=hidden name=pictype value="&Request("catalog")&">"&_
"<table border=0 cellspacing=1 width=600 cellpadding=5 Class=TableBorder align=center>"&_
"<tr><th height=25 align=center colspan=2>上传照片</th></tr>"&_
"<tr Class=LightTableBody><td height=13 colspan=2>"&_
"<table width=""95%"" border=0 cellspacing=16 class=mp align=center><tr><td>"&_
"<FONT color=#284654><b>注意事项：</b><BR>1. 请勿发布违反计算机信息网络安全相关条例的有害信息，一经发现，后果自负！<BR>"&_
"2. 请勿发布和与本站内容无关的照片（如卡通、壁纸、电影剧照、海报、明星、球星、宠物、植物等），一经发现，立即删除。<BR>"&_
"3. 仅接受JPG,GIF,BMP和PNG格式的图片,大小不超过<font color=brown>"&IntVar(2)&"K</font>字节。<BR></FONT>"&_
"</td></tr></table>"&_
"</td></tr>"&_
"<tr Class=LightTableBody><td align=center>提 供 者：&nbsp;&nbsp;"&_
"<input type=text size=41 style=""WIDTH: 295px; HEIGHT: 20px"" name=author value="&getrealname(membername)&" disabled></td>"&_
"</tr><tr Class=LightTableBody><td align=center>照片标题：&nbsp;&nbsp;"&_
"<input size=41 name=title maxlength=30 style=""WIDTH: 295px; HEIGHT: 20px""></td></tr>"&_
"<tr Class=LightTableBody><td align=center valign=top>照片说明：&nbsp;&nbsp;"&_
"<textarea name=remark style=""WIDTH: 295px; HEIGHT: 80px""></TEXTAREA></td></tr>"&_
"<tr Class=LightTableBody><td align=center>照片位置：&nbsp;&nbsp;"&_
"<INPUT type=file size=23 name=UpFile style=""height:16pt;width=163pt"" onchange=""return chgpre();"">&nbsp;"&_
"<input type=submit name=prvbtn value=预览照片 onclick=""return preview();"" class=button disabled></td></tr>"&_
"<tr Class=LightTableBody id=""prv"" style=""DISPLAY: none""><td height=13 colspan=2 align=center>"&_
"<img name=foto onload=""javascript:if(this.width>550){this.width=550}""></td></tr>"&_
"<tr Class=LightTableBody><td height=13 colspan=2>"&_
"<table width=""100%"" cellspacing=13><tr><td valign=top>&nbsp;&nbsp;"&_
"<img src=images/reminder.gif align=absmiddle space=4>如果你的照片文件较大或网络速度太慢，上载过程可能要一段时间，请耐心等待！"&_
"</td></tr></table>"&_
"</td></tr>"&_
"<tr Class=DarkTableBody><td height=30 align=right colspan=2>"&_
"<input type=submit value=开始上传 name=upsubmit class=button disabled>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;</td>"&_
"</tr></table></form>"

End Sub%>

<%Call footer%>



这是ＵＰＣＬＡＳＳ。ＡＳＰ文件的内容

<%
'无组件文件上传 ver2.2

'上传类
Class CUpload
Private arrData
Private stmRequest
Private objData
Private m_blnCaseSensitive
Private mCharSet
Private Sub Class_Initialize '构造函数（初始化数据）
mCharSet = "gb2312"
dim intFileSize,binFileData
intFileSize = Request.totalbytes '客户端响应数据字节的大小
m_blnCaseSensitive = false
'没有数据退出处理
if intFileSize = 0 then
exit sub
end if
set stmRequest = CreateObject("Adodb.Stream")
With stmRequest
.Mode = 3
.Type = 1
.Open
.Write Request.BinaryRead(intFileSize) '得到数据量要小于或等于totalbytes
.Position = 0
binFileData = .Read '将数据流赋值给变量 binFileData
End With
if lenB(binFileData)=0 then exit sub

'取得分割字符串
dim binCrLf,binDivider,intDividerLen
binCrLf = chrB(13) & chrB(10)
if instrB(binFileData,binCrLf) - 1 < 0 then exit sub '如果没有binCrLf退出循环
binDivider = leftB(binFileData,instrB(binFileData,binCrLf) - 1)
intDividerLen=lenB(binDivider) + 2

'将上传数据成组分割
dim intStartPoint,intEndPoint,binBlock,intLoop
set objData = Server.CreateObject("Scripting.Dictionary")
intStartPoint = 1
intLoop = 0
do
intEndPoint = instrB(intStartPoint + 1,binFileData,binDivider,0)
if intEndPoint = 0 then exit do
binBlock = midB(binFileData,intStartPoint + intDividerLen,intEndPoint - intStartPoint - intDividerLen)
'*********************************分解数据***********************************************
objData.Add intLoop,splitData(binBlock,intStartPoint + intDividerLen)
'*********************************分解数据结束***********************************************
intStartPoint = intEndPoint
intLoop = intLoop + 1
Loop
'将所有数据放入arrData数组
arrData = objData.Items
End Sub

Private Sub Class_Terminate '析构函数（释放内存数据）
dim intLoop
objData.RemoveAll

set objData = nothing
for intLoop = Lbound(arrData) to Ubound(arrData)
set arrData(intLoop) = nothing
next
stmRequest.close
set stmRequest=nothing
End Sub
'设置区分大小写属性
Public Property Get CaseSensitive()
CaseSensitive = m_blnCaseSensitive
End Property
Public Property Let CaseSensitive(blnData)
m_blnCaseSensitive = blnData
End Property
'设置区文本字符集
Public Property Get CharSet()
CharSet = mCharSet
End Property
Public Property Let CharSet(blnData)
mCharSet = blnData
End Property

'将二进制数据转化为对象
Private Function splitData(binData,intBlockStart)
dim binCrLf,intPoint,clsData,binName,binValue,intBinStart
binCrLf = chrB(13) & chrB(10)
intPoint = instrB(binData,binCrLf & binCrLf)
binName = leftB(binData,intPoint-1)
if lenB(binData)-intPoint-5 > 0 then
binValue = midB(binData,intPoint+4,lenB(binData)-intPoint-5)
intBinStart = intBlockStart + intPoint + 2
end if
dim intStartPoint,intCount
intStartPoint = 0
intCount = 0
do while(instrB(intStartPoint + 1,binName,chrb(asc(";"))))
intStartPoint = instrB(intStartPoint + 1,binName,chrb(asc(";")))
intCount = intCount + 1
loop
set clsData = new CFormItem
if intCount > 1 then
clsData.DataType = 1 '二进制为1
else
clsData.DataType = 0 '文本为0
end if
dim binDivider,intStart,intLen
binDivider = chrb(Asc(";")) & chrb(Asc(" ")) & chrb(Asc("n")) & chrb(Asc("a")) & chrb(Asc("m")) & chrb(Asc("e")) & chrb(Asc("=")) & chrb(Asc(""""))
intPoint = instrB(binName,binDivider)
intStart = intPoint + 8
intLen = instrB(intStart,binName, chrb(Asc(""""))) - intStart
clsData.Name = BintoStr(midB(binName,intStart,intLen))
clsData.Start = intBinStart
if clsData.DataType then
if lenB(binValue) mod 2 <> 0 then
clsData.Value = binValue & chrB(0)
else
clsData.Value = binValue
end if
binDivider = chrb(Asc(";")) & chrb(Asc(" ")) & chrb(Asc("f")) & chrb(Asc("i")) & chrb(Asc("l")) & chrb(Asc("e")) & chrb(Asc("n")) & chrb(Asc("a")) & chrb(Asc("m")) & chrb(Asc("e")) & chrb(Asc("=")) & chrb(Asc(""""))
intPoint = instrB(binName,binDivider)
intStart = intPoint + 12
intLen = instrB(intStart,binName, chrb(Asc(""""))) - intStart
clsData.FileName = BintoStr(midB(binName,intStart,intLen))
binDivider = binCrLf & chrb(Asc("C")) & chrb(Asc("o")) & chrb(Asc("n")) & chrb(Asc("t")) & chrb(Asc("e")) & chrb(Asc("n")) & chrb(Asc("t")) & chrb(Asc("-")) & chrb(Asc("T")) & chrb(Asc("y")) & chrb(Asc("p")) & chrb(Asc("e"))
intPoint = instrB(binName,binDivider)
intStart = intPoint + 16
clsData.ContentType = BintoStr(midB(binName,intStart))
else
clsData.Value = BintoStr(binValue)
end if
set splitData = clsData
End Function

'转化二进制数据为字符串
Function BintoStr(byRef binStr)
Dim byStream,szReturn

Set byStream = Server.CreateObject("ADODB.Stream") '建立一个流对象
With byStream
.Mode = 3 'adModeUnknow 0; adModeRead 1; adModeWrite 2; adModeReadWrite 3; （默认值）
.Type = 2 'adTypeBinary 1; adTypeText 2 ,'设置流对象的类型为字符流
.Open '打开流对象
.WriteText binStr '把binStr写入流对象中
.Position = 0 '设置流对象的起始位置是0,要设置CharSet属性必须将先Position属性设为0
.Charset = mCharset '设置流对象的编码方式为mCharset
.Position = 2 '设置流对象的起始位置是2（过滤掉开始的一个控制字符
'这个控制字符是WriteText方法按默认属性Charset="Unicode"
'读入数据的时候自动加到数据开头的,字符的值是FF3F
'这个控制字符占2字节,所以Position设置为2
'表示略过2个字节,下面的ReadText方法从Position开始读数据）
szReturn = .ReadText '把流对象的内容保存在szReturn变量中
.close '关闭流对象
End With
Set byStream = Nothing '销毁流对象
BintoStr = szReturn
End Function
'************************************************接口函数开始**********************************************************
'读取数据Class
Public Function BinRequest(strName,intNum)
dim blnExists,intCount,intLoop
intCount = 0
if isEmpty(arrData) then
set BinRequest = new CFormItem
exit function
end if
for intLoop = 0 to ubound(arrData)
if not isObject(arrData(intLoop)) then exit for
if m_blnCaseSensitive then '如果大小写敏感
if strName = arrData(intLoop).Name then
if intCount = intNum then
blnExists = true
exit for
end if
intCount = intCount + 1
end if
else
if UCase(strName) = UCase(arrData(intLoop).Name)then
if intCount = intNum then
blnExists = true
exit for
end if
intCount = intCount + 1
end if
end if
next
if blnExists then
set BinRequest = arrData(intLoop)
else
set BinRequest = new CFormItem
end if
End Function

'判断存在个数
Public Function BinCount(strName)
dim intCount,intLoop
intCount = 0
if isEmpty(arrData) then
BinCount = intCount
exit function
end if
for intLoop = 0 to ubound(arrData)
if not isObject(arrData(intLoop)) then exit for
if m_blnCaseSensitive then '如果大小写敏感
if strName = arrData(intLoop).Name then
intCount = intCount + 1
end if
else
if UCase(strName) = UCase(arrData(intLoop).Name) then
intCount = intCount + 1
end if
end if
next
BinCount = intCount
End Function

'判断是否存在
Public Function IsExists(strName)
dim blnExists,intLoop
blnExists = false
if isEmpty(arrData) then
IsExists = blnExists
exit function
end if
for intLoop = 1 to ubound(arrData)
if not isObject(arrData(intLoop)) then exit for
if m_blnCaseSensitive then '如果大小写敏感
if strName = arrData(intLoop).Name then
blnExists = true
exit for
end if
else
if UCase(strName) = UCase(arrData(intLoop).Name) then
blnExists = true
exit for
end if
end if
next
IsExists = blnExists
End Function

'保存到文件
Public Function SavetoFile(strName,intNum,strFullName,blnForce)
dim clsData
set clsData = BinRequest(strName,intNum)
If IsEmpty(BinRequest(strName,intNum).DataType) Then
SavetoFile = 1 '该控件不存在
Exit Function
End if
If len(BinRequest(strName,intNum).value) = 0 Then
SavetoFile = 2 '该控件值为空
Exit Function
End If
dim objFSO
set objFSO = server.CreateObject("Scripting.FileSystemObject")
if not objFSO.FolderExists(GetPath(strFullName)) then
SavetoFile = 4 '保存路径的目录不存在
Exit Function
end if
set objFSO = nothing

dim stmData
set stmData = Server.CreateObject("ADODB.Stream")
with stmData
.Mode = 3 'adModeWrite; 4 adModeReadWrite; 1 adModeRead （默认值）
.Type = 1 'adTypeBinary
.Open
dim objFs
set objFs = server.CreateObject("Scripting.FileSystemObject")
if blnForce then
stmRequest.Position = clsData.Start
stmRequest.Copyto stmData,lenB(clsData.value)
on Error Resume Next
.SavetoFile strFullName,2 'adSaveCreateOverWrite
if Err <> 0 then
if objFs.FileExists(strFullName) then
SavetoFile = 8 '文件不能保存，该文件正在被使用
else
SavetoFile = 16 '文件不能保存，请确定该目录具有可写权限
end if
else
SavetoFile = 0
End if
on Error goto 0
else
if objFs.FileExists(strFullName) then
SavetoFile = 32 '非强制覆盖状态，文件已经存在
else
stmRequest.position = clsData.Start
stmRequest.copyto stmData,lenB(clsData.value)
on Error Resume Next
.SavetoFile strFullName,2 'adSaveCreateOverWrite
if Err <> 0 then
SavetoFile = 16 '文件不能保存，请确定该目录具有可写权限
else
SavetoFile = 0
End if
on Error goto 0
end if
end if
set objFs = nothing
.close
end with
set stmData = nothing
End Function
Private Function GetPath(strFullName)
dim strReturn
strReturn = left(strFullName,InstrRev(strFullName,"\"))
GetPath = strReturn
End function
'************************************************接口函数结束**********************************************************

End Class

'定义数据类（存放form数据）
Class CFormItem
Private mName
Private mValue
Private mType '数据类型：二进制数据取1； 文本数据取0
Private mFileName
Private mContentType
Private mStart '二进制数据的开始结束位置
'*************属性设置开始********************************
Public Property Get Name()
name = mName
end Property
Public Property Let Name(byVal varData)
mName = varData
end Property
Public Property Get Value()
value = mValue
end Property
Public Property Let Value(byVal varData)
mValue = varData
end Property
Public Property Get DataType()
DataType = mType
end Property
Public Property Let DataType(byVal varData)
mType = varData
end Property
Public Property Get FileName()
FileName = mFileName
end Property
Public Property Let FileName(byVal varData)
mFileName = varData
end Property
Public Property Get ContentType()
ContentType = mContentType
end Property
Public Property Let ContentType(byVal varData)
mContentType = varData
end Property
Public Property Get Start()
Start = mStart
end Property
Public Property Let Start(byVal varData)
mStart = varData
end Property
'取得文件名
Public Property Get ShortFileName()
dim strReturn
strReturn = Mid(mFileName,InstrRev(mFileName,"\")+1)
ShortFileName = strReturn
End Property
'*************属性设置结束********************************
'******************私有函数开始******************************
'返回高位在后的整数（Intel顺序）
Private Function ConvertIntel(strTemp)
dim i
for i = 1 to lenB(strTemp)
ConvertIntel = ConvertIntel + ascb( midb( strTemp, i, 1 ) ) * ( 2 ^ ( (i-1) * 8 ) )
next
end Function
'返回高位在前的整数（Motorola顺序）
Private Function ConvertMotorola(strTemp)
dim i,j
j = 0
for i = lenB(strTemp) to 1 step -1
ConvertMotorola = ConvertMotorola + ascb( midb( strTemp, i, 1 ) ) * ( 2 ^ ( j * 8 ) )
j = j + 1
next
end Function

'******************私有函数结束******************************

'****************************************接口函数开始***************************************

'处理图片信息
Public Function IsImage(byRef imgWidth,byRef imgHeight,byRef imgType,byRef imgSize,byRef imgBit)
if mType = 0 or LenB(mValue) = 0 then
IsImage = false
imgWidth = -1
imgHeight = -1
imgType = "unknow"
imgSize = -1
imgBit = -1
exit function
end if

dim flag
flag = 0 '0 is not jpg/gif/png image; 1 is jpg/gif/png
'*********************************Check.jpg Start*****************************************************
dim i_Depth
if flag = 0 then
dim lngMarkerSize,lngSize,flgFound,strTarget,lngpos,exitLoop
dim strFileHead1 , strFileHead2 , strFileHead3 ,strHeader1,strHeader2 , strHeader3
strFileHead1 = LeftB(mValue,10)
strFileHead2 = LeftB(mValue , 4)
strFileHead3 = MidB(mValue , 9 , 8)
'jpg格式1
strHeader1 = chrb(255) & chrb(216) & chrb(255) & chrb(224) & chrb(0) & chrb(16) & chrb(74) & chrb(70) & chrb(73) & chrb(70)
'jpg格式2
strHeader2 = chrb(255) & chrb(216) & chrb(255) & chrb(225)
strHeader3 = chrb(105) & chrb(102) & chrb(0) & chrb(0) & chrb(73) & chrb(73) & chrb(42) & chrb(00)
if strcomp(strFileHead1,strHeader1,0) = 0 or ( strcomp(strFileHead2,strHeader2,0) = 0 and strcomp(strFileHead3,strHeader3,0) = 0) then
imgType = "jpg" '图片格式
imgSize = lenB(mValue) '图片大小
lngSize = imgSize
flgFound = 0
strTarget = chrb(255) & chrb(216) & chrb(255)
flgFound = instrb(mValue, strTarget)
lngPos = flgFound + 2
ExitLoop = false

do while ExitLoop = False and lngPos < lngSize
do while ascb(midb(mValue, lngPos, 1)) = 255 and lngPos < lngSize
lngPos = lngPos + 1
loop
if ascb(midb(mValue, lngPos, 1)) < 192 or ascb(midb(mValue, lngPos, 1)) > 195 then
lngMarkerSize = ConvertMotorola(midb(mValue, lngPos + 1, 2))
lngPos = lngPos + lngMarkerSize + 1
else
ExitLoop = True
end if
loop
if lngPos < lngSize - 10 then
imgHeight = ConvertMotorola(midb(mValue, lngPos + 4, 2)) '图片高度
imgWidth = ConvertMotorola(midb(mValue, lngPos + 6, 2)) '图片宽度
imgBit = ascb(midb(mValue, lngPos + 8, 1)) * 8 '图片色深
flag=2
end if
end if
end if
'*********************************Check.jpg End*****************************************************

'*********************************Check.gif Start*****************************************************
if flag = 0 then
dim tstr,tstr2,tempstr
tempstr = Leftb(mValue,6)
tstr = chrb(71) & chrb(73) & chrb(70) & chrb(56) & chrb(57) & chrb(97)
tstr2 = chrb(71) & chrb(73) & chrb(70) & chrb(56) & chrb(55) & chrb(97)
if (strcomp(tempstr,tstr,0) = 0 or strcomp(tempstr,tstr2) = 0) and (lenB(mValue) > 12) then
imgType = "gif" '图片格式
imgWidth = ConvertIntel(midb(mValue,7,2)) '图片宽度
imgHeight = ConvertIntel(midb(mValue,9,2)) '图片高度
imgBit = (ascb(midb(mValue, 11, 1)) and 112)/16 + 1 '图片色深
imgSize = lenB(mValue) '图片大小
flag = 2
end if
end if
'*********************************Check.gif End*****************************************************

'*********************************Check.bmp Start*****************************************************
if flag = 0 then
tempstr = Leftb(mValue,2)
tstr = chrb(Asc("B")) & chrb(Asc("M"))
if (strcomp(tempstr,tstr,0) = 0) and (lenb(mValue) >32 ) then
imgType = "bmp" '图片格式
imgWidth = ConvertIntel(midb(mValue,19,4)) '图片宽度
imgHeight = ConvertIntel(midb(mValue,23,4)) '图片高度
imgBit = ConvertIntel(midb(mValue,29,2)) '图片色深
imgSize = lenB(mValue) '图片大小
flag=2
end if
end if
'*********************************Check.bmp End*****************************************************

'*********************************Check.png Start*****************************************************
if flag = 0 then
dim i_colorType
tempstr=Leftb(mValue,8)
tstr=chrb(137) & chrb(80) & chrb(78) & chrb(71) & chrb(13) & chrb(10) & chrb(26) & chrb(10)
if (strcomp(tempstr,tstr,0) = 0) and (lenb(mValue) >27 )then
imgType = "png" '图片格式
imgWidth = ConvertMotorola(midb(mValue, 19, 2)) '图片宽度
imgHeight = ConvertMotorola(midb(mValue, 23, 2)) '图片高度
i_Depth = ascb(midb(mValue, 25, 1))
i_colorType = ascb(midb(mValue, 26, 1))
select case i_colorType
case 0
i_Depth = i_Depth
case 2
i_Depth = i_Depth * 3
case 3
i_Depth = i_Depth
case 4
i_Depth = i_Depth * 2
case 6
i_Depth = i_Depth * 4
case else
i_Depth = -1
end select
imgBit = i_Depth '图片色深
imgSize = lenB(mValue) '图片大小
flag = 2
end if
end if

'*********************************Check.png End*****************************************************
if flag = 0 then
isImage = false
imgWidth = -1
imgHeight = -1
imgType = "unknow"
imgSize = -1
imgBit = -1
else
IsImage = true
end if
End Function
'*************************************************接口函数结束***********************************************
End Class

%>

LG我建议你可以去下一个上传的
套上去.