index.asp

网人分类信息5.0商业版。非常优秀的分类信息系统。比较少见。

					If Err = 0 Then
						IsExpired = False
					End If
			End Select
		End If
		Set xTestObj = Nothing
		Err = 0
End Function    
'为图片添加水印
Function AddWaterMark(FileName)
		    Dim SK
			Dim objFileSystem, strFileExtName, objImage
			If InStr(FileName, ":") = 0 Then                                            
				FileName = Server.MapPath(FileName)
			End If
			If FileName <> "" And Not IsNull(FileName) Then                           
				strFileExtName = ""
				If InStr(FileName, ".") <> 0 Then
					strFileExtName = LCase(Trim(Mid(FileName, InStrRev(FileName, ".") + 1)))
				End If
				If strFileExtName <> "jpg" And strFileExtName <> "gif" And strFileExtName <> "bmp" And strFileExtName <> "png" Then 
					Exit Function
				End If
				Set objFileSystem = Server.CreateObject(WR_Setting(14))
				If objFileSystem.FileExists(FileName) Then             
					If WR_UpLoad(25) <> "0" Then                   
						Select Case WR_UpLoad(25)
							Case "1"                                                           
								If IsObjInstalled("Persits.Jpeg") Then                    
									If IsExpired("Persits.Jpeg") Then
										Response.Write ("对不起，Persits.Jpeg组件已过期<br><a href=# Onclick=""javascript:history.back()"">返回</a>")
										Response.End
									End If
									If WR_UpLoad(27) = "1" Then             
										AddWordMark 1, WR_UpLoad(28), WR_UpLoad(30), WR_UpLoad(31), WR_UpLoad(32), WR_UpLoad(29), WR_UpLoad(26), FileName
									Else                                               
										AddPhotoMark 1, WR_UpLoad(36), WR_UpLoad(37), WR_UpLoad(33), WR_UpLoad(34), WR_UpLoad(35), WR_UpLoad(26), FileName
									End If
								End If
						End Select
					End If
				End If
				Set objFileSystem = Nothing
			End If
End Function
'为图片添加文字水印函数
Function AddWordMark(MarkComponentID, MarkText, MarkFontColor, MarkFontName, MarkFontBond, MarkFontSize, MarkPosition, FileName)
			Dim objImage, x, y, Text, TextWidth, FontColor, FontName, FondBond, FontSize, OriginalWidth, OriginalHeight
			If InStr(FileName, ":") = 0 Then                                                            
				FileName = Server.MapPath(FileName)
			End If
				
			Text = Trim(MarkText)
			If Text = "" Then
				Exit Function
			End If
			FontColor = Replace(MarkFontColor, "#", "&H")
			FontName = MarkFontName
			If MarkFontBond = "1" Then
				FondBond = True
			Else
				FondBond = False
			End If
			   
			FontSize = CInt(MarkFontSize)
		
			Select Case MarkComponentID
				Case 1
					If Not IsObjInstalled("Persits.Jpeg") Then
						Exit Function
					End If
					Set objImage = Server.CreateObject("Persits.Jpeg")
					objImage.Open FileName
					objImage.Canvas.Font.Color = FontColor
					objImage.Canvas.Font.Family = FontName
					objImage.Canvas.Font.Bold = FondBond
					objImage.Canvas.Font.size = FontSize
					
					If objImage.OriginalWidth < TextWidth Or objImage.OriginalHeight < FontSize Then    
						Exit Function
					End If
					GetPostion CInt(MarkPosition), x, y, objImage.OriginalWidth, objImage.OriginalHeight, WR_UpLoad(36), WR_UpLoad(37)
					
					With objImage.Canvas
					  .Print x, y, Text
					End With
					objImage.Save FileName
			End Select
			Set objImage = Nothing
End Function

Function AddPhotoMark(MarkComponentID, MarkWidth, MarkHeight, MarkPicture, MarkOpacity, MarkTranspColor, MarkPosition, FileName)
			Dim objImage, objMark, x, y, OriginalWidth, OriginalHeight, Position
			If InStr(FileName, ":") = 0 Then                                                            
				FileName = Server.MapPath(FileName)
			End If
			If IsNull(MarkWidth) Or MarkWidth = "" Then
				MarkWidth = 0
			Else
				MarkWidth = CInt(MarkWidth)
			End If
			If IsNull(MarkHeight) Or MarkHeight = "" Then
				MarkHeight = 0
			Else
				MarkHeight = CInt(MarkHeight)
			End If
			If Trim(MarkPicture) = "" Or IsNull(MarkPicture) Then
				Exit Function
			End If
			If IsNull(MarkOpacity) Or MarkOpacity = "" Then
				MarkOpacity = 1
			Else
				MarkOpacity = CSng(MarkOpacity)
			End If
			If MarkTranspColor <> "" Then                                                              
				MarkTranspColor = Replace(MarkTranspColor, "#", "&H")
			Else
			End If
			Select Case MarkComponentID
				Case 1
					If Not IsObjInstalled("Persits.Jpeg") Then
						Exit Function
					End If
					Set objImage = Server.CreateObject("Persits.Jpeg")
					Set objMark = Server.CreateObject("Persits.Jpeg")
					objImage.Open FileName
					If objImage.OriginalWidth < MarkWidth Or objImage.OriginalHeight < MarkHeight Then 
						Exit Function
					End If
					objMark.Open Server.MapPath(MarkPicture)
					GetPostion CInt(MarkPosition), x, y, objImage.OriginalWidth, objImage.OriginalHeight, MarkWidth, MarkHeight 
					If MarkTranspColor <> "" Then
						objImage.DrawImage x, y, objMark, MarkOpacity, MarkTranspColor
					Else
						objImage.DrawImage x, y, objMark, MarkOpacity
					End If
					objImage.Save FileName
			End Select
			Set objImage = Nothing
			Set objMark = Nothing
End Function
Function GetPostion(MarkPosition, x, y, ImageWidth, ImageHeight, MarkWidth, MarkHeight)
			Select Case CInt(MarkPosition)
				Case 1
					x = MarkWidth
					y = MarkHeight
				Case 2
					x = MarkWidth
					y = Int(ImageHeight - MarkHeight)
				Case 3
					x = Int((ImageWidth - MarkWidth) / 2)
					y = Int((ImageHeight - MarkHeight) / 2)
				Case 4
					x = Int(ImageWidth - MarkWidth)
					y = MarkHeight
				Case 5
					x = Int(ImageWidth - MarkWidth)
					y = Int(ImageHeight - MarkHeight)
			End Select
End Function
'由原图片根据数据里保存的设置生成缩略图
'原图路径 , 新图路径
Function CreateThumbs(FileName,ThumbFileName)
			CreateThumbs = False
			If WR_UpLoad(20) <> "0" And (Not IsNull(WR_UpLoad(20))) Then
				If WR_UpLoad(21) = "0" Then
					CreateThumbs = CreateThumb(FileName, CInt(WR_UpLoad(23)), CInt(WR_UpLoad(24)), 0, ThumbFileName)
				Else
					CreateThumbs = CreateThumb(FileName, 0, 0, CSng(WR_UpLoad(22)), ThumbFileName)
				End If
			End If
End Function
'由原图片生成指定宽度和高度的缩略图
Function CreateThumb(FileName, Width, Height, Rate, ThumbFileName)
			Dim strSql, RsSetting, objImage, iWidth, iHeight, strFileExtName
			CreateThumb = False
			If IsNull(FileName) Then                                    '如果原图片未指定直接退出
				Exit Function
			ElseIf FileName = "" Then
				Exit Function
			End If
			If InStr(FileName, ".") <> 0 Then
				strFileExtName = LCase(Trim(Mid(FileName, InStrRev(FileName, ".") + 1)))
			End If
			If strFileExtName <> "jpg" And strFileExtName <> "gif" And strFileExtName <> "bmp" And strFileExtName <> "png" Then '文件不是可用图片则退出
				Exit Function
			End If
			If IsNull(ThumbFileName) Then                          
				Exit Function
			ElseIf ThumbFileName = "" Then
				Exit Function
			End If
			If IsNull(Width) Then                                
				Width = 0
			ElseIf Width = "" Then
				Width = 0
			End If
			If IsNull(Rate) Then                                   
				Rate = 0
			ElseIf Rate = "" Then
				Rate = 0
			End If
			If IsNull(Height) Then                               
				Height = 0
			ElseIf Height = "" Then
				Height = 0
			End If
			If InStr(FileName, ":") = 0 Then      
				FileName = Server.MapPath(FileName)
			End If
			If InStr(ThumbFileName, ":") = 0 Then
				ThumbFileName = Server.MapPath(ThumbFileName)
			End If
			Width = CInt(Width)
			Height = CInt(Height)
			Rate = CSng(Rate)
			
			Select Case CInt(WR_UpLoad(20))
				Case 0                                               
					Exit Function
				Case 1
					If Not IsObjInstalled("Persits.Jpeg") Then
						Exit Function
					End If
					If IsExpired("Persits.Jpeg") Then
						Response.Write ("对不起，Persits.Jpeg 组件已过期<br><a href=# Onclick=""javascript:history.back()"">返回</a>")
						Response.End
					End If
					Set objImage = Server.CreateObject("Persits.Jpeg")
					objImage.Open FileName
					If Rate = 0 And (Width <> 0 Or Height <> 0) Then
						If Width < objImage.OriginalWidth And Height < objImage.OriginalHeight Then
							If Width = 0 And Height <> 0 Then
								objImage.Width = objImage.OriginalWidth / objImage.OriginalHeight * Height
								objImage.Height = Height
							ElseIf Width <> 0 And Height = 0 Then
								objImage.Width = Width
								objImage.Height = objImage.OriginalHeight / objImage.OriginalWidth * Width
							ElseIf Width <> 0 And Height <> 0 Then
								objImage.Width = Width
								objImage.Height = Height
							End If
						End If
					ElseIf Rate <> 0 Then
						objImage.Width = objImage.OriginalWidth * Rate
						objImage.Height = objImage.OriginalHeight * Rate
					End If
					objImage.Save ThumbFileName
			End Select
			CreateThumb = True
End Function

'==================================================
'过程名：SaveRemoteFile
'作  用：保存远程的文件到本地
'参  数：LocalFileName ------ 本地文件名
'参  数：RemoteFileUrl ------ 远程文件URL
'==================================================
Function SaveRemoteFile(LocalFileName,RemoteFileUrl,FileSize)
    SaveRemoteFile=0
	dim Ads,Retrieval,GetRemoteData,FileExt
	RemoteFileUrl = Replace(RemoteFileUrl," ","")
	On Error Resume Next
	Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
	With Retrieval
		.Open "Get", RemoteFileUrl, False, "", ""
		.Send
        If .Readystate<>4 or .Status > 300 then
            Response.write "操作错误<br><a href=# Onclick=""javascript:history.back()"">返回</a>":Response.end
        End If
		GetRemoteData = .ResponseBody
	End With
	Set Retrieval = Nothing
	If Round(LenB(GetRemoteData)/1024) > FileSize Then Response.write "下载文档大小超过限制<br><a href=# Onclick=""javascript:history.back()"">返回</a>":Response.end
	u_uFilter = "gif|jpg|bmp|png"
    u_uFilter = Split(Lcase(u_uFilter),"|")
	FileExt = Lcase(Split(RemoteFileUrl,".")(UBound(Split(RemoteFileUrl,"."))))
	FileExt = Left(FileExt,3)
    RemoteErr = 0
	For uI=0 To UBound(u_uFilter)
      If u_uFilter(uI) <> "" Then
	    If u_uFilter(uI) = FileExt Then RemoteErr = 1
	  End If
    Next
    If RemoteErr = 0 Then Response.Write "服务器不接受该类文档<br><a href=# Onclick=""javascript:history.back()"">返回</a>":Response.end
	SaveRemoteFile = LenB(GetRemoteData)
    Set Ads = Server.CreateObject("Adodb.Stream")
	  With Ads
		.Type = 1
		.Open
		.Write GetRemoteData
		.SaveToFile server.MapPath(LocalFileName),2
		.Cancel()
		.Close()
	  End With
	  If Err.number<>0 then
	    Response.write "操作错误<br><a href=# Onclick=""javascript:history.back()"">返回</a>":Response.end
   	    Err.Clear
   	  End If
	Set Ads=nothing
End Function
%>
</body>
</html>