function.asp

嘉缘人才6.0精简 ,很好用的人才系统

' TextColor文字颜色,TextFamily文字字体，BoldTF是否粗体（1为加粗），TextSize文字大小，StrTitle文字内容
' NumTopMargin文字垂直距离画布的顶边距(横向默认是居中的)，StrSavePath图片保存路径（需要绝对路径）
' 测试代码如下：
'	AspJpegCreateTextPic 400,60,&Hcccccc,&H0000ff,&H000000,"宋体",1,40,"文字转换图片AspJpeg",8,server.mappath("frontpage.jpg")
'	response.write "<img src='frontpage.jpg'><br>"
'======================================================================
Function AspJpegCreateTextPic(NumCanvasWidth,NumCanvasHeight,bgColor,borderColor,TextColor,TextFamily,BoldTF,TextSize,StrTitle,NumTopMargin,StrSavePath)
	AspJpegCreateTextPic = true
	If GetIsOpenWater=True Then Exit Function
	If Not IsObjInstalled("Persits.Jpeg") Then
		AspJpegCreateTextPic = false
	else
		If IsExpired("Persits.Jpeg")=true Then
			AspJpegCreateTextPic = false
		else
			Dim Title,objJpeg,TitleWidth
			Title = StrTitle
			Set objJpeg = Server.CreateObject("Persits.Jpeg")
			objJpeg.New NumCanvasWidth, NumCanvasHeight, bgColor
			If borderColor<>"" And borderColor<>0 Then
				objJpeg.Canvas.Pen.Color = borderColor
				objJpeg.Canvas.Brush.Solid = False
				objJpeg.Canvas.DrawBar 1, 1, objJpeg.Width, objJpeg.Height
			End If
			objJpeg.Canvas.Font.Color = "&H"&TextColor'&HFF0000
			objJpeg.Canvas.Font.Family = TextFamily
			If BoldTF=1 Then objJpeg.Canvas.Font.Bold = True
			objJpeg.Canvas.Font.Size = TextSize
			objJpeg.Canvas.Font.Quality = 4
		
			TitleWidth = objJpeg.Canvas.GetTextExtent( Title )
			objJpeg.Canvas.Print (objJpeg.Width-TitleWidth)/2, NumTopMargin, Title
			objJpeg.Save StrSavePath
			Set objJpeg = Nothing
		end if
	end if
End Function

'======================================================================
' 用WsImage组件建立带有新闻标题的图片
' 参数说明：
' NumCanvasWidth画布宽度，NumCanvasHeight画布高度，，TextColor文字颜色,TextFamily文字字体，TextSize文字大小
' NumRotation旋转角度（文字保持水平请填0），StrTitle文字内容
' NumLeft，文字水平与画布的左边距，NumTop文字垂直距离画布的顶边距，StrSavePath图片保存路径（需要绝对路径）
' 返回值：
' 如果发生错误，返回错误代码
' 测试代码如下：
'	x = WsImgWatermarkText(440,300,&H0000FF&,"宋体",20,0,110,300,"测试水印WsImage",server.MapPath("apple111.jpg"))
'	response.write x&server.mappath("../admin/Images/wsimg.jpg")&"<br><img src='../admin/Images/wsimg.jpg'><img src='apple111.jpg'>"
'======================================================================

Function WsImgWatermarkTextToPic(NumCanvasWidth,NumCanvasHeight,TextColor,TextFamily,TextSize,NumRotation,NumLeft,NumTop,StrTitle,StrSavePath)
	WsImgWatermarkTextToPic = true
	If GetIsOpenWater=True Then Exit Function
	On Error Resume Next
	Dim StrPicPath
	If Not IsObjInstalled("wsImage.Resize") then
		WsImgWatermarkTextToPic = false
	else
		If IsExpired("wsImage.Resize")=true  then
			WsImgWatermarkTextToPic = false
		else
			StrPicPath = server.mappath("../Images/wsimg.jpg")
			WsImgIndentPicSize1 StrPicPath,NumCanvasWidth,NumCanvasHeight
			Dim objWsImg,strError
			set objWsImg=server.CreateObject("wsImage.Resize")
			objWsImg.LoadSoucePic StrPicPath
			objWsImg.Quality=75
			objWsImg.TxtMarkFont = TextFamily
			objWsImg.TxtMarkBond = false
			objWsImg.MarkRotate = NumRotation
			objWsImg.TxtMarkHeight = TextSize
			objWsImg.AddTxtMark CStr(StrSavePath), StrTitle, TextColor, NumTop, NumLeft
			strError=objWsImg.errorinfo
			If strError<>"" Then WsImgIndentPicScale = strError
			objWsImg.free:Set objWsImg=Nothing
			IF Err Then
				WsImgWatermarkTextToPic=False
			End If
		end if
	end if
End Function
Function WsImgIndentPicSize1(StrPicPath,NumWidth,NumHeight)
	On Error Resume Next
	Dim objWsImg,strError,NumType
	NumType = 0
	If NumHeight<=0 Then NumHeight=0:NumType=1
	If NumWidth<=0 Then NumWidth=0:NumType=2
	set objWsImg=server.CreateObject("wsImage.Resize")
	objWsImg.LoadSoucePic CStr(StrPicPath)
	objWsImg.Quality=75
	objWsImg.OutputSpic CStr(StrPicPath),NumWidth,NumHeight,NumType
	strError=objWsImg.errorinfo
	If strError<>"" Then WsImgIndentPicSize1 = strError
	objWsImg.free:Set objWsImg=Nothing
End Function


'======================================================================
' 用SA-ImgWriter组件建立带有新闻标题的图片
' 参数说明
' NumCanvasWidth画布宽度，NumCanvasHeight画布高度，bgColor背景颜色
' TextColor文字颜色,TextFamily文字字体，TextSize文字大小，StrTitle文字内容
' NumleftMargin文字水平与画布的左边距，NumTopMargin文字垂直距离画布的顶边距，StrSavePath图片保存路径（需要绝对路径）
' 测试代码如下：
'	ImageGenCreateTextPic 420,60,rgb(255,255,255),rgb(0,0,0),"宋体",40,"文字转换图片ImageGen",8,8,server.mappath("frontpage.jpg")
'	response.write "<img src='frontpage.jpg'><br>"
'======================================================================
Function ImageGenCreateTextPic(NumCanvasWidth,NumCanvasHeight,bgColor,TextColor,TextFamily,TextSize,StrTitle,NumleftMargin,NumTopMargin,StrSavePath)
	ImageGenCreateTextPic = true
	If GetIsOpenWater=True Then Exit Function
	If Not IsObjInstalled("softartisans.ImageGen") Then
		ImageGenCreateTextPic=false
	else
		If IsExpired("softartisans.ImageGen")=true Then
			ImageGenCreateTextPic=false
		else
			Dim objImageGen,objFont
			Set objImageGen = Server.CreateObject("softartisans.ImageGen")
			'Response.Write "<br>"&NumCanvasWidth &"<br>"& NumCanvasHeight&"<br>"& bgColor
			'Response.end
			objImageGen.CreateImage NumCanvasWidth, NumCanvasHeight, bgColor	'rgb(255,255,255)注意格式
			Set objFont = objImagegen.Font
			objFont.name = TextFamily
			objFont.Color = TextColor	'rgb(0,0,0)	'注意格式
			objFont.height = TextSize
			objImageGen.DrawTextOnImage NumleftMargin, NumTopMargin, objImageGen.Width-NumleftMargin, objImageGen.Height-NumTopMargin, StrTitle
			'Response.Write "<br>" &StrSavePath
			objImageGen.SaveImage 0, 3, StrSavePath
			Set objFont = Nothing
			Set objImageGen = Nothing
		end if
	end if
End Function

Function GetStrLengthE(Str)
'按英文计算字符串的长度，计算头条新闻图片大小用
	Dim i,StrLenth
	For i = 1 to len(Str)
		If Abs(Asc(Mid(Str,i,1)))>255 Then
			StrLenth=StrLenth+1
		Else
			StrLenth=StrLenth+0.5
		End If
	Next
	GetStrLengthE=StrLenth
End Function


'判断组件是否可用
Function IsObjInstalled(strClassString)
	IsObjInstalled = False
	Dim xTestObj
	On Error Resume Next
	Set xTestObj = Server.CreateObject(strClassString)
	If Err Then
		IsObjInstalled = False
		Err.Clear
	Else
		IsObjInstalled = True
	End If
	Set xTestObj = Nothing
End Function
'组件是否过期
Function IsExpired(strClassString)
	IsExpired = True
	Dim xTestObj
	On Error Resume Next
	Err.Clear
	Set xTestObj = Server.CreateObject(strClassString)
	Select Case LCase(strClassString)
		Case "Persits.Jpeg"
			If DateDiff("s",xTestObj.Expires,now)<0 Then
				IsExpired = False
			End if
		Case "wsImage.Resize"
			If instr(xTestObj.errorinfo,"已经过期") = 0 Then
				IsExpired = False
			End if
		Case "softartisans.ImageGen"
			xTestObj.CreateImage 500, 500, rgb(255,255,255)
			If Err Then
				Err.Clear
				IsExpired = False
			End if
		Case Else
			IsExpired = False
	End Select

	Set xTestObj = Nothing
End Function

'去掉首尾,号
Function DelHeadAndEndDot(Str)
	Dim StrLen
	StrLen=Len(Str)
	if StrLen>0 then
		if instr(str,",")=1 then
			Str=right(str,StrLen-1)
		end if
		StrLen=Len(Str)
		if instrrev(str,",")=StrLen then
			Str=left(str,StrLen-1)
		end if
	end if
	DelHeadAndEndDot=Str
End Function

'验证字符串是否合法,匹配到即为合法
Function IsValidStr(Str,FilterStr)
	IsValidStr=False
	If Str<>"" Then
		Dim regEx
		Set regEx = New RegExp
		regEx.IgnoreCase = True
		regEx.Pattern = FilterStr
		If regEx.Test(LCase(Str)) Then
			IsValidStr=True
		End If
		Set regEx = Nothing
	End If
End Function
'检查是否外部输入
Function IsSelfRefer()
	Dim sHttp_Referer, sServer_Name
	sHttp_Referer = CStr(Request.ServerVariables("HTTP_REFERER"))
	sServer_Name = CStr(Request.ServerVariables("SERVER_NAME"))
	If Mid(sHttp_Referer, 8, Len(sServer_Name)) = sServer_Name Then
		IsSelfRefer = True
	Else
		IsSelfRefer = False
	End If
End Function

'得到多少位数的随机函数
Function GetRamCode(f_number)
	Randomize
	Dim f_Randchar,f_Randchararr,f_RandLen,f_Randomizecode,f_iR
	f_Randchar="0,1,2,3,4,5,6,7,8,9,A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z"
	f_Randchararr=split(f_Randchar,",")
	f_RandLen=f_number '定义密码的长度或者是位数
	for f_iR=1 to f_RandLen
		f_Randomizecode=f_Randomizecode&f_Randchararr(Int((21*Rnd)))
	next
	GetRamCode = f_Randomizecode
End Function

'检查英文名称是否合法
Function chkinputchar(f_char)
	Dim f_name, i, c
	f_name = f_char
	chkinputchar = True
	If Len(f_name) <= 0 Then
		chkinputchar = False
		Exit Function
	End If
	For i = 1 To Len(f_name)
	   c = Mid(f_name, i, 1)
		If InStr("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ@,.0123456789|-_", c) <= 0  Then
		   chkinputchar = False
		Exit Function
	   End If
   Next
End Function

''替换成自己想显示的信息
''格式:Replacestr(Hs_Rs("FloorType"),"1:多层,2:单层")
''格式:Replacestr(Rs("Audited"),"1:已通过审核,0:<span class=""tx"">未通过审核</span>")
Function Replacestr(dbvalue,strlist)
	Dim f_oldstr,f_tmpstr,f_tmparr,f_tmparr1
	f_oldstr = strlist
	if isnull(dbvalue) then dbvalue=""
	f_tmparr = split(f_oldstr,",")
	for each f_tmpstr in f_tmparr
		f_tmparr1 = split(f_tmpstr,":")
		if ubound(f_tmparr1) = 1 then
			if trim(dbvalue) = trim(f_tmparr1(0)) then
				f_oldstr = trim(f_tmparr1(1)) : exit for
			elseif trim(f_tmparr1(0)) = "else" then
				f_oldstr = trim(f_tmparr1(1))
			else
				f_oldstr = dbvalue
			end if
		else
		end if
	next
	Replacestr = f_oldstr
End Function

''显示下拉
''格式PrintOption(rs("language"),":<font color=#999999>请选择</font>,英语:英语,日语:日语,法语:法语")
Function PrintOption(Equvalue,valuelist)
	Dim f_oldstr,f_tmpstr,f_tmparr,f_tmparr1,isselected
	isselected=false:f_oldstr=""
	if isnull(Equvalue) then Equvalue=""
	f_tmparr = split(valuelist,",")
	for each f_tmpstr in f_tmparr
		f_tmparr1 = split(f_tmpstr,":")
		if ubound(f_tmparr1) = 1 then
			if trim(Equvalue) = trim(f_tmparr1(0)) and isselected=false then
				f_oldstr = f_oldstr & "<option value="""&f_tmparr1(0)&""" selected>"&f_tmparr1(1)&"</option>"
				isselected=true
			elseif trim(f_tmparr1(0))+trim(f_tmparr1(1))<>"" then
				f_oldstr = f_oldstr & "<option value="""&f_tmparr1(0)&""">"&f_tmparr1(1)&"</option>"
			end if
		else
		end if
	next
	PrintOption = f_oldstr
End Function

''文本框查询处理，方式可 “A B*”“A *B*”“A B”
''查询的时候 FildValue为空，显示的时候的 FildValue 不为空，则会将关键字颜色替换
Function Search_TextArr(StrKey,FildName,FildValue)
	Dim StrTmp,ArrTmp,New_StrTmp,Bol_Xin
	StrTmp = "" : New_StrTmp = FildValue
	Bol_Xin = False
	ArrTmp = split(StrKey,chr(32))
	for each StrTmp in ArrTmp
	  if Trim(StrTmp)<>"" then
		if New_StrTmp <> "" then
			StrTmp = replace(StrTmp,"*","")
			New_StrTmp = replace(New_StrTmp,StrTmp,"<font color=""red"">"&StrTmp&"</font>")
		else
			if left(StrTmp,1) = "*" then StrTmp = "%"&mid(StrTmp,2) : Bol_Xin = True
			if right(StrTmp,1) = "*" then StrTmp = mid(StrTmp,1,len(StrTmp) - 1)&"%" : Bol_Xin = True
			if not Bol_Xin then StrTmp = "%"&StrTmp&"%"