cls_image.asp

后台管理系统

<%
'==============================================================================
'软件名称：拓网文件上传提取系统
'当前版本：拓网文件上传提取系统1.0(TopWang Upload V1.0)
'Copyright (C) 2003-2006 TopWang.Com  All rights reserved.
'产品咨询QQ：36355735
'程序开发：拓网产品开发组
'Email:[e-mail]
'官方网站：www.TopWang.com
'论坛支持：拓网在线论坛(http://bbs.TopWang.com)
'免费版本请在程序首页保留版权信息，并做上本站LOGO友情连接
'==============================================================================

'==============================================================================
'文件名:Cls_Image.asp
'摘  要:图片信息类
'作  者:怀念曾经的雨37
'更  新:2006-2-10
'==============================================================================
Class NetBuilderImage

	Private my_Width
	Private my_Height
	Private my_FileType
	Private my_Error
	Private my_Image
	Private my_Url
	Private my_FilePath


	Private Sub Class_Initialize()
		my_Width = 0
		my_Height = 0
	End Sub

	Public Property Get Width()
		Width = my_Width
	End Property

	Public Property Get Height()
		Height = my_Height
	End Property

	Public Property Get FileType()
		FileType = my_FileType
	End Property

	Public Property Get Error()
		Error = my_Error
	End Property
	
	Public Property Get Image()
		Image = my_Image
	End Property

	Public Property Let Url(ByVal Value)
		my_Url = Value
	End Property

	Public Property Let FilePath(ByVal Value)
		my_FilePath = Value
	End Property

	Public Sub Load()
		If (Not IsEmpty(my_URL)) And my_URL <> "" Then
			GetWebData(my_URL)
		Else
			GetLocalData(my_FilePath)
		End If
		If my_Error = 0 Then getImageWH(my_Image)
	End Sub

	Public Sub LoadFromFile(ByVal File)
		my_Url = Empty
		my_FilePath = File
		Load()
	End Sub

	Public Sub LoadFromUrl(ByVal sUrl)
		my_FilePath = Empty
		my_Url = sUrl
		Load()
	End Sub

	Public Sub LoadFromImage(ByVal sStream,ByVal X,ByVal Y,ByVal TransparentColor)
		my_Image = sStream
		getImageWH(my_Image)
	End Sub

	Public Sub Refresh()
		my_Width = 0
		my_Height = 0
		my_FileType = Empty
		my_Error = Empty
		my_Image = Empty
		my_Url = Empty
		my_FilePath = Empty		
	End Sub

	Private Function Bytes2bStr(ByVal Value)
		If LenB(Value) =0 Then
			Bytes2bStr = ""
			Exit Function
		End If

		Dim BytesStream,StringReturn

		Set BytesStream = Server.CreateObject(ServerObject_003)
		BytesStream.Type = 2 
		BytesStream.Open
		BytesStream.WriteText Value
		BytesStream.Position = 0
		BytesStream.Charset = "gb2312"
		BytesStream.Position = 2
		StringReturn = BytesStream.ReadText
		BytesStream.Close

		Set BytesStream = Nothing
		Bytes2bStr = StringReturn
	End Function

	Private Function BinVal(ByVal binValue)
		Dim i
		Dim ret
		ret = 0
		For i = LenB(binValue) To 1 Step -1
			ret = ret * 256 + AscB(MidB(binValue,i,1))
		Next
		BinVal = ret
	End Function

	Private Function BinVal2(ByVal binValue)
		Dim i
		Dim ret
		ret = 0
		For i = 1 To LenB(binValue)
			ret = ret * 256 + AscB(MidB(binValue,i,1))
		Next
		BinVal2 = ret
	End Function

	Private Sub getImageWH(ByVal fdata) 

		Dim ret(2),bFlag,fsize,ADOS

		fsize = CLng(LenB(fdata))

		If fsize = 0 Then Exit Sub

		Set ADOS = Server.CreateObject(ServerObject_003)
		ADOS.Type = 1 
		ADOS.Mode = 3 
		ADOS.Open

		ADOS.Write fdata
		ADOS.Position = 0
		bFlag = ADOS.read(3)

		If IsNull(bFlag) Then 
			my_FileType = "unknow"
			my_Width = 0
			my_Height = 0
			Exit Sub
		End If

		'取文件类型和长宽
		Select Case Hex(binVal(bFlag))
		Case "4E5089":
			ADOS.read(15)
			my_FileType = "png"
			my_Width = BinVal2(ADOS.read(2))
			ADOS.read(2)
			my_Height = BinVal2(ADOS.read(2))
		Case "464947":
			ADOS.read(3)
			my_FileType = "gif"
			my_Width = BinVal(ADOS.read(2))
			my_Height = BinVal(ADOS.read(2))
		Case "FFD8FF":
			Dim p1
			Do 
			Do: p1 = binVal(ADOS.Read(1)): Loop While p1 = 255 And Not ADOS.EOS
			If p1 > 191 And p1 < 196 Then Exit Do Else ADOS.Read(binval2(ADOS.read(2))-2)
			Do:p1 = binVal(ADOS.Read(1)):Loop While p1 < 255 And Not ADOS.EOS
			Loop While True
			ADOS.Read(3)
			my_FileType = "jpg"
			my_Width = binval2(ADOS.Read(2))
			my_Height = binval2(ADOS.Read(2))
		Case Else:
			If Left(Bytes2bStr(bFlag),2) = "BM" Then
				ADOS.Read(15)
				my_FileType = "bmp"
				my_Width = binval(ADOS.Read(4))
				my_Height = binval(ADOS.Read(4))
			Else
				my_FileType = ""
			End If
		ADOS.Close
		Set ADOS = Nothing
		End Select

		Select Case my_FileType
		Case "png","jpg","bmp","gif"
		Case Else
			my_Width = 0
			my_Height = 0
			my_FileType = "unknow"
		End Select

	End Sub

	Private Sub GetLocalData(ByVal Path)
		On Error Resume Next
		Dim temp
		If Path = "" Then Exit Sub
		Set temp = Server.CreateObject(ServerObject_003)
		temp.Type = 1
		temp.Open
		temp.LoadFromFile(Path)
		my_Image = temp.Read(temp.Size)
		temp.Close
		Set temp = Nothing
		my_Error = Err.Number
		Err.clear
	End Sub

	Private Sub GetWebData(ByVal StrUrl)
		On Error Resume Next
		If Strurl = "" Then Exit Sub

		Dim Tempstr
		Tempstr = Split(Strurl,"/")
		If Tempstr(Ubound(Tempstr)) = "" Or Instr(Strurl,"/") = 0 Then Exit Sub

		Dim Retrieval
		Set Retrieval = Server.Createobject("Microsoft.XmlHTTP")
		With Retrieval
			.Open "Get", Strurl, False, "", ""
			.Send
			MY_Image =.Responsebody
		End With
		Set Retrieval = Nothing
		my_Error = Err.Number
		Err.clear

	End Sub 
	
End Class
%>