<%
Function clscache()
    Dim cacheobj
    application.Lock
    For Each cacheobj In application.contents
        If CStr(Left(cacheobj, Len(Cacheflag))) = CStr(Cacheflag) Then application.contents.Remove (cacheobj)
    Next
    application.unlock
End Function

'将textarea标记转为代字符
Function HTMLa(reString)
 Dim Str:Str=reString
 If Not IsNull(Str) Then
  Str = Replace(Str, "</textarea>", "</bokehtml>")
  HTMLa = Str
 End If
End Function
'还原textarea标记
Function HTMLb(reString)
 Dim Str:Str=reString
 If Not IsNull(Str) Then
  Str = Replace(Str, "</bokehtml>", "</textarea>")
  HTMLb = Str
 End If
End Function

'未用
Function setcache(cachename, cachevalue)
    Dim cachedata
    cachename = LCase(filterstr(cachename))
    cachedata = application(Cacheflag & cachename)
    If IsArray(cachedata) Then
        cachedata(0) = Cachevalue
        cachedata(1) = Now()
    Else
        ReDim cachedata(2)
        cachedata(0) = Cachevalue
        cachedata(1) = Now()
    End If
    application.Lock
    application(Cacheflag & cachename) = cachedata
    application.unlock
End Function

Function getcache(cachename)
    Dim cachedata
    cachename = LCase(filterstr(cachename))
    cachedata = application(Cacheflag & cachename)
    If IsArray(cachedata) Then getcache = cachedata(0) Else getcache = ""
End Function

Function chkcache(cachename)
    Dim cachedata
    chkcache = False
    cachename = LCase(filterstr(cachename))
    cachedata = application(Cacheflag & cachename)
    If Not IsArray(cachedata) Then Exit Function
    If Not IsDate(cachedata(1)) Then Exit Function
    If DateDiff("s", CDate(cachedata(1)), Now()) < 60 * Cachetime Then chkcache = True
End Function

Function filterstr(Str)
    filterstr = LCase(Str)
    filterstr = Replace(filterstr, " ", "")
    filterstr = Replace(filterstr, "'", "")
    filterstr = Replace(filterstr, """", "")
    filterstr = Replace(filterstr, "=", "")
    filterstr = Replace(filterstr, "*", "")
End Function

'替换特定字符,安全过虑
Function ReplaceBadChar(strChar)
    If strChar = "" Or IsNull(strChar) Then
        ReplaceBadChar = ""
        Exit Function
    End If
    Dim strBadChar, arrBadChar, tempChar, i
    strBadChar = "+,',%,^,&,?,(,),<,>,[,],{,},/,\,;,:," & Chr(34) & "," & Chr(0) & ",--"
    arrBadChar = Split(strBadChar, ",")
    tempChar = strChar
    For i = 0 To UBound(arrBadChar)
        tempChar = Replace(tempChar, arrBadChar(i), "")
    Next
    tempChar = Replace(tempChar, "@@", "@")
    ReplaceBadChar = tempChar
End Function

'格式化字串
Function ReplaceConstChar(strChar)
    If strChar = "" Or IsNull(strChar) Then
        ReplaceConstChar = ""
        Exit Function
    End If
    Dim strBadChar, arrBadChar, tempChar, i
    strBadChar = "+,',%,^,&,?,(,),<,>,[,],{,},;,:," & Chr(34) & "," & Chr(0) & ",--"
    arrBadChar = Split(strBadChar, ",")
    tempChar = strChar
    For i = 0 To UBound(arrBadChar)
        tempChar = Replace(tempChar, arrBadChar(i), "")
    Next
    tempChar = Replace(tempChar, "@@", "@")
    ReplaceConstChar = tempChar
End Function

'判断字符串长度
Function StrLen(Str)
    If Str = "" Or IsNull(Str) Then
        StrLen = 0
        Exit Function
    Else
        Dim regex
        Set regex = New regexp
        regEx.Pattern = "[^\x00-\xff]"
        regex.Global = True
        Str = regEx.Replace(Str, "^^")
        Set regex = Nothing
        StrLen = Len(Str)
    End If
End Function

'过滤
Function ReStrReplace(Str)
    If Str = "" Or IsNull(Str) Then
        ReStrReplace = ""
        Exit Function
    Else
        ReStrReplace = Replace(Str, "&nbsp;", " ")
        ReStrReplace = Replace(ReStrReplace, "<br />", Chr(13))
        ReStrReplace = Replace(ReStrReplace, "&lt;br&gt;", Chr(13))
        ReStrReplace = Replace(ReStrReplace, "&lt;", "<")
        ReStrReplace = Replace(ReStrReplace, "&gt;", ">")
    End If
End Function

'未用
Function HtmlStrReplace(Str)
    If Str = "" Or IsNull(Str) Then
        HtmlStrReplace = ""
        Exit Function
    Else
        HtmlStrReplace = Replace(Str, "&lt;br&gt;", "<br />")
    End If
End Function

'未用
Function GetUrl()
    GetUrl = "http://"&Request.ServerVariables("SERVER_NAME")&Request.ServerVariables("URL")
    If Request.ServerVariables("QUERY_STRING")<>"" Then GetURL = GetUrl&"?"& Request.ServerVariables("QUERY_STRING")
End Function

'未用
Function IsValidMemName(memname)
    Dim i, c
    IsValidMemName = True
    If Not (3<= Len(memname) And Len(memname)<= 16) Then
        IsValidMemName = False
        Exit Function
    End If
    For i = 1 To Len(memname)
        c = Mid(memname, i, 1)
        If InStr("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_-", c) <= 0 And Not IsNumeric(c) Then
            IsValidMemName = False
            Exit Function
        End If
    Next
End Function

Function CheckStr(Strer, Num)
    Dim Shield, w
    If Strer = "" Or IsNull(Strer) Then Exit Function
    Select Case Num
        Case 1
            If IsNumeric(Strer) = 0 Then
                Response.Write "操作错误"
                Response.End
            End If
            Strer = Int(Strer)
    End Select
    CheckStr = Strer
End Function

'替换
sub sunlynetpy()
	sunlynet=replace(sunlynet,":","-")
	sunlynet=replace(sunlynet,"：","-")
	sunlynet=replace(sunlynet,"“","")
	sunlynet=replace(sunlynet,"”","")
	sunlynet=replace(sunlynet,"？","-")
	sunlynet=replace(sunlynet," ","-")
end sub

' ====== 用到
Function StrReplace(Str)
    If Str = "" Or IsNull(Str) Then
        StrReplace = ""
        Exit Function
    Else
        StrReplace = Replace(Str, " ", "&nbsp;")
        StrReplace = Replace(StrReplace, Chr(13), "&lt;br&gt;")
        StrReplace = Replace(StrReplace, "<", "&lt;")
        StrReplace = Replace(StrReplace, ">", "&gt;")
    End If
End Function

'邮箱合法性检查
Function IsValidEmail(email)
    Dim names, Name, i, c
    IsValidEmail = True
    names = Split(email, "@")
    If UBound(names) <> 1 Then
        IsValidEmail = False
        Exit Function
    End If
    For Each Name in names
        If Len(Name) <= 0 Then
            IsValidEmail = False
            Exit Function
        End If
        For i = 1 To Len(Name)
            c = Mid(Name, i, 1)
            If InStr("abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ_-.", c) <= 0 And Not IsNumeric(c) Then
                IsValidEmail = False
                Exit Function
            End If
        Next
        If Left(Name, 1) = "." Or Right(Name, 1) = "." Then
            IsValidEmail = False
            Exit Function
        End If
    Next
    If InStr(names(1), ".") <= 0 Then
        IsValidEmail = False
        Exit Function
    End If
    i = Len(names(1)) - InStrRev(names(1), ".")
    If i <> 2 And i <> 3 Then
        IsValidEmail = False
        Exit Function
    End If
    If InStr(email, "..") > 0 Then
        IsValidEmail = False
    End If
End Function

'判断硬盘中是否存在文件
Function Checkfile(Filepath)
    Dim Fso, Path
    Set Fso = Server.CreateObject("Scripting.Filesystemobject")
    If InStr(Filepath, ":") <> 0 Then Path = Filepath Else Path = Server.Mappath(Filepath)
    If Fso.FileExists(Path) Then Checkfile = True Else Checkfile = False
    Set Fso = Nothing
End Function

'按长度截取字串
Function StrLeft(Str, StrLen)
    Dim L, T, I, C
    If Str = "" Then
        StrLeft = ""
        Exit Function
    End If
    Str = Replace(Replace(Replace(Replace(Str, "&nbsp;", " "), "&quot;", Chr(34)), "&gt;", ">"), "&lt;", "<")
    L = Len(Str)
    T = 0
    For i = 1 To L
        C = Abs(AscW(Mid(Str, i, 1)))
        If C>255 Then
            T = T + 2
        Else
            T = T + 1
        End If
        If T>= StrLen Then
            StrLeft = Left(Str, i) & "...."
            Exit For
        Else
            StrLeft = Str
        End If
    Next
    StrLeft = Replace(Replace(Replace(Replace(StrLeft, " ", "&nbsp;"), Chr(34), "&quot;"), ">", "&gt;"), "<", "&lt;")
End Function

Function RemoveHTML(strText)
	Dim RegEx
	Set RegEx = New RegExp
	RegEx.Pattern = "<[^>]*>"
	RegEx.Global = True
	RemoveHTML = RegEx.Replace(strText, "")
End Function

Function FormatDate(DateAndTime, Format)
	If Not IsDate(DateAndTime) Then Exit Function
	If IsNul(Format) Then
		FormatDate = DateAndTime
	Else
		If IsNumeric(Format) Then
			FormatDate = FormatDate2(DateAndTime, Format)
		Else
			FormatDate = FormatDate1(DateAndTime, Format)
		End If
	End If
End Function

'日期格式化
Function FormatDate1(DateAndTime, Format)
    On Error Resume Next
    Dim yy, y, m, d, h, mi, s, strDateTime
    FormatDate = DateAndTime
    If IsNumeric(Format) Then Exit Function
	Select Case Format
		Case "yy"
			strDateTime = CStr(Year(DateAndTime))
		Case "y"
			strDateTime = Mid(CStr(Year(DateAndTime)), 3)
		Case "mon"
			m = CStr(Month(DateAndTime))
			If Len(m) = 1 Then m = "0" & m
			strDateTime = m
		Case "mo"
			strDateTime = CStr(Month(DateAndTime))
		Case "dd"
			d = CStr(Day(DateAndTime))
			If Len(d) = 1 Then d = "0" & d
			strDateTime = d
		Case "d"
			strDateTime = CStr(Day(DateAndTime))
		Case "hh"
			h = CStr(Hour(DateAndTime))
			If Len(h) = 1 Then h = "0" & h
			strDateTime = h
		Case "h"
			strDateTime = CStr(Hour(DateAndTime))
		Case "min"
			min = CStr(Minute(DateAndTime))
			If Len(min) = 1 Then min = "0" & min
			strDateTime = min
		Case "mi"
			strDateTime = CStr(Minute(DateAndTime))
		Case "ss"
			s = CStr(Second(DateAndTime))
			If Len(s) = 1 Then s = "0" & s
			strDateTime = s
		Case "s"
			strDateTime = CStr(Second(DateAndTime))
		Case Else
			strDateTime = DateAndTime
	End Select
	FormatDate1 = strDateTime
End Function

'日期格式化
Function FormatDate2(DateAndTime, Format)
    On Error Resume Next
    Dim yy, y, m, d, h, mi, s, strDateTime
    FormatDate = DateAndTime
    If Not IsNumeric(Format) Then Exit Function
    yy = CStr(Year(DateAndTime))
    y = Mid(CStr(Year(DateAndTime)), 3)
    m = CStr(Month(DateAndTime))
    If Len(m) = 1 Then m = "0" & m
    d = CStr(Day(DateAndTime))
    If Len(d) = 1 Then d = "0" & d
    h = CStr(Hour(DateAndTime))
    If Len(h) = 1 Then h = "0" & h
    mi = CStr(Minute(DateAndTime))
    If Len(mi) = 1 Then mi = "0" & mi
    s = CStr(Second(DateAndTime))
    If Len(s) = 1 Then s = "0" & s
    Select Case Format
        Case "1"
            strDateTime = y & "-" & m & "-" & d & " " & h & ":" & mi & ":" & s
        Case "2"
            strDateTime = yy & m & d & h & mi & s
        Case "3"
            strDateTime = yy & m & d & h & mi
        Case "4"
            strDateTime = yy & "年" & m & "月" & d & "日"
        Case "5"
            strDateTime = m & "-" & d
        Case "6"
            strDateTime = m & "/" & d
        Case "7"
            strDateTime = m & "月" & d & "日"
        Case "8"
            strDateTime = y & "年" & m & "月"
        Case "9"
            strDateTime = y & "-" & m
        Case "10"
            strDateTime = y & "/" & m
        Case "11"
            strDateTime = y & "-" & m & "-" & d
        Case "12"
            strDateTime = y & "/" & m & "/" & d
        Case "13"
            strDateTime = yy & "." & m & "." & d
        Case "14"
            strDateTime = yy & "-" & m & "-" & d
        Case Else
            strDateTime = DateAndTime
    End Select
    FormatDate2 = strDateTime
End Function

Public SiteTitle, SiteUrl, ComName, Address,Zipcode, Telephone, Mobile, Contacts, Fax, Email, Keywords, Descriptions, IcpNumber, gaba,gabah,Stats, SiteLogo, SiteDetail, Ico,share,SiteStatus, Explain
Public MobileTitle, MobileKeywords, MobileDescriptions, MobileLogo, MobileTelephone, MobileJump
Public TemplatePath, mTemplatePath
Public AboutDir, NewsDir, ProDir, CaseDir, DownDir, RecruitmentDir,VideoDir, AboutPc, NewsPc, ProPc, CasePc, DownPc, RecruitmentPc, AboutMc, NewsMc, ProMc, CaseMc, DownMc, RecruitmentMc
Public KfUser,Kfqq,KfPhone,KfWeChat
'读取配置信息
Sub SiteInfo()
    Dim rs, sql
    Set rs = server.CreateObject("adodb.recordset")
    sql = "select top 1 * from BokeCMS_Web"
    rs.Open sql, conn, 1, 1
    SiteTitle = rs("SiteTitle")
    Keywords = rs("Keywords")
    Descriptions = rs("Descriptions")
	Stats = rs("Stats")
    SiteUrl = rs("SiteUrl")
    ComName = rs("ComName")
    Address = rs("Address")
	Zipcode = rs("Zipcode")
    Telephone = rs("Telephone")
	Mobile = rs("Mobile")
    Contacts = rs("Contacts")
    Fax = rs("Fax")
    Email = rs("Email")
    IcpNumber = rs("IcpNumber")
	gaba = rs("gaba")
	gabah = rs("gabah")
    SiteLogo = rs("SiteLogo")
    SiteDetail = rs("SiteDetail")
    SiteStatus = rs("SiteStatus")
    Explain = rs("Explain")
    Ico = rs("Ico")
	share = rs("share")
    Call CloseRs(rs)

    Set rs = server.CreateObject("adodb.recordset")
    sql = "select top 1 * from BokeCMS_Contact where Sequence=1"
    rs.Open sql, conn, 1, 1
    KfUser = rs("User")
    Kfqq = rs("qq")
    KfPhone = rs("Phone")
	KfWeChat = rs("WeChat")
    Call CloseRs(rs)

    Set rs = server.CreateObject("adodb.recordset")
    sql = "select top 1 * from BokeCMS_Wap"
    rs.Open sql, conn, 1, 1
	If mStatus Then
		MobileTitle = rs("MobileTitle")
		MobileKeywords = rs("MobileKeywords")
		MobileDescriptions = rs("MobileDescriptions")
		MobileLogo = rs("MobileLogo")
		MobileTelephone = rs("MobileTelephone")
		MobileJump = rs("MobileJump")
	End If
   Call CloseRs(rs)

	If not Conn.execute("select * from BokeCMS_Template where UseFlag and SortName='PC'").eof Then
		TemplatePath  = Conn.execute("select top 1 * from BokeCMS_Template where UseFlag and SortName='PC'")("TemplatePath")
	End If
	
	If not Conn.execute("select * from BokeCMS_Template where UseFlag and SortName='Wap'").eof Then
		mTemplatePath = Conn.execute("select top 1 * from BokeCMS_Template where UseFlag and SortName='Wap'")("TemplatePath")
	End If

	AboutDir = Conn.execute("select * from BokeCMS_Module where DataForm=1")("SystemDir")
	NewsDir  = Conn.execute("select * from BokeCMS_Module where DataForm=2")("SystemDir")
	ProDir   = Conn.execute("select * from BokeCMS_Module where DataForm=3")("SystemDir")
	CaseDir  = Conn.execute("select * from BokeCMS_Module where DataForm=4")("SystemDir")
	DownDir  = Conn.execute("select * from BokeCMS_Module where DataForm=5")("SystemDir")
	RecruitmentDir   = Conn.execute("select * from BokeCMS_Module where DataForm=6")("SystemDir")
	VideoDir  = Conn.execute("select * from BokeCMS_Module where DataForm=7")("SystemDir")
End Sub

Function getEnglish(Str)
    getEnglish = Str	
	getEnglish = Replace(getEnglish, "博科", "bkkey")
End Function

'汉字转拼音
Function Pinyin(chinese)
	chinese = replace(chinese, "/", ""): chinese = replace(chinese, "\", "")
	chinese = replace(chinese, "*", ""): chinese = replace(chinese, "]", "")
	chinese = replace(chinese, "[", ""): chinese = replace(chinese, "}", "")
	chinese = replace(chinese, "{", ""): chinese = replace(chinese, "'", "")
	chinese = getEnglish(chinese)
	dim pinyinstr, istr, iIsCn, IsCn
	dim pinyinconn, rs, i, x
	on error resume next
	set pinyinconn = server.createobject("Adodb.connection")
	pinyinconn.open "Provider=Microsoft.Jet.OLEdb.4.0;Data Source=" & server.mappath("pinyin.asp")
	if err then pinyin = "" : set pinyinconn = nothing : exit function
	IsCn = true
	for i = 1 to len(chinese)
		iIsCn = IsCn '获取上次是不是中文的值
		istr = Mid(chinese, i, 1)
		Session.Codepage = 936 ' 修改成 936
'		x = Asc(istr) + 65536
		x = Asc(istr)
		Session.Codepage = 65001 ' 用完改回来	
		
		if (x >= 65 and x <= 90) or (x >= 97 and x <= 122) or (x >= 48 and x <= 57) or istr = " " then
			IsCn = False '这些是英文、数字(保留字符)
			if istr = " " then istr = "-"
		else
			set rs = pinyinconn.execute("select top 1 pinyin From pinyin where content like '%" & istr & "%';")
			if not rs.eof then
				'istr = lcase(rs(0)): IsCn = True '小写
				istr = rs(0): IsCn = True '首字母大写
			else
				IsCn = false
				if istr = " " then istr = "-" else istr = "" '将空格转换成"－"
			end if
			Call CloseRs(rs)
		end if
		if iIsCn = IsCn then pinyinstr = pinyinstr & istr else pinyinstr = pinyinstr & "-" & istr
		pinyinstr = replace(pinyinstr, "--", "-")
		pinyinstr = replace(pinyinstr, "__", "_")
	next

	if right(pinyinstr, 1) = "-" then pinyinstr = left(pinyinstr, len(pinyinstr) - 1)
	if right(pinyinstr, 1) = "_" then pinyinstr = left(pinyinstr, len(pinyinstr) - 1)
	if left(pinyinstr, 1) = "-" then pinyinstr = right(pinyinstr, len(pinyinstr) - 1)
	if left(pinyinstr, 1) = "_" then pinyinstr = right(pinyinstr, len(pinyinstr) - 1)
	pinyinconn.close : set pinyinconn = nothing
	Pinyin = trim(pinyinstr)
End Function

'删除静态页面
Sub DoDelHtml(htmlname)
    On Error Resume Next
    Set FSO = Server.CreateObject("Scripting.FileSystemObject")
    ServerMap = server.MapPath(htmlname)
    FSO.DeleteFile(ServerMap)
    Set FSO = Nothing
End Sub



'新建文件夹
Sub CreateFolder(strFolder)
	'首选判断要建立的文件夹是否已经存在
	Dim strTestFolder, objFSO
	strTestFolder = Server.Mappath(strFolder)
	Set objFSO = CreateObject("Scripting.FileSystemObject")
	' 检查文件夹是否存在
	If not objFSO.FolderExists(strTestFolder) Then
		Set objFSO = CreateObject("Scripting.FileSystemObject")
		' 建立文件夹
		objFSO.CreateFolder(strTestFolder)
		Set objFSO = Nothing
     End If
End Sub

'修改文件夹名称
Sub fldrename(nowfld, newfld)
	nowfld2 = server.mappath(nowfld) 
	newfld2 = server.mappath(newfld) 
	Set fso = CreateObject("Scripting.FileSystemObject")

	if fso.FolderExists(nowfld2) then
		if not fso.FolderExists(newfld2) then 
			fso.CopyFolder nowfld2, newfld2
			fso.DeleteFolder(nowfld2) 
		end if 
	else
		fso.CreateFolder(newfld2)
	end if 
	set fso = nothing 
End Sub

'删除文件夹
Sub DelFileFolder(strFolder)
	Dbpath=server.mappath(strFolder)
	dim fso,strRubbishFile
	Set fso = Server.CreateObject("Scripting.FileSystemObject")
	if fso.FolderExists(Dbpath) then    '判断是否有这文件夹
		fso.DeleteFolder(Dbpath)        '删除文件夹
	end if
End Sub

'日期格式化
Function TimeToName()
	yy = CStr(Year(now()))
	mm = CStr(Month(now()))
	dd = CStr(Day(now()))
	hh = CStr(Hour(now()))
	mi = CStr(Minute(now()))
	ss = CStr(Second(now()))

    If Len(mm) = 1 Then mm = "0" & mm
    If Len(dd) = 1 Then dd = "0" & dd
    If Len(hh) = 1 Then hh = "0" & hh
    If Len(mi) = 1 Then mi = "0" & mi
    If Len(ss) = 1 Then ss = "0" & ss

	TimeToName = yy & mm & dd & hh & mi & ss
End Function

'弹出提示框
Function SweetAlert(SweetType, title, text, showButton, action)
	response.Write "<!doctype html>" & vbCrLf
	response.Write "<link rel='stylesheet' type='text/css' href='SweetAlert/sweet-alert.css'>" & vbCrLf
	response.Write "<script src='SweetAlert/sweet-alert.min.js'></script>" & vbCrLf
	response.Write "<script>window.onload = function(){swal({title: '"&title&"',text: '"&text&"',type: '"&SweetType&"',showCancelButton: "&showButton&",confirmButtonColor: '#DD6B55',confirmButtonText: '确定'},function(){"&action&"});}</script>"
End Function

'******************************************
'检查组件是否已经安装
'****************bokew.net*****************
Function IsObjInstalled(strClassString)
 On Error Resume Next
 IsObjInstalled = False
 Err = 0
 Dim xTestObj
 Set xTestObj = Server.CreateObject(strClassString)
 If 0 = Err Then IsObjInstalled = True
 Set xTestObj = Nothing
 Err = 0
End Function


'*************************************************
'函数名：PicAspJpeg
'作  用：给上传图片加文字或图片水印
'参  数：picname带路径的图片名称
'******************bokew.net**********************
Sub PicAspJpeg(picname)
If SY_Bold=1 Then
SY_Bold=true
Else
SY_Bold=False
End if
SY_FontColor=right(SY_FontColor,6)
SY_FontColor="&H"&SY_FontColor&""
SY_BackgroundColor=right(SY_BackgroundColor,6)
SY_BackgroundColor="&H"&SY_BackgroundColor&""
Dim current_time
current_time=year(now) & right("0" & month(now),2) & right("0" & day(now),2) & right("0" & hour(now),2) & right("0" & minute(now),2)'格式当前时间 
	'文字水印
	On Error Resume Next
	Dim FSOpic
	Set FSOpic = Server.CreateObject("Scripting.FileSystemObject")
	if SY_Type=1 then		
		if fsopic.FileExists(Server.MapPath(picname)) Then
		If CCur(current_time)-CCur(Left(right(picname,len(picname)-InStrRev(picname,"/")),12))<SY_interval then'SY_interval分钟前旧图片不重复加水印
			Dim Jpeg                                                   '声明变量
			Set Jpeg = Server.CreateObject("Persits.Jpeg")             '调用组件
			Jpeg.Open Server.MapPath(picname)                          '源图片位置		
			Jpeg.Canvas.Font.Color = SY_FontColor          '水印字体颜色
			Jpeg.Canvas.Font.Family = SY_FontName          '水印字体		
			Jpeg.Canvas.Font.Size = SY_FontSize            '水印字体大小
			Jpeg.Canvas.Font.Bold = SY_Bold                '字体是否加粗
			'Jpeg.Canvas.Font.BkMode = "&H"&""&DrawShadowColor&""      '字体背景颜色，不启用为透明
			Jpeg.Canvas.Font.Quality = 3                               '文字清晰度
			Jpeg.Canvas.Print Jpeg.OriginalWidth-SY_X-50,Jpeg.OriginalHeight-30-SY_FontSize,SY_Text'水印文字,xy座标	
			Jpeg.Save Server.MapPath(picname) '//生成有水印的新图片及保存位置
			Set Jpeg = Nothing
		end If
		end if
	'图片水印
	elseif SY_Type=2 then
		If fsopic.FileExists(Server.MapPath(picname)) and fsopic.FileExists(Server.MapPath(""&SY_FileName&"")) then	'打开要加图片水印的图片
		If CCur(current_time)-CCur(Left(right(picname,len(picname)-InStrRev(picname,"/")),12))<SY_interval then'SY_interval分钟前旧图片不重复加水印

			Dim AspJpeg
			Set AspJpeg=Server.CreateObject("Persits.Jpeg")
			AspJpeg.Open Server.MapPath(picname)
			Dim T_AspJpeg,T_Left,T_Top
			Set T_AspJpeg=Server.CreateObject("Persits.Jpeg")
			T_AspJpeg.Open Server.MapPath(""&SY_FileName&"")'打开水印logo
			T_Left=GetPosition_X(AspJpeg.OriginalWidth,T_AspJpeg.Width,SY_X)
			T_Top=GetPosition_Y(AspJpeg.OriginalHeight,T_AspJpeg.Height,SY_Y)			
			AspJpeg.DrawImage T_Left,T_Top,T_AspJpeg,SY_Transparence,SY_BackgroundColor'参数分别为距左、距顶、水印图片、透明度、背景色			
			AspJpeg.Quality=100
			AspJpeg.Save Server.MapPath(picname)
			Set T_AspJpeg=Nothing
		End If
		End If
	end if
	Set FSOpic = Nothing
End Sub

'函数功能：获得图片的X坐标
Function GetPosition_X(ByVal t0,ByVal t1,ByVal t2)
    Select Case SY_coordinates
		Case 0:GetPosition_X=t2'左上
		Case 1:GetPosition_X=t2'左下
		Case 2:GetPosition_X=(t0-t1)/2'居中
		Case 3:GetPosition_X=t0-t1-t2'右上
		Case 4:GetPosition_X=t0-t1-t2'右下
		Case Else:GetPosition_X=0'不显示
	End Select
End Function

'函数功能：获得图片的Y坐标
Function GetPosition_Y(ByVal t0,ByVal t1,ByVal t2)
    Select Case SY_coordinates
		Case 0:GetPosition_Y=t2'左上
		Case 1:GetPosition_Y=t0-t1-t2'左下
		Case 2:GetPosition_Y=(t0-t1)/2'居中
		Case 3:GetPosition_Y=t2'右上
		Case 4:GetPosition_Y=t0-t1-t2'右下
		Case Else:GetPosition_Y=0'不显示
    End Select
End Function

'*************************************************
'函数名：content_pic
'作  用：搜索内容中的图片以|号分隔组成字符串
'参  数：content_pic(content),content为内容
         '得到的结果为|a1|a2...
'*************************************************
Function content_pic(content)
Dim regEx,Matches,Match,Strsimg,Bimg,Strsimg2,Bimg2
Set regEx = New RegExp '建立正则表达式。
regEx.Pattern = "(<img)(.[^<>]*)(src=)('|"&CHR(34)&"| )?(.[^'|\s|"&CHR(34)&"]*)(\.)(jpg|gif|png|bmp|jpeg)('|"&CHR(34)&"|\s|>)(.[^>]*)(>)" '设置模式。
regEx.IgnoreCase = True '设置是否区分字符大小写。
regEx.Global = True '设置全局可用性。
Set Matches = regEx.Execute(content) '执行内容图片搜索。
For Each Match in Matches '遍历匹配集合。 '输入图片地址
Bimg=Bimg&Match.SubMatches(4)&"."&Match.SubMatches(6)&"|"
Next
content_pic=Bimg
End Function



'*****************************************************
'函数功能：保存远程文件并替换字符串中的远程文件地址为本地
'参数：
'      bokew_HTML         : 要替换的字符串
'      bokew_SaveFilePath : 保存文件的路径
'      bokew_AspJpeg      : 是否给图片加水印，1加水印，0不加   
'*****************************************************
Server.ScriptTimeOut = 1000
'远程图片保存允许类型
Const bokew_FileExt="jpg|gif|bmp|png"
Function ReplaceRemoteUrl(bokew_HTML,bokew_SaveFilePath,bokew_AspJpeg)
     Dim bokew_Content
     bokew_Content = bokew_HTML
     If IsObjInstalled("Microsoft"&".XMLHTTP") = False then
         ReplaceRemoteUrl = bokew_Content
         Exit Function
     End If     
     Dim re,RemoteFile,RemoteFileurl,SaveFileName,SaveFileType,arrSaveFileNameS,arrSaveFileName,ranNum,dtNow
     Set re = new RegExp
     re.IgnoreCase = True
     re.Global = True
     re.Pattern = "((http|https|ftp|rtsp|mms):(\/\/|\\\\){1}((\w)+[.]){1,}(net|com|cn|org|cc|tv|[0-9]{1,3})(\S*\/)((\S)+[.]{1}(" & bokew_FileExt & ")))"
     Set RemoteFile = re.Execute(bokew_Content)
     For Each RemoteFileurl in RemoteFile
		 arrSaveFileName = Split(RemoteFileurl,".")
  		 SaveFileType=arrSaveFileName(UBound(arrSaveFileName))
		 dtNow=Now()
		 randomize
		 ranNum=int(90000*rnd)+10000
		 arrSaveFileName=year(dtNow) & right("0" & month(dtNow),2) & right("0" & day(dtNow),2) & right("0" & hour(dtNow),2) & right("0" & minute(dtNow),2) & right("0" & second(dtNow),2) & ranNum&"."&SaveFileType
         SaveFileName = bokew_SaveFilePath & arrSaveFileName
         Call SaveRemoteFile(SaveFileName,RemoteFileurl)

		 
'==========================================================给远程图片加水印==================================================================		 		 
		  If SY_Type>0 And bokew_AspJpeg=1 And ((action="about" And InStr(SY_watermark, "|1,")>0) Or (action="news" And InStr(SY_watermark, "|2,")>0) Or (action="product" And InStr(SY_watermark, "|3,")>0) Or (action="case" And InStr(SY_watermark, "|4,")>0) Or (action="download" And InStr(SY_watermark, "|5,")>0) Or (action="recruitment" And InStr(SY_watermark, "|6,")>0) Or (action="video" And InStr(SY_watermark, "|7,")>0) Or (action="link" And InStr(SY_watermark, "|11,")>0) Or (action="ad" And InStr(SY_watermark, "|12,")>0) Or (action="ads" And InStr(SY_watermark, "|13,")>0) Or (action="slides" And InStr(SY_watermark, "|14,")>0)) then
		 	Call PicAspJpeg(SaveFileName)'给远程图片加水印
		  End If
'========================================================给远程图片加水印END====bokew.net====================================================


         bokew_Content = Replace(bokew_Content,RemoteFileurl,SaveFileName)
     Next
     ReplaceRemoteUrl = bokew_Content
End Function

'*********************************************
'函数功能：操作保存远程的文件到本地
'参 数：
'       bokew_LocalFileName：本地文件名
'       bokew_RemoteFileUrl：远程文件URL
'返回值：
'True   成功
'False  失败
'*********************************************
Sub SaveRemoteFile(bokew_LocalFileName,bokew_RemoteFileUrl)
     Dim Ads, Retrieval, GetRemoteData
     On Error Resume Next
     Set Retrieval = Server.CreateObject("Microsoft"&".XMLHTTP")
     With Retrieval
         .Open "Get",bokew_RemoteFileUrl,False,"",""
         .Send
         GetRemoteData = .ResponseBody
     End With
     Set Retrieval = Nothing
     Set Ads = Server.CreateObject("Adodb"&".Stream")
     With Ads
         .Type = 1
         .Open
         .Write GetRemoteData
         .SaveToFile Server.MapPath(bokew_LocalFileName),2
         .Cancel()
         .Close()
     End With
     Set Ads=nothing
End Sub

'==============图片水印end===============

'**********************************jmail发信函数************************************
'函数名：bokeEmail() 
'作用：利用Jmail4.3组件发送E-Mail
'参数：
'Email:类型：字符串。作用：接收方E-Mail的地址。
'HostName邮件发送者名字
'E_Subject:类型：字符串。作用：信件主题。
'Information:类型：字符串。作用：信件内容。
'S_Type:类型：布尔值。作用：是否为Html格式信件。True为Html格式。False为文本格式。 
'C_M_Chk:类型：布尔值。作用：Smtp服务器是否需要身份验证 ,True需要验证，False不需要验证。
'如果发送成功，函数将返回True否则返回False
'调用：Call bokeEmail(Email,HostName,E_Subject,Information,S_Type,C_M_Chk)
'***********************************************************************************

Function bokeEmail(Email,HostName,E_Subject,Information,S_Type,C_M_Chk)'括号里面分别是：邮件接收人信箱，发信人名称，邮件主题，邮件内容 ，信件格式，是否要验证
Dim C_Email,C_HostName,C_Smtp,C_M_User,C_M_Pass
C_Email=mailform'发送者的邮箱
C_HostName=HostName'发送者的名字
C_M_User=mailname'邮箱用户名
C_M_Pass=mailpass'登录密码
C_Smtp=mailsmtp'Smtp服务器地址

Dim boke_Jmail
Err.Clear
On Error Resume Next
If Email="" Or Information="" Or E_Subject="" Then
bokeEmail="<br><li>检查收信邮箱、信件标题、信件内容是否为空！<a href=""javascript:history.back(-1);"">返回</a></li>" 
Exit Function
End If
set boke_Jmail=Server.CreateObject("Jmail.message")'建立发送邮件的对象
if err then 
bokeEmail= "<br><li>服务器没有安装JMail组件，无法发送邮件！</li>" 
err.clear 
exit Function 
end if 
boke_Jmail.silent = true '屏蔽例外错误，返回FALSE跟TRUE两值
boke_Jmail.Charset="gb2312" '邮件的文字编码为国标,不要此句可能出现乱码
boke_Jmail.Logging=True'启用邮件日志 
boke_Jmail.From=C_Email '发件人的E-MAIL地址
boke_Jmail.Fromname=C_HostName'发送者的名字
boke_Jmail.addrecipient Email'邮件收件人的地址
boke_Jmail.subject=E_Subject'信件主题
If S_Type=False Then'文本或HTML格式
boke_Jmail.appendtext Information
Else
boke_Jmail.AppendHtml Information
End If
boke_Jmail.maildomain=C_Smtp'Smtp服务器地址
If C_M_Chk=True Then'Smtp服务器验证用户名和密码
boke_Jmail.mailserverusername=C_M_User'登录邮件服务器所需的用户名
boke_Jmail.mailserverpassword=C_M_Pass'登录邮件服务器所需的密码
End If
boke_Jmail.Priority = 1'邮件的紧急程序，1 为最快，5 为最慢， 3 为默认值
boke_Jmail.send(C_Smtp)'执行邮件发送（通过邮件服务器地址）
If Err.Number<>0 Then'判断是否发送成功
bokeEmail="<li>邮件发送失败，请检查邮件发送系统参数和收信人信箱是否正确！"'失败返回
Else
bokeEmail="<li>邮件发送成功！"&SiteTitle&""'成功返回
End If
Err.Clear
Set boke_Jmail=nothing'消毁对象
End Function%>