<%@LANGUAGE="VBSCRIPT" CODEPAGE="936"%>
<%option explicit%>
<%
Dim SqlNowString,SiteSN,Conn,DBPath,CollectDBPath,DataServer,DataUser,DataBaseName,DataBasePsw,ConnStr,CollcetConnStr
Const DataBaseType=0 '系统数据库类型，"1"为MS SQL2000数据库，"0"为MS ACCESS 2000数据库
Const SysVer=1
Const MsxmlVersion=".3.0" '系统采用XML版本设置
If DataBaseType=0 then
'如果是ACCESS数据库，请认真修改好下面的数据库的文件名
DBPath= "/fangfangonline_Data/fangfangonline_Datacenter.asp" 'ACCESS数据库的文件名，请使用相对于网站根目录的的绝对路径
SqlNowString = "Now()"
Else
'如果是SQL数据库，请认真修改好以下数据库选项
DataServer = "(local)" '数据库服务器IP
DataUser = "sa" '访问数据库用户名
DataBaseName = "kesioncms4" '数据库名称
DataBasePsw = "989066" '访问数据库密码
SqlNowString = "getdate()"
End if
'采集数据库路径
CollectDBPath="\fangfangonline_Data\Collect\KS_Collect.Mdb"
Call OpenConn
Sub OpenConn()
On Error Resume Next
If DataBaseType = 1 Then
ConnStr="Provider = Sqloledb; User ID = " & datauser & "; Password = " & databasepsw & "; Initial Catalog = " & databasename & "; Data Source = " & dataserver & ";"
Else
ConnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(DBPath)
End If
Set conn = Server.CreateObject("ADODB.Connection")
conn.open ConnStr
If Err Then Err.Clear:Set conn = Nothing:Response.Write "数据库连接出错，请检查Conn.asp文件中的数据库参数设置。":Response.End
CollcetConnStr ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(CollectDBPath)
End Sub
Sub CloseConn()
On Error Resume Next
Conn.close:Set Conn=nothing
End sub
%>
<%
Class Thumb
Private KS
Private Sub Class_Initialize()
Set KS=New PublicCls
End Sub
Private Sub Class_Terminate()
' Call CloseConn()
Set KS=Nothing
End Sub
'为图片添加水印
Function AddWaterMark(FileName)
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(KS.Setting(99))
If objFileSystem.FileExists(FileName) Then
If KS.TbSetting(5) <> "0" Then
Select Case KS.TbSetting(5)
Case "1"
If KS.IsObjInstalled("Persits.Jpeg") Then
If KS.IsExpired("Persits.Jpeg") Then
Response.Write ("对不起，Persits.Jpeg组件已过期!")
Response.End
End If
If KS.TbSetting(6) = "1" Then
AddWordMark 1, KS.TbSetting(8), KS.TbSetting(10), KS.TbSetting(11), KS.TbSetting(12), KS.TbSetting(9), KS.TbSetting(7), FileName
Else
AddPhotoMark 1, KS.TbSetting(16), KS.TbSetting(17), KS.TbSetting(13), KS.TbSetting(14), KS.TbSetting(15), KS.TbSetting(7), FileName
End If
End If
Case "2"
If strFileExtName = "png" Then
Exit Function
End If
If KS.IsObjInstalled("wsImage.Resize") Then
If KS.IsExpired("wsImage.Resize") Then
Response.Write ("对不起，sImage.Resize组件已过期!")
Response.End
End If
If KS.TbSetting(6) = "1" Then
AddWordMark 2, KS.TbSetting(8), KS.TbSetting(10), KS.TbSetting(11), KS.TbSetting(12), KS.TbSetting(9), KS.TbSetting(7), FileName
Else
AddPhotoMark 2, KS.TbSetting(16), KS.TbSetting(17), KS.TbSetting(13), KS.TbSetting(14), KS.TbSetting(15), KS.TbSetting(7), FileName
End If
End If
Case "3"
If KS.IsObjInstalled("SoftArtisans.ImageGen") Then
If KS.IsExpired("SoftArtisans.ImageGen") Then
Response.Write ("对不起，SoftArtisans.ImageGen组件已过期!")
Response.End
End If
If KS.TbSetting(6) = "1" Then
AddWordMark 3, KS.TbSetting(8), KS.TbSetting(10), KS.TbSetting(11), KS.TbSetting(12), KS.TbSetting(9), KS.TbSetting(7), FileName
Else
AddPhotoMark 3, KS.TbSetting(16), KS.TbSetting(17), KS.TbSetting(13), KS.TbSetting(14), KS.TbSetting(15), KS.TbSetting(7), 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 KS.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
TextWidth = objImage.Canvas.GetTextExtent(Text)
If objImage.OriginalWidth < TextWidth Or objImage.OriginalHeight < FontSize Then
Exit Function
End If
GetPostion CInt(MarkPosition), x, y, objImage.OriginalWidth, objImage.OriginalHeight, TextWidth, FontSize
With objImage.Canvas
.Print x, y, Text
End With
objImage.Save FileName
Case 2
If Not KS.IsObjInstalled("wsImage.Resize") Then
Exit Function
End If
Set objImage = Server.CreateObject("wsImage.Resize")
objImage.LoadSoucePic CStr(FileName)
objImage.TxtMarkFont = CStr(FontName)
objImage.TxtMarkBond = FondBond
objImage.TxtMarkHeight = FontSize
FontColor = "&H" & Mid(FontColor, 7) & Mid(FontColor, 5, 2) & Mid(FontColor, 3, 2)
objImage.AddTxtMark CStr(FileName), CStr(Text), CLng(FontColor), 1, 1
Case 3
If Not KS.IsObjInstalled("SoftArtisans.ImageGen") Then
Exit Function
End If
Set objImage = Server.CreateObject("SoftArtisans.ImageGen")
objImage.LoadImage FileName
objImage.Font.Height = FontSize
objImage.Font.name = FontName
FontColor = "&H" & Mid(FontColor, 7) & Mid(FontColor, 5, 2) & Mid(FontColor, 3, 2)
objImage.Font.Color = CLng(FontColor)
objImage.Text = Text
GetPostion CInt(MarkPosition), x, y, objImage.Width, objImage.Height, objImage.TextWidth, objImage.TextHeight
objImage.DrawTextOnImage x, y, objImage.TextWidth, objImage.TextHeight
objImage.SaveImage 0, objImage.ImageFormat, 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 KS.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
Case 2
If Not KS.IsObjInstalled("wsImage.Resize") Then
Exit Function
End If
Set objImage = Server.CreateObject("wsImage.Resize")
objImage.LoadSoucePic CStr(FileName)
objImage.LoadImgMarkPic Server.MapPath(MarkPicture)
objImage.GetSourceInfo OriginalWidth, OriginalHeight
GetPostion CInt(MarkPosition), x, y, OriginalWidth, OriginalHeight, MarkWidth, MarkHeight
If MarkTranspColor = "" Then
MarkTranspColor = 0
Else
MarkTranspColor = "&H" & Mid(MarkTranspColor, 7) & Mid(MarkTranspColor, 5, 2) & Mid(MarkTranspColor, 3, 2)
End If
objImage.AddImgMark CStr(FileName), Int(x), Int(y), CLng(MarkTranspColor), Int(CSng(MarkOpacity) * 100)
Case 3
If Not KS.IsObjInstalled("SoftArtisans.ImageGen") Then
Exit Function
End If
Set objImage = Server.CreateObject("SoftArtisans.ImageGen")
objImage.LoadImage FileName
Select Case CInt(MarkPosition)
Case 1
Position = 3
Case 2
Position = 5
Case 3
Position = 1
Case 4
Position = 6
Case 5
Position = 8
End Select
If MarkTranspColor <> "" Then
MarkTranspColor = "&H" & Mid(MarkTranspColor, 7) & Mid(MarkTranspColor, 5, 2) & Mid(MarkTranspColor, 3, 2)
objImage.AddWaterMark Server.MapPath(MarkPicture), Position, CSng(MarkOpacity), CLng(MarkTranspColor)
Else
objImage.AddWaterMark Server.MapPath(MarkPicture), Position, CSng(MarkOpacity)
End If
objImage.SaveImage 0, objImage.ImageFormat, 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 = 1
y = 1
Case 2
x = 1
y = Int(ImageHeight - MarkHeight - 1)
Case 3
x = Int((ImageWidth - MarkWidth) / 2)
y = Int((ImageHeight - MarkHeight) / 2)
Case 4
x = Int(ImageWidth - MarkWidth - 1)
y = 1
Case 5
x = Int(ImageWidth - MarkWidth - 1)
y = Int(ImageHeight - MarkHeight - 1)
End Select
End Function
'由原图片根据数据里保存的设置生成缩略图
Function CreateThumbs(FileName, ThumbFileName)
CreateThumbs = False
If KS.TbSetting(0) <> "0" And (Not IsNull(KS.TbSetting(0))) Then
If KS.TbSetting(1) = "0" Then
CreateThumbs = CreateThumb(FileName, CInt(KS.TbSetting(2)), CInt(KS.TbSetting(3)), 0, ThumbFileName)
Else
CreateThumbs = CreateThumb(FileName, 0, 0, CSng(KS.TbSetting(4)), ThumbFileName)
End If
End If
End Function
'由原图片生成指定宽度和高度的缩略图
Function CreateThumb(FileName, Width, Height, Rate, ThumbFileName)
On Error Resume Next
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(KS.TbSetting(0))
Case 0
Exit Function
Case 1
If Not KS.IsObjInstalled("Persits.Jpeg") Then
Exit Function
End If
If KS.IsExpired("Persits.Jpeg") Then
Response.Write ("对不起，Persits.Jpeg组件已过期！")
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
Case 2
If Not KS.IsObjInstalled("wsImage.Resize") Then
Exit Function
End If
If KS.IsExpired("wsImage.Resize") Then
Response.Write ("对不起，wsImage.Resize组件已过期！")
Response.End
End If
If strFileExtName = "png" Then
Exit Function
End If
Set objImage = Server.CreateObject("wsImage.Resize")
objImage.LoadSoucePic CStr(FileName)
If Rate = 0 And (Width <> 0 Or Height <> 0) Then
objImage.GetSourceInfo iWidth, iHeight
If Width < iWidth And Height < iHeight Then
If Width = 0 And Height <> 0 Then
objImage.OutputSpic CStr(ThumbFileName), 0, Height, 2
ElseIf Width <> 0 And Height = 0 Then
objImage.OutputSpic CStr(ThumbFileName), Width, 0, 1
ElseIf Width <> 0 And Height <> 0 Then
objImage.OutputSpic CStr(ThumbFileName), Width, Height, 0
Else
objImage.OutputSpic CStr(ThumbFileName), 1, 1, 3
End If
Else
objImage.OutputSpic CStr(ThumbFileName), 1, 1, 3
End If
ElseIf Rate <> 0 Then
objImage.OutputSpic CStr(ThumbFileName), Rate, Rate, 3
Else
objImage.OutputSpic CStr(ThumbFileName), 1, 1, 3
End If
Case 3
If Not KS.IsObjInstalled("SoftArtisans.ImageGen") Then
Exit Function
End If
If KS.IsExpired("SoftArtisans.ImageGen") Then
Response.Write ("对不起，SoftArtisans.ImageGen组件已过期！")
Response.End
End If
Set objImage = Server.CreateObject("SoftArtisans.ImageGen")
objImage.LoadImage FileName
If Rate = 0 And (Width <> 0 Or Height <> 0) Then
If Width < objImage.Width And Height < objImage.Height Then
If Width = 0 And Height <> 0 Then
objImage.CreateThumb , CLng(Height), 0, True
ElseIf Width <> 0 And Height = 0 Then
objImage.CreateThumb CLng(Width), objImage.Height / objImage.Width * Width, 0, False
ElseIf Width <> 0 And Height <> 0 Then
objImage.CreateThumb CLng(Width), CLng(Height), 0, False
End If
End If
ElseIf Rate <> 0 Then
objImage.CreateThumb CLng(objImage.Width * Rate), CLng(objImage.Height * Rate), 0, False
End If
objImage.SaveImage 0, objImage.ImageFormat, ThumbFileName
Case 4
If Not KS.IsObjInstalled("CreatePreviewImage.cGvbox") Then
Exit Function
End If
Set objImage = Server.CreateObject("CreatePreviewImage.cGvbox")
objImage.SetImageFile = FileName
If Rate = 0 And (Width <> 0 Or Height <> 0) Then
objImage.SetPreviewImageSize = Width
ElseIf Rate <> 0 Then
objImage.SetPreviewImageSize = objImage.SetPreviewImageSize * Rate
End If
objImage.SetSavePreviewImagePath = ThumbFileName
If objImage.DoImageProcess = False Then
Exit Function
End If
End Select
CreateThumb = True
End Function
End Class
%>
<%
Class CtoECls
Private Sub Class_Initialize()
End Sub
Private Sub Class_Terminate()
End Sub
function CTOE(str)
Dim i
CTOE=""
for i=1 to len(str)
CTOE=CTOE&CETrans(asc(mid(str,i,1)))
next
end function
function CETrans(num)
Dim a,b,i,d
Set d = CreateObject("Scripting.Dictionary")
d.add "a",-20319
d.add "ai",-20317
d.add "an",-20304
d.add "ang",-20295
d.add "ao",-20292
d.add "ba",-20283
d.add "bai",-20265
d.add "ban",-20257
d.add "bang",-20242
d.add "bao",-20230
d.add "bei",-20051
d.add "ben",-20036
d.add "beng",-20032
d.add "bi",-20026
d.add "bian",-20002
d.add "biao",-19990
d.add "bie",-19986
d.add "bin",-19982
d.add "bing",-19976
d.add "bo",-19805
d.add "bu",-19784
d.add "ca",-19775
d.add "cai",-19774
d.add "can",-19763
d.add "cang",-19756
d.add "cao",-19751
d.add "ce",-19746
d.add "ceng",-19741
d.add "cha",-19739
d.add "chai",-19728
d.add "chan",-19725
d.add "chang",-19715
d.add "chao",-19540
d.add "che",-19531
d.add "chen",-19525
d.add "cheng",-19515
d.add "chi",-19500
d.add "chong",-19484
d.add "chou",-19479
d.add "chu",-19467
d.add "chuai",-19289
d.add "chuan",-19288
d.add "chuang",-19281
d.add "chui",-19275
d.add "chun",-19270
d.add "chuo",-19263
d.add "ci",-19261
d.add "cong",-19249
d.add "cou",-19243
d.add "cu",-19242
d.add "cuan",-19238
d.add "cui",-19235
d.add "cun",-19227
d.add "cuo",-19224
d.add "da",-19218
d.add "dai",-19212
d.add "dan",-19038
d.add "dang",-19023
d.add "dao",-19018
d.add "de",-19006
d.add "deng",-19003
d.add "di",-18996
d.add "dian",-18977
d.add "diao",-18961
d.add "die",-18952
d.add "ding",-18783
d.add "diu",-18774
d.add "dong",-18773
d.add "dou",-18763
d.add "du",-18756
d.add "duan",-18741
d.add "dui",-18735
d.add "dun",-18731
d.add "duo",-18722
d.add "e",-18710
d.add "en",-18697
d.add "er",-18696
d.add "fa",-18526
d.add "fan",-18518
d.add "fang",-18501
d.add "fei",-18490
d.add "fen",-18478
d.add "feng",-18463
d.add "fo",-18448
d.add "fou",-18447
d.add "fu",-18446
d.add "ga",-18239
d.add "gai",-18237
d.add "gan",-18231
d.add "gang",-18220
d.add "gao",-18211
d.add "ge",-18201
d.add "gei",-18184
d.add "gen",-18183
d.add "geng",-18181
d.add "gong",-18012
d.add "gou",-17997
d.add "gu",-17988
d.add "gua",-17970
d.add "guai",-17964
d.add "guan",-17961
d.add "guang",-17950
d.add "gui",-17947
d.add "gun",-17931
d.add "guo",-17928
d.add "ha",-17922
d.add "hai",-17759
d.add "han",-17752
d.add "hang",-17733
d.add "hao",-17730
d.add "he",-17721
d.add "hei",-17703
d.add "hen",-17701
d.add "heng",-17697
d.add "hong",-17692
d.add "hou",-17683
d.add "hu",-17676
d.add "hua",-17496
d.add "huai",-17487
d.add "huan",-17482
d.add "huang",-17468
d.add "hui",-17454
d.add "hun",-17433
d.add "huo",-17427
d.add "ji",-17417
d.add "jia",-17202
d.add "jian",-17185
d.add "jiang",-16983
d.add "jiao",-16970
d.add "jie",-16942
d.add "jin",-16915
d.add "jing",-16733
d.add "jiong",-16708
d.add "jiu",-16706
d.add "ju",-16689
d.add "juan",-16664
d.add "jue",-16657
d.add "jun",-16647
d.add "ka",-16474
d.add "kai",-16470
d.add "kan",-16465
d.add "kang",-16459
d.add "kao",-16452
d.add "ke",-16448
d.add "ken",-16433
d.add "keng",-16429
d.add "kong",-16427
d.add "kou",-16423
d.add "ku",-16419
d.add "kua",-16412
d.add "kuai",-16407
d.add "kuan",-16403
d.add "kuang",-16401
d.add "kui",-16393
d.add "kun",-16220
d.add "kuo",-16216
d.add "la",-16212
d.add "lai",-16205
d.add "lan",-16202
d.add "lang",-16187
d.add "lao",-16180
d.add "le",-16171
d.add "lei",-16169
d.add "leng",-16158
d.add "li",-16155
d.add "lia",-15959
d.add "lian",-15958
d.add "liang",-15944
d.add "liao",-15933
d.add "lie",-15920
d.add "lin",-15915
d.add "ling",-15903
d.add "liu",-15889
d.add "long",-15878
d.add "lou",-15707
d.add "lu",-15701
d.add "lv",-15681
d.add "luan",-15667
d.add "lue",-15661
d.add "lun",-15659
d.add "luo",-15652
d.add "ma",-15640
d.add "mai",-15631
d.add "man",-15625
d.add "mang",-15454
d.add "mao",-15448
d.add "me",-15436
d.add "mei",-15435
d.add "men",-15419
d.add "meng",-15416
d.add "mi",-15408
d.add "mian",-15394
d.add "miao",-15385
d.add "mie",-15377
d.add "min",-15375
d.add "ming",-15369
d.add "miu",-15363
d.add "mo",-15362
d.add "mou",-15183
d.add "mu",-15180
d.add "na",-15165
d.add "nai",-15158
d.add "nan",-15153
d.add "nang",-15150
d.add "nao",-15149
d.add "ne",-15144
d.add "nei",-15143
d.add "nen",-15141
d.add "neng",-15140
d.add "ni",-15139
d.add "nian",-15128
d.add "niang",-15121
d.add "niao",-15119
d.add "nie",-15117
d.add "nin",-15110
d.add "ning",-15109
d.add "niu",-14941
d.add "nong",-14937
d.add "nu",-14933
d.add "nv",-14930
d.add "nuan",-14929
d.add "nue",-14928
d.add "nuo",-14926
d.add "o",-14922
d.add "ou",-14921
d.add "pa",-14914
d.add "pai",-14908
d.add "pan",-14902
d.add "pang",-14894
d.add "pao",-14889
d.add "pei",-14882
d.add "pen",-14873
d.add "peng",-14871
d.add "pi",-14857
d.add "pian",-14678
d.add "piao",-14674
d.add "pie",-14670
d.add "pin",-14668
d.add "ping",-14663
d.add "po",-14654
d.add "pu",-14645
d.add "qi",-14630
d.add "qia",-14594
d.add "qian",-14429
d.add "qiang",-14407
d.add "qiao",-14399
d.add "qie",-14384
d.add "qin",-14379
d.add "qing",-14368
d.add "qiong",-14355
d.add "qiu",-14353
d.add "qu",-14345
d.add "quan",-14170
d.add "que",-14159
d.add "qun",-14151
d.add "ran",-14149
d.add "rang",-14145
d.add "rao",-14140
d.add "re",-14137
d.add "ren",-14135
d.add "reng",-14125
d.add "ri",-14123
d.add "rong",-14122
d.add "rou",-14112
d.add "ru",-14109
d.add "ruan",-14099
d.add "rui",-14097
d.add "run",-14094
d.add "ruo",-14092
d.add "sa",-14090
d.add "sai",-14087
d.add "san",-14083
d.add "sang",-13917
d.add "sao",-13914
d.add "se",-13910
d.add "sen",-13907
d.add "seng",-13906
d.add "sha",-13905
d.add "shai",-13896
d.add "shan",-13894
d.add "shang",-13878
d.add "shao",-13870
d.add "she",-13859
d.add "shen",-13847
d.add "sheng",-13831
d.add "shi",-13658
d.add "shou",-13611
d.add "shu",-13601
d.add "shua",-13406
d.add "shuai",-13404
d.add "shuan",-13400
d.add "shuang",-13398
d.add "shui",-13395
d.add "shun",-13391
d.add "shuo",-13387
d.add "si",-13383
d.add "song",-13367
d.add "sou",-13359
d.add "su",-13356
d.add "suan",-13343
d.add "sui",-13340
d.add "sun",-13329
d.add "suo",-13326
d.add "ta",-13318
d.add "tai",-13147
d.add "tan",-13138
d.add "tang",-13120
d.add "tao",-13107
d.add "te",-13096
d.add "teng",-13095
d.add "ti",-13091
d.add "tian",-13076
d.add "tiao",-13068
d.add "tie",-13063
d.add "ting",-13060
d.add "tong",-12888
d.add "tou",-12875
d.add "tu",-12871
d.add "tuan",-12860
d.add "tui",-12858
d.add "tun",-12852
d.add "tuo",-12849
d.add "wa",-12838
d.add "wai",-12831
d.add "wan",-12829
d.add "wang",-12812
d.add "wei",-12802
d.add "wen",-12607
d.add "weng",-12597
d.add "wo",-12594
d.add "wu",-12585
d.add "xi",-12556
d.add "xia",-12359
d.add "xian",-12346
d.add "xiang",-12320
d.add "xiao",-12300
d.add "xie",-12120
d.add "xin",-12099
d.add "xing",-12089
d.add "xiong",-12074
d.add "xiu",-12067
d.add "xu",-12058
d.add "xuan",-12039
d.add "xue",-11867
d.add "xun",-11861
d.add "ya",-11847
d.add "yan",-11831
d.add "yang",-11798
d.add "yao",-11781
d.add "ye",-11604
d.add "yi",-11589
d.add "yin",-11536
d.add "ying",-11358
d.add "yo",-11340
d.add "yong",-11339
d.add "you",-11324
d.add "yu",-11303
d.add "yuan",-11097
d.add "yue",-11077
d.add "yun",-11067
d.add "za",-11055
d.add "zai",-11052
d.add "zan",-11045
d.add "zang",-11041
d.add "zao",-11038
d.add "ze",-11024
d.add "zei",-11020
d.add "zen",-11019
d.add "zeng",-11018
d.add "zha",-11014
d.add "zhai",-10838
d.add "zhan",-10832
d.add "zhang",-10815
d.add "zhao",-10800
d.add "zhe",-10790
d.add "zhen",-10780
d.add "zheng",-10764
d.add "zhi",-10587
d.add "zhong",-10544
d.add "zhou",-10533
d.add "zhu",-10519
d.add "zhua",-10331
d.add "zhuai",-10329
d.add "zhuan",-10328
d.add "zhuang",-10322
d.add "zhui",-10315
d.add "zhun",-10309
d.add "zhuo",-10307
d.add "zi",-10296
d.add "zong",-10281
d.add "zou",-10274
d.add "zu",-10270
d.add "zuan",-10262
d.add "zui",-10260
d.add "zun",-10256
d.add "zuo",-10254
if num>0 and num<160 then
CETrans=chr(num)
else
if num<-20319 or num>-10247 then
CETrans=""
else
a=d.Items
b=d.keys
for i=d.count-1 to 0 step -1
if a(i)<=num then exit for
next
CETrans=b(i)
end if
end if
end function
End Class
%>
<%
Class PublicCls
Private LocalCacheName,Cache_Data,CacheData,Reloadtime
Public SiteSN,Version
Public Setting,TbSetting,SSetting
Private Sub Class_Initialize()
if Not Response.IsClientConnected then response.End()
Call KSInitialize
End Sub
Private Sub Class_Terminate()
End Sub
'*******************************************************************************************************************
'函数名：KSInitialize
'作 用: 加载CMS的必要参数
'备 注：以下参数请不要更改。否则系统可能无法正常运行
'*******************************************************************************************************************
Public Function KSInitialize()
Call GetConfig()
Setting=Split(CacheData(0,0),"^%^")
TbSetting=Split(CacheData(1,0),"^%^")
SSetting=Split(CacheData(2,0),"^%^")
SiteSN = Replace(Replace(LCase(Request.ServerVariables("SERVER_NAME")), "/", ""), ".", "") '--缓存名称
Reloadtime = 28800
Version = "ks4.5"
Call IsIPlock() 'IP访问限制
End Function
'===================服务器缓存部分函数开始===================
Public Property Let Name(ByVal vNewValue)
LocalCacheName = LCase(vNewValue)
Cache_Data = Application(SiteSN & "_" & LocalCacheName)
End Property
Public Property Let Value(ByVal vNewValue)
If LocalCacheName <> "" Then
ReDim Cache_Data(2)
Cache_Data(0) = vNewValue
Cache_Data(1) = Now()
Application.Lock
Application(SiteSN & "_" & LocalCacheName) = Cache_Data
Application.UnLock
Else
Err.Raise vbObjectError + 1, "KesionCacheServer", " please change the CacheName."
End If
End Property
Public Property Get Value()
If LocalCacheName <> "" Then
If IsArray(Cache_Data) Then
Value = Cache_Data(0)
Else
'Err.Raise vbObjectError + 1, "KesionCacheServer", " The Cache_Data("&LocalCacheName&") Is Empty."
End If
Else
Err.Raise vbObjectError + 1, "KesionCacheServer", " please change the CacheName."
End If
End Property
Public Function ObjIsEmpty()
ObjIsEmpty = True
If Not IsArray(Cache_Data) Then Exit Function
If Not IsDate(Cache_Data(1)) Then Exit Function
If DateDiff("s", CDate(Cache_Data(1)), Now()) < (60 * Reloadtime) Then ObjIsEmpty = False
End Function
'不提示,批量清除缓存,参数 PreCacheName-前段匹配
Public Sub DelCaches(PreCacheName)
Dim i
Dim CacheList:CacheList=split(GetCacheList(PreCacheName),",")
If UBound(CacheList)>1 Then
For i=0 to UBound(CacheList)-1
DelCahe CacheList(i)
Next
End IF
End Sub
'取得缓存列表 参数 PreCacheName-前段匹配
Public Function GetCacheList(PreCacheName)
Dim Cacheobj
For Each Cacheobj in Application.Contents
If CStr(Left(Cacheobj,Len(PreCacheName)))=CStr(PreCacheName) Then GetCacheList=GetCacheList&Cacheobj&","
Next
End Function
'清除缓存,参数 MyCaheName-缓存名称
Public Sub DelCahe(MyCaheName)
Application.Lock
Application.Contents.Remove(MyCaheName)
Application.unLock
End Sub
'===================服务器缓存部分函数结束===================
Public Sub GetSetting()
Dim RS:Set RS=Server.CreateObject("ADODB.RECORDSET")
RS.Open "SELECT Setting,TbSetting,SpaceSetting from [KS_Config]",conn,1,1
value=RS.GetRows(1)
RS.Close:Set RS=Nothing
End Sub
Public Sub GetConfig()
Name = "Config"
If ObjIsEmpty() Then GetSetting
CacheData = Value
Name = "Date"
If ObjIsEmpty() Then
Value = Date
Else
If CStr(Value) <> CStr(Date) Then
Name = "Config"
Call GetSetting
CacheData = Value
End If
End If
If Len(CacheData(1, 0)) = 0 Then
Name = "Config"
Call GetSetting
CacheData = Value
End If
End Sub
'xmlroot跟节点名称 row记录行节点名称
Public Function RecordsetToxml(RSObj,row,xmlroot)
Dim i,node,rs,j,DataArray
If xmlroot="" Then xmlroot="xml"
If row="" Then row="row"
Set RecordsetToxml=Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
RecordsetToxml.appendChild(RecordsetToxml.createElement(xmlroot))
If Not RSObj.EOF Then
DataArray=RSObj.GetRows(-1)
For i=0 To UBound(DataArray,2)
Set Node=RecordsetToxml.createNode(1,row,"")
j=0
For Each rs in RSObj.Fields
node.attributes.setNamedItem(RecordsetToxml.createNode(2,"ks"&j,"")).text= DataArray(j,i)& ""
j=j+1
Next
RecordsetToxml.documentElement.appendChild(Node)
Next
End If
DataArray=Null
End Function
Public Function LoadChannelConfig()
Application.Lock
Dim RS:Set Rs=conn.execute("select ChannelID,ChannelName,ChannelTable,ItemName,ItemUnit,FieldBit,BasicType,FsoHtmlTF,FsoFolder,RefreshFlag,ModelEname,MaxPerPage,VerificCommentTF,CommentVF,CommentLen,CommentTemplate,UserSelectFilesTF,InfoVerificTF,UserAddMoney,UserAddPoint,UserAddScore,ChannelStatus,CollectTF,UpFilesTF,UpFilesDir,UpFilesSize,UserUpFilesTF,UserUpFilesDir,AllowUpPhotoType,AllowUpFlashType,AllowUpMediaType,AllowUpRealType,AllowUpOtherType,SearchTemplate,EditorType From KS_Channel Order by ChannelID")
Set Application(SiteSN&"_ChannelConfig")=RecordsetToxml(rs,"channel","ChannelConfig")
Set Rs=Nothing
Application.unLock
End Function
Function C_S(sChannelID,FieldID)
on error resume next
If not IsObject(Application(SiteSN&"_ChannelConfig")) Then LoadChannelConfig()
C_S=Application(SiteSN&"_ChannelConfig").documentElement.selectSingleNode("channel[@ks0=" & sChannelID & "]/@ks" & FieldID & "").text
if err then C_S=0:err.Clear
End Function
Public Function LoadClassConfig()
Application.Lock
Dim RS:Set Rs=conn.execute("select ID,FolderName,Folder,ClassPurview,FolderDomain,TemplateID,ClassBasicInfo,ClassDefineContent,TS From KS_Class Order by ClassID")
Set Application(SiteSN&"_class")=RecordsetToxml(rs,"class","classConfig")
Set Rs=Nothing
Application.unLock
End Function
Function C_C(ClassID,FieldID)
on error resume next
If not IsObject(Application(SiteSN&"_class")) Then LoadClassConfig()
C_C=Application(SiteSN&"_class").documentElement.selectSingleNode("class[@ks0=" & classID & "]/@ks" & FieldID & "").text
End Function
'**************************************************
'函数名：LoadSelectClass
'作 用：返回目录树。
'参 数：ChannelID-----返回频道目录树
'返回值：整棵树
'**************************************************
Public Function LoadSelectClass(ChannelID)
On Error resume next
Dim Node,K,SQL
If Not IsNumeric(ChannelID) Then Exit Function
If Not IsObject(Application(SiteSN&"_selectclass")) Then
Set Application(SiteSN&"_selectclass")=Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
Application(SiteSN&"_selectclass").appendChild( Application(SiteSN&"_selectclass").createElement("xml"))
Dim RSC:Set RSC=Conn.Execute("Select ChannelID From KS_Channel Where ChannelStatus=1 order by channelid")
Do While Not RSC.Eof
Dim ID,RS,TreeStr
Set RS=Conn.Execute("select ID,FolderName from KS_Class Where ChannelID=" & rsc(0) & " AND tj=1 Order BY FolderOrder ASC")
If Not RS.Eof Then
SQL=RS.GetRows(-1):RS.Close:Set RS = Nothing
For K=0 To Ubound(SQL,2)
ID=trim(SQL(0,K))
TreeStr = TreeStr & ""
TreeStr = TreeStr & ReturnSubList("TN='" & ID & "'")
Next
Set Node=Application(SiteSN&"_selectclass").documentElement.appendChild(Application(SiteSN&"_selectclass").createNode(1,"selectclass",""))
Node.attributes.setNamedItem(Application(SiteSN&"_selectclass").createNode(2,"channelid","")).text=rsc(0)
Node.text=TreeStr
TreeStr=""
End If
RSC.MoveNext
Loop
RSC.Close:Set RSC=Nothing
End If
LoadSelectClass=Application(SiteSN&"_selectclass").documentElement.selectSingleNode("selectclass[@channelid=" & ChannelID & "]").text
End Function
'**************************************************
'函数名：ReturnSubList
'作 用：查找并返子树数据。
'参 数：ParentID ----父节点ID
'返回值：子树
'**************************************************
Public Function ReturnSubList(Param)
Dim SubTypeList, RS, SpaceStr, k, Total, Num,ID,TJ,SQL,n
Set RS=Conn.Execute("Select ID,FolderName,TJ from KS_Class Where " & Param & " Order BY FolderOrder ASC")
Num = 0
If RS.Eof Then ReturnSubList="":RS.Close:Set RS=Nothing:Exit Function
SQL=RS.GetRows(-1):Total=Ubound(SQL,2)
For n=0 To Total
Num = Num + 1:SpaceStr = "":TJ = CInt(SQL(2,N))
For k = 1 To TJ - 1
If k = 1 And k <> TJ - 1 Then
SpaceStr = SpaceStr & " │"
ElseIf k = TJ - 1 Then
If Num = Total+1 Then
SpaceStr = SpaceStr & " └ "
Else
SpaceStr = SpaceStr & " ├ "
End If
Else
SpaceStr = SpaceStr & " │"
End If
Next
ID = Trim(SQL(0,N))
SubTypeList = SubTypeList & ""
SubTypeList = SubTypeList & ReturnSubList("TN='" & ID & "'")
Next
ReturnSubList = SubTypeList
End Function
Sub IsIPlock()
On Error Resume Next
If Setting(100)=0 Then Exit Sub
If session("KS_IPlock") = "" Then
session("KS_IPlock") = CheckIPlock(Setting(100), Setting(101), GetIP)
End If
If session("KS_IPlock") = True Then
Response.Write "对不起！您的IP（" &GetIP & "）被系统限定。您可以和站长联系。"
Response.End
End If
End Sub
Function EncodeIP(Sip)
Dim strIP:strIP = Split(Sip, ".")
If UBound(strIP) < 3 Then
EncodeIP = 0:Exit Function
End If
If IsNumeric(strIP(0)) = 0 Or IsNumeric(strIP(1)) = 0 Or IsNumeric(strIP(2)) = 0 Or IsNumeric(strIP(3)) = 0 Then
Sip = 0
Else
Sip = CInt(strIP(0)) * 256 * 256 * 256 + CInt(strIP(1)) * 256 * 256 + CInt(strIP(2)) * 256 + CInt(strIP(3)) - 1
End If
EncodeIP = Sip
End Function
Function CStrIP(ByVal anNewIP)
Dim lsResults ' Results To be returned
Dim lnTemp ' Temporary value being parsed
Dim lnIndex ' Position of number being parsed
For lnIndex = 3 To 0 Step-1
lnTemp = Int(anNewIP / (256 ^ lnIndex))
lsResults = lsResults & lnTemp & "."
anNewIP = anNewIP - (lnTemp * (256 ^ lnIndex))
Next
lsResults = Left(lsResults, Len(lsResults) - 1)
lsResults=Split(lsResults,".")
Dim IPStr,i:For I=0 To Ubound(lsResults)
if i=3 then
IPStr=IPStr & "." &lsResults(3)+1
elseif i=0 then
IPStr=lsResults(0)
else
IPStr=IPStr & "." & lsResults(i)
end if
Next
CStrIP = IPStr
End Function
'白名单的端点可以访问和黑名单的端点将不允许访问。
Function ChecKIPlock(ByVal sLockType, ByVal sLockList, ByVal sUserIP)
Dim IPlock, rsLockIP
Dim arrLockIPW, arrLockIPB, arrLockIPWCut, arrLockIPBCut
IPlock = False
ChecKIPlock = IPlock
Dim i, sKillIP
If sLockType = "" Or IsNull(sLockType) Then Exit Function
If sLockList = "" Or IsNull(sLockList) Then Exit Function
If sUserIP = "" Or IsNull(sUserIP) Then Exit Function
sUserIP = CDbl(EncodeIP(sUserIP))
rsLockIP = Split(sLockList, "|||")
If sLockType = 4 Then
arrLockIPB = Split(Trim(rsLockIP(1)), "$$$")
For i = 0 To UBound(arrLockIPB)
If arrLockIPB(i) <> "" Then
arrLockIPBCut = Split(Trim(arrLockIPB(i)), "----")
IPlock = True
If CDbl(arrLockIPBCut(0)) > sUserIP Or sUserIP > CDbl(arrLockIPBCut(1)) Then IPlock = False
If IPlock Then Exit For
End If
Next
If IPlock = True Then
arrLockIPW = Split(Trim(rsLockIP(0)), "$$$")
For i = 0 To UBound(arrLockIPW)
If arrLockIPW(i) <> "" Then
arrLockIPWCut = Split(Trim(arrLockIPW(i)), "----")
IPlock = True
If CDbl(arrLockIPWCut(0)) <= sUserIP And sUserIP <= CDbl(arrLockIPWCut(1)) Then IPlock = False
If IPlock Then Exit For
End If
Next
End If
Else
If sLockType = 1 Or sLockType = 3 Then
arrLockIPW = Split(Trim(rsLockIP(0)), "$$$")
For i = 0 To UBound(arrLockIPW)
If arrLockIPW(i) <> "" Then
arrLockIPWCut = Split(Trim(arrLockIPW(i)), "----")
IPlock = True
If CDbl(arrLockIPWCut(0)) <= sUserIP And sUserIP <= CDbl(arrLockIPWCut(1)) Then IPlock = False
If IPlock Then Exit For
End If
Next
End If
If IPlock = False And (sLockType = 2 Or sLockType = 3) Then
arrLockIPB = Split(Trim(rsLockIP(1)), "$$$")
For i = 0 To UBound(arrLockIPB)
If arrLockIPB(i) <> "" Then
arrLockIPBCut = Split(Trim(arrLockIPB(i)), "----")
IPlock = True
If CDbl(arrLockIPBCut(0)) > sUserIP Or sUserIP > CDbl(arrLockIPBCut(1)) Then IPlock = False
If IPlock Then Exit For
End If
Next
End If
End If
ChecKIPlock = IPlock
End Function
Public Function Conn()
On Error Resume Next
Dim ConnObj:Set ConnObj=Server.CreateObject("ADODB.Connection")
ConnObj.Open ConnStr
Set Conn = ConnObj
End Function
'采集数据库连接
Public Function ConnItem()
Dim ConnObj:Set ConnObj=Server.CreateObject("ADODB.Connection")
ConnObj.Open CollcetConnStr
Set ConnItem = ConnObj
End Function
'***************************************************************************************************************
'函数名：GetDomain
'作 用：获取URL,包括虚拟目录 如http://www.sykv.com/ 或 http://www.sykv.com/Sys/ 其中 Sys/为虚拟目录
'参 数： 无
'返回值：完整域名
'***************************************************************************************************************
Public Function GetDomain()
GetDomain = Trim(Setting(2) & Setting(3))
End Function
'**************************************************
'函数名：GetChannelDomain
'作 用：获取包含频道的完整Url
'参 数：ChannelID频道ID
'返回值：完整域名
'**************************************************
Public Function GetChannelDomain(ChannelID)
GetChannelDomain=C_S(ChannelID,8)
If Left(GetChannelDomain, 1) = "/" Then GetChannelDomain = Right(GetChannelDomain, Len(GetChannelDomain) - 1)
GetChannelDomain = GetDomain() & GetChannelDomain
End Function
'**************************************************
'函数名：GetAutoDoMain()
'作 用：取得当前服务器IP 如：http://127.0.0.1
'参 数：无
'**************************************************
Public Function GetAutoDomain()
Dim TempPath
If Request.ServerVariables("SERVER_PORT") = "80" Then
GetAutoDomain = Request.ServerVariables("SERVER_NAME")
Else
GetAutoDomain = Request.ServerVariables("SERVER_NAME") & ":" & Request.ServerVariables("SERVER_PORT")
End If
If Instr(UCASE(GetAutoDomain),"/W3SVC")<>0 Then
GetAutoDomain=Left(GetAutoDomain,Instr(GetAutoDomain,"/W3SVC"))
End If
GetAutoDomain = "http://" & GetAutoDomain
End Function
Function CutFixContent(ByVal str, ByVal start, ByVal last, ByVal n)
Dim strTemp
On Error Resume Next
If InStr(str, start) > 0 Then
Select Case n
Case 0 '左右都截取（都取前面）（去处关键字）
strTemp = Right(str, Len(str) - InStr(str, start) - Len(start) + 1)
strTemp = Left(strTemp, InStr(strTemp, last) - 1)
Case Else '左右都截取（都取前面）（保留关键字）
strTemp = Right(str, Len(str) - InStr(str, start) + 1)
strTemp = Left(strTemp, InStr(strTemp, last) + Len(last) - 1)
End Select
Else
strTemp = ""
End If
CutFixContent = strTemp
End Function
'*************************************************************************
'函数名：gotTopic
'作 用：截字符串，汉字一个算两个字符，英文算一个字符
'参 数：str ----原字符串
' strlen ----截取长度
'返回值：截取后的字符串
'*************************************************************************
Public Function GotTopic(ByVal Str, ByVal strlen)
If Str = "" OR IsNull(Str) Then GotTopic = "":Exit Function
If strlen=0 Then GotTopic=Str:Exit Function
Dim l, T, c, I, strTemp
Str = Replace(Replace(Replace(Replace(Str, " ", " "), """, Chr(34)), ">", ">"), "<", "<")
l = Len(Str)
T = 0
strTemp = Str
strlen = CLng(strlen)
For I = 1 To l
c = Abs(Asc(Mid(Str, I, 1)))
If c > 255 Then
T = T + 2
Else
T = T + 1
End If
If T >= strlen Then
strTemp = Left(Str, I)
Exit For
End If
Next
If strTemp <> Str Then strTemp = strTemp
GotTopic = Replace(Replace(Replace(Replace(strTemp, " ", " "), Chr(34), """), ">", ">"), "<", "<")
End Function
'**************************************************
'函数名：ListTitle
'作 用：取标题
'参 数：TitleStr 标题, TitleNum 取字符数
'返回值：将标题分解成两行
'**************************************************
Public Function ListTitle(TitleStr, TitleNum)
Dim LeftStr, RightStr
ListTitle = Trim(GotTopic(Trim(TitleStr), TitleNum))
If Len(ListTitle) > CInt(TitleNum / 2) Then
LeftStr = GotTopic(ListTitle, CInt(TitleNum / 2))
RightStr = Mid(ListTitle, Len(LeftStr) + 1)
ListTitle = LeftStr & " " & RightStr
End If
End Function
Function ListTitle1(TitleStr, TitleNum)
Dim ClsTitleStr, ClsTitleNum, I, J, ClsTempNum, k, ClsTitleStrResult, LeftStr, RightStr
ClsTitleNum = CInt(TitleNum)
ClsTempNum = Len(CStr(TitleStr))
If ClsTitleNum > ClsTempNum Then
ClsTitleNum = ClsTempNum
End If
ClsTitleStr = Left(CStr(TitleStr), ClsTitleNum)
Dim TempStr
For I = 1 To ClsTitleNum - 1
TempStr = TempStr & Mid(ClsTitleStr, I, 1) & " "
Next
TempStr = TempStr & Right(ClsTitleStr, 1)
ListTitle1 = TempStr
End Function
'**************************************************
'函数名：GetIP
'作 用：取得正确的IP
'返回值：IP字符串
'**************************************************
Public Function GetIP()
Dim strIPAddr
If Request.ServerVariables("HTTP_X_FORWARDED_FOR") = "" Or InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), "unknown") > 0 Then
strIPAddr = Request.ServerVariables("REMOTE_ADDR")
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",") > 0 Then
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ",")-1)
ElseIf InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";") > 0 Then
strIPAddr = Mid(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), 1, InStr(Request.ServerVariables("HTTP_X_FORWARDED_FOR"), ";")-1)
Else
strIPAddr = Request.ServerVariables("HTTP_X_FORWARDED_FOR")
End If
getIP = Checkstr(Trim(Mid(strIPAddr, 1, 30)))
End Function
Public Function Checkstr(Str)
If Isnull(Str) Then
CheckStr = ""
Exit Function
End If
Str = Replace(Str,Chr(0),"")
CheckStr = Replace(Str,"'","''")
End Function
'================================================
'函数名：URLDecode
'作 用：URL解码
'================================================
Function URLDecode(ByVal urlcode)
Dim start,final,length,char,i,butf8,pass
Dim leftstr,rightstr,finalstr
Dim b0,b1,bx,blength,position,u,utf8
On Error Resume Next
b0 = Array(192,224,240,248,252,254)
urlcode = Replace(urlcode,"+"," ")
pass = 0
utf8 = -1
length = Len(urlcode) : start = InStr(urlcode,"%") : final = InStrRev(urlcode,"%")
If start = 0 Or length < 3 Then URLDecode = urlcode : Exit Function
leftstr = Left(urlcode,start - 1) : rightstr = Right(urlcode,length - 2 - final)
For i = start To final
char = Mid(urlcode,i,1)
If char = "%" Then
bx = URLDecode_Hex(Mid(urlcode,i + 1,2))
If bx > 31 And bx < 128 Then
i = i + 2
finalstr = finalstr & ChrW(bx)
ElseIf bx > 127 Then
i = i + 2
If utf8 < 0 Then
butf8 = 1 : blength = -1 : b1 = bx
For position = 4 To 0 Step -1
If b1 >= b0(position) And b1 < b0(position + 1) Then
blength = position
Exit For
End If
Next
If blength > -1 Then
For position = 0 To blength
b1 = URLDecode_Hex(Mid(urlcode,i + position * 3 + 2,2))
If b1 < 128 Or b1 > 191 Then butf8 = 0 : Exit For
Next
Else
butf8 = 0
End If
If butf8 = 1 And blength = 0 Then butf8 = -2
If butf8 > -1 And utf8 = -2 Then i = start - 1 : finalstr = "" : pass = 1
utf8 = butf8
End If
If pass = 0 Then
If utf8 = 1 Then
b1 = bx : u = 0 : blength = -1
For position = 4 To 0 Step -1
If b1 >= b0(position) And b1 < b0(position + 1) Then
blength = position
b1 = (b1 xOr b0(position)) * 64 ^ (position + 1)
Exit For
End If
Next
If blength > -1 Then
For position = 0 To blength
bx = URLDecode_Hex(Mid(urlcode,i + 2,2)) : i = i + 3
If bx < 128 Or bx > 191 Then u = 0 : Exit For
u = u + (bx And 63) * 64 ^ (blength - position)
Next
If u > 0 Then finalstr = finalstr & ChrW(b1 + u)
End If
Else
b1 = bx * &h100 : u = 0
bx = URLDecode_Hex(Mid(urlcode,i + 2,2))
If bx > 0 Then
u = b1 + bx
i = i + 3
Else
If Left(urlcode,1) = "%" Then
u = b1 + Asc(Mid(urlcode,i + 3,1))
i = i + 2
Else
u = b1 + Asc(Mid(urlcode,i + 1,1))
i = i + 1
End If
End If
finalstr = finalstr & Chr(u)
End If
Else
pass = 0
End If
End If
Else
finalstr = finalstr & char
End If
Next
URLDecode = leftstr & finalstr & rightstr
End Function
Function URLDecode_Hex(ByVal h)
On Error Resume Next
h = "&h" & Trim(h) : URLDecode_Hex = -1
If Len(h) <> 4 Then Exit Function
If isNumeric(h) Then URLDecode_Hex = cInt(h)
End Function
'**************************************************
'函数名：R
'作 用：过滤非法的SQL字符
'参 数：strChar-----要过滤的字符
'返回值：过滤后的字符
'**************************************************
Public Function R(strChar)
If strChar = "" Or IsNull(strChar) Then R = "":Exit Function
Dim strBadChar, arrBadChar, tempChar, I
'strBadChar = "$,#,',%,^,&,?,(,),<,>,[,],{,},/,\,;,:," & Chr(34) & "," & Chr(0) & ""
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, "@@", "@")
R = tempChar
End Function
Function FilterIDs(byval strIDs)
Dim arrIDs,i,strReturn
strIDs=Trim(strIDs)
If Len(strIDs)=0 Then Exit Function
arrIDs=Split(strIDs,",")
For i=0 To Ubound(arrIds)
If ChkClng(Trim(arrIDs(i)))<>0 Then
strReturn=strReturn & "," & Int(arrIDs(i))
End If
Next
If Left(strReturn,1)="," Then strReturn=Right(strReturn,Len(strReturn)-1)
FilterIDs=strReturn
End Function
'********************************************
'函数名：IsValidEmail
'作 用：检查Email地址合法性
'参 数：email ----要检查的Email地址
'返回值：True ----Email地址合法
' False ----Email地址不合法
'********************************************
Public Function IsValidEmail(Email)
Dim names, name, I, c
IsValidEmail = True
names = Split(Email, "@")
If UBound(names) <> 1 Then IsValidEmail = False: Exit Function
For Each name In names
If Len(name) <= 0 Then IsValidEmail = False:Exit Function
For I = 1 To Len(name)
c = LCase(Mid(name, I, 1))
If InStr("abcdefghijklmnopqrstuvwxyz_-.", c) <= 0 And Not IsNumeric(c) Then IsValidEmail = False:Exit Function
Next
If Left(name, 1) = "." Or Right(name, 1) = "." Then IsValidEmail = False:Exit Function
Next
If InStr(names(1), ".") <= 0 Then IsValidEmail = False:Exit Function
I = Len(names(1)) - InStrRev(names(1), ".")
If I <> 2 And I <> 3 Then IsValidEmail = False:Exit Function
If InStr(Email, "..") > 0 Then IsValidEmail = False
End Function
'**************************************************
'函数名：strLength
'作 用：求字符串长度。汉字算两个字符，英文算一个字符。
'参 数：str ----要求长度的字符串
'返回值：字符串长度
'**************************************************
Public Function strLength(Str)
On Error Resume Next
Dim WINNT_CHINESE:WINNT_CHINESE = (Len("中国") = 2)
If WINNT_CHINESE Then
Dim l, T, c,I
l = Len(Str)
T = l
For I = 1 To l
c = Asc(Mid(Str, I, 1))
If c < 0 Then c = c + 65536
If c > 255 Then
T = T + 1
End If
Next
strLength = T
Else
strLength = Len(Str)
End If
If Err.Number <> 0 Then Err.Clear
End Function
'**************************************************
'函数名: GetFolderPath
'功 能:取得目录Url
'参 数: FolderID目录的ID
'**************************************************
Public Function GetFolderPath(FolderID)
on error resume next
If Not IsObject(Application(SiteSN&"_classpath")) Then
Dim Folder,ClassPurview,ChannelFsoHtmlTF,Node,K,SQL,RS
Set Application(SiteSN&"_classpath")=Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
Application(SiteSN&"_classpath").appendChild( Application(SiteSN&"_classpath").createElement("xml"))
Set RS=Server.CreateObject("ADODB.RECORDSET")
RS.Open "Select C.ClassID,C.ChannelID,TN,Folder,FolderDomain,ClassPurview,FsoHtmlTF,ModelEName,C.ID From KS_Class C inner join KS_Channel M On C.ChannelID=M.ChannelID Order BY FolderOrder", Conn, 1, 1
If RS.Eof And RS.Bof Then RS.Close:Set RS=Nothing:Exit Function
SQL=RS.GetRows(-1):RS.Close:Set RS=Nothing
For K=0 To Ubound(SQL,2)
ClassPurview=SQL(5,K)
ChannelFsoHtmlTF=SQL(6,K)
If Trim(SQL(4,K)) <> "" And SQL(2,K) = "0" Then
IF ClassPurview=2 Or ChannelFsoHtmlTF=0 Then
GetFolderPath= GetChannelNoHtmlUrl(SQL(7,K),SQL(0,K))
Else
GetFolderPath=Trim(SQL(4,K))
End If
ElseIf Trim(SQL(4,K)) <> "" Then
Folder = Trim(SQL(3,K))
Folder = Right(Mid(Folder, InStr(Folder, "/")), Len(Mid(Folder, InStr(Folder, "/"))) - 1)
IF ClassPurview=2 Or ChannelFsoHtmlTF=0 Then
GetFolderPath= Trim(SQL(4,K)) & GetChannelNoHtmlUrl(SQL(7,K),SQL(0,K))
Else
GetFolderPath= Trim(SQL(4,K)) & Folder
End If
Else
IF ClassPurview=2 Or ChannelFsoHtmlTF=0 Then
GetFolderPath= GetChannelNoHtmlUrl(SQL(7,K),SQL(0,K))
Else
GetFolderPath= GetChannelDomain(SQL(1,K)) & SQL(3,K)
End If
End If
Set Node=Application(SiteSN&"_classpath").documentElement.appendChild(Application(SiteSN&"_classpath").createNode(1,"classpath",""))
Node.attributes.setNamedItem(Application(SiteSN&"_classpath").createNode(2,"classid","")).text=SQL(8,K)
Node.text=GetFolderPath
Next
End If
GetFolderPath=Application(SiteSN&"_classpath").documentElement.selectSingleNode("classpath[@classid=" & FolderID & "]").text
End Function
'************************************************************************
'函数名: GetClassNP
'功 能: 取得目录名称并加上链接
'参 数: FolderID目录的ID
'*************************************************************************
Function GetClassNP(FolderID)
on error resume next
If Not IsObject(Application(SiteSN&"_classnamepath")) Then
Dim Folder,ClassPurview,ChannelFsoHtmlTF,Node,K,SQL,RS
Dim FolderCss:FolderCss=""
Dim OpenTypeStr:OpenTypeStr=" target=""_blank"""
Set Application(SiteSN&"_classnamepath")=Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
Application(SiteSN&"_classnamepath").appendChild( Application(SiteSN&"_classnamepath").createElement("xml"))
Set RS=Server.CreateObject("ADODB.RECORDSET")
RS.Open "Select C.ClassID,C.ChannelID,FolderName,Folder,FolderDomain,TN,ClassPurview,FolderFsoIndex,FsoHtmlTF,ModelEname,C.ID From KS_Class C inner join KS_Channel M On C.ChannelID=M.ChannelID Order BY FolderOrder", Conn, 1, 1
If RS.Eof And RS.Bof Then RS.Close:Set RS=Nothing:Exit Function
SQL=RS.GetRows(-1):RS.Close:Set RS=Nothing
For K=0 To Ubound(SQL,2)
ClassPurview=SQL(6,K)
ChannelFsoHtmlTF=SQL(8,K)
If Trim(SQL(4,K)) <> "" And SQL(5,K) = "0" Then '判断根目录是否有绑定二级域名
IF ClassPurview=2 Or ChannelFsoHtmlTF=0 Then
GetClassNP = ""
Else
GetClassNP = ""
End If
ElseIf Trim(SQL(4,K)) <> "" Then
Folder = Trim(SQL(3,K))
Folder = Right(Mid(Folder, InStr(Folder, "/")), Len(Mid(Folder, InStr(Folder, "/"))) - 1)
IF ClassPurview=2 Or ChannelFsoHtmlTF=0 Then
GetClassNP = ""
Else
GetClassNP = ""
End If
Else
IF ClassPurview=2 Or ChannelFsoHtmlTF=0 Then
GetClassNP = ""
Else
GetClassNP = ""
End If
End If
GetClassNP = GetClassNP & Trim(SQL(2,K)) & ""
Set Node=Application(SiteSN&"_classnamepath").documentElement.appendChild(Application(SiteSN&"_classnamepath").createNode(1,"classnamepath",""))
Node.attributes.setNamedItem(Application(SiteSN&"_classnamepath").createNode(2,"classid","")).text=SQL(10,K)
Node.text=GetClassNP
Next
End If
GetClassNP=Application(SiteSN&"_classnamepath").documentElement.selectSingleNode("classnamepath[@classid=" & FolderID & "]").text
End Function
'----------------------------------------------------------------------------------------------------------------------
'函数名: GetSpecialPath
'功 能: 取得专题目录Url
'参 数: SpecialrRS
'-----------------------------------------------------------------------------------------------------------------------
Public Function GetSpecialPath(SpecialID,SpecialEname,FsoSpecialIndex,ChannelID)
Dim SpecialDir:SpecialDir = Setting(95)
If Left(SpecialDir, 1) = "/" Or Left(SpecialDir, 1) = "\" Then SpecialDir = Right(SpecialDir, Len(SpecialDir) - 1)
If C_S(ChannelID,7)=0 Then
GetSpecialPath=GetDomain & C_S(ChannelID,10) & "/Special.asp?ID=" & SpecialID
Else
GetSpecialPath = GetDomain & SpecialDir & SpecialEname & "/" & FsoSpecialIndex
End iF
End Function
'----------------------------------------------------------------------------------------------------------------------
'函数名: GetFolderSpecialPath
'功 能: 取得栏目专题汇总Url
'参 数: FolderID目录的ID,FullPathFlag是否完整路径(取栏目首页与否),包括专题首页
'-----------------------------------------------------------------------------------------------------------------------
Function GetFolderSpecialPath(FolderID, FullPathFlag)
Dim RS:Set RS=Server.CreateObject("ADODB.RECORDSET")
Dim SpecialDir:SpecialDir =Setting(95)
If Left(SpecialDir, 1) = "/" Or Left(SpecialDir, 1) = "\" Then SpecialDir = Right(SpecialDir, Len(SpecialDir) - 1)
RS.Open "Select Folder,FolderFsoIndex,ChannelID,id From KS_Class Where ID='" & FolderID & "'", Conn, 1, 1
If Not RS.EOF Then
If Conn.Execute("Select FsoHtmlTF From KS_Channel Where ChannelID=" & RS("ChannelID"))(0)=0 Then
GetFolderSpecialPath = GetDomain &"SpecialList.asp?ClassID="&RS(3)
Else
If FullPathFlag = True Then
GetFolderSpecialPath = GetDomain & SpecialDir & RS(0) & RS(1)
Else
GetFolderSpecialPath = GetDomain & SpecialDir & RS(0)
End If
End IF
RS.Close:Set RS = Nothing
Else
RS.Close:Set RS = Nothing:GetFolderSpecialPath = ""
End If
End Function
'取得栏目的链接URL
Public Function GetChannelNoHtmlUrl(ModelEname,ClassID)
GetChannelNoHtmlUrl=GetDomain & ModelEname & "/ShowClass.asp?ID=" & ClassID
End Function
'***************************************************************************
'函数名: GetInfoUrl
'功 能: 取得每篇文章、图片等的Url链接
'参 数: RSObj--信息的recordset对象
'调用该函数前先初始化
'****************************************************************************
Public Function GetInfoUrl(ByVal ChannelID,ByVal Tid,ByVal InfoID,ByVal Fname,ByVal ReadPoint,ByVal InfoPurview,ByVal Changes)
On error resume next
IF Not Isnumeric(ChannelID) Then GetInfoUrl="#":Exit Function
Dim ClassPurview:ClassPurview=C_C(Tid,3)
Select Case C_S(ChannelID,6)
Case 1
'当需要点数阅读或是指定的会员组才能查看或是继承栏目且该栏目的权限为半开放或认证栏目时，不能生成静态
If Changes=1 Then
GetInfoUrl=Fname
ElseIf ReadPoint>0 Or C_S(ChannelID,7)=0 Or InfoPurview=2 Or (InfoPurview=0 And (ClassPurview=1 Or ClassPurview=2)) Then
GetInfoUrl=GetDomain & C_S(ChannelID,10) & "/ShowInfo.asp?ID=" &InfoID
Else
GetInfoUrl=GetFolderPath(Tid) & Fname
End If
Case 2
'当需要点数阅读或是指定的会员组才能查看或是继承栏目且该栏目的权限为半开放或认证栏目时，不能生成静态
If ReadPoint>0 Or C_S(ChannelID,7)=0 Or InfoPurview=2 Or (InfoPurview=0 And (ClassPurview=1 Or ClassPurview=2)) Then
GetInfoUrl=GetDomain & C_S(ChannelID,10) & "/ShowInfo.asp?ID=" &InfoID
Else
GetInfoUrl=GetFolderPath(Tid) & Fname
End If
Case 3
'当需要点数阅读或是指定的会员组才能查看或是继承栏目且该栏目的权限为半开放或认证栏目时，不能生成静态
If C_S(ChannelID,7)=0 Then
GetInfoUrl=GetDomain & C_S(ChannelID,10) & "/ShowInfo.asp?ID=" &InfoID
Else
GetInfoUrl=GetFolderPath(Tid) & Fname
End If
Case 4
'当需要点数阅读或是指定的会员组才能查看或是继承栏目且该栏目的权限为半开放或认证栏目时，不能生成静态
If ReadPoint>0 Or C_S(ChannelID,7)=0 Or InfoPurview=2 Or (InfoPurview=0 And (ClassPurview=1 Or ClassPurview=2)) Then
GetInfoUrl=GetDomain & C_S(ChannelID,10) & "/ShowInfo.asp?ID=" &InfoID
Else
GetInfoUrl=GetFolderPath(Tid) & Fname
End If
Case 5
'判断是否生成
If C_S(ChannelID,7)=0 Then
GetInfoUrl=GetDomain & C_S(ChannelID,10) & "/ShowInfo.asp?ID=" &InfoID
Else
GetInfoUrl=GetFolderPath(Tid) & Fname
End If
Case 7
'当需要点数阅读或是指定的会员组才能查看或是继承栏目且该栏目的权限为半开放或认证栏目时，不能生成静态
If ReadPoint>0 Or C_S(ChannelID,7)=0 Or InfoPurview=2 Or (InfoPurview=0 And (ClassPurview=1 Or ClassPurview=2)) Then
GetInfoUrl=GetDomain & C_S(ChannelID,10) & "/ShowInfo.asp?ID=" &InfoID
Else
GetInfoUrl=GetFolderPath(Tid) & Fname
End If
Case 8
If C_S(ChannelID,7)=0 Then
GetInfoUrl=GetDomain & C_S(ChannelID,10) & "/ShowInfo.asp?ID=" &InfoID
Else
GetInfoUrl=GetFolderPath(Tid) & Fname
End If
End Select
End Function
'取消HTML
Public Function LoseHtml(ContentStr)
On Error Resume Next
Dim TempLoseStr, regEx
If ContentStr="" Or ContentStr=Null Then Exit Function
TempLoseStr = CStr(ContentStr)
Set regEx = New RegExp
regEx.Pattern = "<\/*[^<>]*>"
regEx.IgnoreCase = True
regEx.Global = True
TempLoseStr = regEx.Replace(TempLoseStr, "")
LoseHtml = TempLoseStr
End Function
'---------------------------------------------------------------------------------------------------
'函数名: G_O_T_S
'功 能:取得打开类型
'参 数: OpenType 取true时,新窗口打开
'--------------------------------------------------------------------------------------------
Function G_O_T_S(OpenType)
If OpenType = "" Or OpenType = False Then
G_O_T_S = ""
ElseIf OpenType = True Then
G_O_T_S = " target=""_blank"""
Else
G_O_T_S = " target=""" & OpenType & """"
End If
End Function
'--------------------------------------------------------------------------------------------------
'函数名: GetCss
'功 能:取得样式
'参 数: CssName样式名称
'--------------------------------------------------------------------------------------------
Function GetCss(CssName)
If CssName = "" Then GetCss = "" Else GetCss = " class=""" & CssName & """"
End Function
'取得CSS的ID
Function GetCssID(ID)
If ID="" Then GetCssID="" Else GetCssID=" id=""" & ID & """"
End Function
'-------------------------------------------------------------------------------------------------------------
'函数名: G_R_H
'功 能:取得单元格行距
'参 数: RowHeight 默认行距
'-----------------------------------------------------------------------------------------------------------
Function G_R_H(RowHeight)
If IsNumeric(RowHeight) Then G_R_H = RowHeight Else G_R_H = 20
End Function
'----------------------------------------------------------------------------------------------------------------------------
'函数名:GetMenuBg
'功 能:取得表头背景
'参 数: MenuBGType 类型 1 取背景图片 0 取背景颜色, MenuBg 背景颜色的值 如#CCCCCC 或 /Upfies/TITLE_BG.GIF ,ColNumber列数
'---------------------------------------------------------------------------------------------------------------------------
Function GetMenuBg(MenuBgType, MenuBg, ColNumber)
If MenuBgType = 0 Then
If MenuBg = "" Then GetMenuBg = "" Else GetMenuBg = MenuBg
Else
If MenuBg = "" Then
GetMenuBg = "url(" & GetDomain & "Images/Default/MenuBg" & ColNumber & ".Gif)"
Else
If Left(MenuBg, 1) = "/" Or Left(MenuBg, 1) = "\" Then MenuBg = Right(MenuBg, Len(MenuBg) - 1)
If LCase(Left(MenuBg, 4)) = "http" Then MenuBg = MenuBg Else MenuBg = GetDomain & MenuBg
GetMenuBg = "url(" & MenuBg & ")"
End If
End If
End Function
'----------------------------------------------------------------------------------------------------------------------------
'函数名:GetPhotoBorder
'功 能: 取得图片的边框
'参 数: BorderType 类型 1 取透明图片边框 0 取颜色边框, Border 背景颜色的值 如#CCCCCC 或 /Upfies/TITLE_BG.GIF ,ColNumber列数
'----------------------------------------------------------------------------------------------------------------------------
Function GetPhotoBorder(LinkPhotoStr, BorderType, Border)
Dim bgColorStr
If Trim(Border) = "" Then
GetPhotoBorder = LinkPhotoStr:Exit Function
Else
If BorderType = 0 Then
bgColorStr = " bgcolor=""" & Border & """"
GetPhotoBorder = "
" & vbCrLf
GetPhotoBorder = GetPhotoBorder & "
" & vbCrLf
GetPhotoBorder = GetPhotoBorder & "
" & LinkPhotoStr & "
" & vbCrLf
GetPhotoBorder = GetPhotoBorder & "
" & vbCrLf
GetPhotoBorder = GetPhotoBorder & "
" & vbCrLf
Exit Function
Else
If Left(Border, 1) = "/" Or Left(Border, 1) = "\" Then Border = Right(Border, Len(Border) - 1)
If LCase(Left(Border, 4)) = "http" Then
Border = Border
Else
Border = GetDomain & Border
End If
bgColorStr = " style=""background:url(" & Border & ") #FFF no-repeat;"""
GetPhotoBorder = "
" & vbCrLf
GetPhotoBorder = GetPhotoBorder & "
" & vbCrLf
GetPhotoBorder = GetPhotoBorder & "
" & LinkPhotoStr & "
" & vbCrLf
GetPhotoBorder = GetPhotoBorder & "
" & vbCrLf
GetPhotoBorder = GetPhotoBorder & "
" & vbCrLf
End If
End If
End Function
'--------------------------------------------------------------------------------------------------------------------
'函数名: GetNavi
'功 能: 取得导航值
'参 数: NaviType 导航类型, NaviStr导航值
'---------------------------------------------------------------------------------------------------------------
Function GetNavi(NaviType, NaviStr)
If NaviType = "0" Then
If NaviStr = "" Then GetNavi = "" Else GetNavi = NaviStr
ElseIf NaviType = "1" Then
If NaviStr <> "" Then GetNavi = ""
Else
GetNavi = ""
End If
End Function
'---------------------------------------------------------------
'函数名:GetDateStr
'作用：取日期的样式
'参数：AddDate,DateRule,DateAlign,DateCssStr,ByRef ColSpanNum
'---------------------------------------------------------------
Function GetDateStr(AddDate,DateRule,DateAlign,DateCssStr,ByVal ColNumber,ByRef ColSpanNum)
If CStr(DateRule) <> "0" And CStr("DateRule") <> "" Then
Dim NowDate,NowFormatStr
NowDate=Now
If (Year(NowDate) & Month(NowDate) & Day(NowDate)) = (Year(AddDate) & Month(AddDate) & Day(AddDate)) Then
NowFormatStr=" style=""color:red"""
Else
NowFormatStr=""
End If
If Lcase(DateAlign)="left" Then
GetDateStr=" " & DateFormat(AddDate, DateRule) & ""
ColSpanNum = 1
Else
GetDateStr="
" & DateFormat(AddDate, DateRule) & ""
ColSpanNum = 2
End If
Else
GetDateStr="":ColSpanNum = 1
End If
If ColNumber>=2 Then ColSpanNum = ColNumber
End Function
'取得日期样式(div+css)
Function GetDCDateStr(AddDate,DateRule,DateCssStr)
If CStr(DateRule) <> "0" And CStr("DateRule") <> "" Then
Dim NowDate,NowFormatStr
NowDate=Now
If (Year(NowDate) & Month(NowDate) & Day(NowDate)) = (Year(AddDate) & Month(AddDate) & Day(AddDate)) Then
NowFormatStr=" style=""color:red"""
Else
NowFormatStr=""
End If
GetDCDateStr=" " & DateFormat(AddDate, DateRule) & ""
Else
GetDCDateStr=""
End If
End Function '----------------------------------------------------------------------------------------------------------------------------
'函数名:DateFormat
'功 能:日期格式函数
'参 数: DateStr日期, Types转换类型 '----------------------------------------------------------------------------------------------------------------------------
Function DateFormat(DateStr, Types)
Dim DateString
If IsDate(DateStr) = False Then
DateFormat = "":Exit Function
End If
Select Case CStr(Types)
Case "0"
DateFormat = ""
Exit Function
Case 1,21,41
DateString=Year(DateStr) & "-" & Right("0" & Month(DateStr), 2) & "-" & Right("0" & Day(DateStr), 2)
if Types=21 then
DateString = "(" & DateString &")"
elseIf Types=41 then
DateString = "[" & DateString &"]"
end if
Case 2,22,42
DateString=Year(DateStr) & "." & Right("0" & Month(DateStr), 2) & "." & Right("0" & Day(DateStr), 2)
if Types=22 then
DateString = "(" & DateString &")"
elseIf Types=42 then
DateString = "[" & DateString &"]"
end if
Case 3,23,43
DateString=Year(DateStr) & "/" & Right("0" & Month(DateStr), 2) & "/" & Right("0" & Day(DateStr), 2)
if Types=23 then
DateString = "(" & DateString &")"
elseIf Types=43 then
DateString = "[" & DateString &"]"
end if
Case 4,24,44
DateString=Right("0" & Month(DateStr), 2) & "/" & Right("0" & Day(DateStr), 2) & "/" & Year(DateStr)
if Types=24 then
DateString = "(" & DateString &")"
elseIf Types=44 then
DateString = "[" & DateString &"]"
end if
Case 5,25,45
DateString = Year(DateStr) & "年" & Right("0" & Month(DateStr), 2) & "月"
if Types=25 then
DateString = "(" & DateString &")"
elseIf Types=45 then
DateString = "[" & DateString &"]"
end if
Case 6,26,46
DateString = Year(DateStr) & "年" & Right("0" & Month(DateStr), 2) & "月" & Right("0" & Day(DateStr), 2) & "日"
if Types=26 then
DateString = "(" & DateString &")"
elseIf Types=46 then
DateString = "[" & DateString &"]"
end if
Case 7,27,47
DateString = Right("0" & Month(DateStr), 2) & "." & Right("0" & Day(DateStr), 2) & "." & Year(DateStr)
if Types=27 then
DateString = "(" & DateString &")"
elseIf Types=47 then
DateString = "[" & DateString &"]"
end if
Case 8,28,48
DateString = Right("0" & Month(DateStr), 2) & "-" & Right("0" & Day(DateStr), 2) & "-" & Year(DateStr)
if Types=28 then
DateString = "(" & DateString &")"
elseIf Types=48 then
DateString = "[" & DateString &"]"
end if
Case 9,29,49
DateString = Right("0" & Month(DateStr), 2) & "/" & Right("0" & Day(DateStr), 2)
if Types=29 then
DateString = "(" & DateString &")"
elseIf Types=49 then
DateString = "[" & DateString &"]"
end if
Case 10,30,50
DateString = Right("0" & Month(DateStr), 2) & "." & Right("0" & Day(DateStr), 2)
if Types=30 then
DateString = "(" & DateString &")"
elseIf Types=50 then
DateString = "[" & DateString &"]"
end if
Case 11,31,51
DateString = Right("0" & Month(DateStr), 2) & "月" & Right("0" & Day(DateStr), 2) & "日"
if Types=31 then
DateString = "(" & DateString &")"
elseIf Types=51 then
DateString = "[" & DateString &"]"
end if
Case 12,32,52
DateString = Right("0" & Day(DateStr), 2) & "日" & Right("0" & Hour(DateStr), 2) & "时"
if Types=32 then
DateString = "(" & DateString &")"
elseIf Types=52 then
DateString = "[" & DateString &"]"
end if
Case 13,33,53
DateString = Right("0" & Day(DateStr), 2) & "日" & Right("0" & Hour(DateStr), 2) & "点"
if Types=33 then
DateString = "(" & DateString &")"
elseIf Types=53 then
DateString = "[" & DateString &"]"
end if
Case 14,34,54
DateString = Right("0" & Hour(DateStr), 2) & "时" & Minute(DateStr) & "分"
if Types=34 then
DateString = "(" & DateString &")"
elseIf Types=54 then
DateString = "[" & DateString &"]"
end if
Case 15,35,55
DateString = Right("0" & Hour(DateStr), 2) & ":" & Right("0" & Minute(DateStr), 2)
if Types=35 then
DateString = "(" & DateString &")"
elseIf Types=55 then
DateString = "[" & DateString &"]"
end if
Case 16,36,56
DateString = Right("0" & Month(DateStr), 2) & "-" & Right("0" & Day(DateStr), 2)
if Types=36 then
DateString = "(" & DateString &")"
elseIf Types=56 then
DateString = "[" & DateString &"]"
end if
Case 17,37,57
DateString = Right("0" & Month(DateStr), 2) & "/" & Right("0" & Day(DateStr), 2) &" " &Right("0" & Hour(DateStr), 2)&":"&Right("0" & Minute(DateStr), 2)
if Types=37 then
DateString = "(" & DateString &")"
elseIf Types=57 then
DateString = "[" & DateString &"]"
end if
Case Else
DateString = DateStr
End Select
DateFormat = DateString
End Function
'----------------------------------------------------------------------------------------------------------------------------
'函数名:GetOrigin
'功 能:取得文章来源并附加上链接
'参 数: OriginName名称
'返回值: 形如 新华网
'----------------------------------------------------------------------------------------------------------------------------
Function GetOrigin(OriginName)
Dim RS: Set RS=Server.CreateObject("ADODB.Recordset")
RS.Open "select OriginName,HomePage From KS_Origin Where OriginName='" & Trim(OriginName) & "'", Conn, 1, 1
If RS.EOF Then
GetOrigin = OriginName
Else
If RS("HomePage") <> "" And UCase(Trim(RS("HomePage"))) <> "HTTP://" Then
GetOrigin = "" & OriginName & ""
Else
GetOrigin = OriginName
End If
End If
RS.Close:Set RS = Nothing
End Function
'----------------------------------------------------------------------------------------------------------------------------
'函数名:GetMoreLink
'功 能:取得更多链接
'参 数: ColNum列数, RowHeight行距, MoreLinkType链接类型, LinkUrl链接地址, OpenTypeStr是否新窗口打开
'----------------------------------------------------------------------------------------------------------------------------
Function GetMoreLink(PrintType,ColNum, RowHeight, MoreLinkType, LinkNameStr, LinkUrl, OpenTypeStr)
If LinkNameStr = "" Then GetMoreLink = "":Exit Function
If PrintType=2 Then
If MoreLinkType = "0" Then
GetMoreLink = "
"
ElseIf CStr(MoreLinkType) = "1" Then
GetMoreLink = "
"
Else
GetMoreLink = ""
End If
End If
End Function
'----------------------------------------------------------------------------------------------------------------------------
'函数名: GetSplitPic
'功 能:取得分隔图片
'参 数: ColSpanNum 列数, SplitPic 图片SRC '-------------------------------------------------------------------------------------------------------------------------------
Function GetSplitPic(SplitPic, ColSpanNum)
Dim ColStr
If SplitPic = "" Then
GetSplitPic = ""
Else
If ColSpanNum>=2 Then ColStr=" colspan=""" & ColSpanNum & """"
GetSplitPic = "
" & vbcrlf
End If
End Function
'-------------------------------------------------------------------------------------------------------------------
'函数名:GetFolderTid
'功 能:取得子目录的ID集合
'参 数: FolderID父目录ID
'返回值: 形如 1255555,111111,4444的ID集合
'---------------------------------------------------------------------------------------------------------
Function GetFolderTid(FolderID)
Dim I,Tid,SQL
Dim RS:Set RS=Conn.Execute("Select ID From KS_Class Where DelTF=0 AND TS LIKE '%" & FolderID & "%'")
If RS.EOF Then GetFolderTid="'0'":RS.Close:Set RS=Nothing:Exit Function
SQL=RS.GetRows(-1):RS.Close:Set RS = Nothing
For I=0 To Ubound(SQL,2)
Tid = Tid & "'" & Trim(SQL(0,I)) & "',"
Next
Tid = Left(Trim(Tid), Len(Trim(Tid)) - 1) '去掉最后一个逗号
GetFolderTid = Tid
End Function
'取得专题查询参数,应用于Sql条件
Function GetSpecialPara(SpecialID)
If SpecialID = "-1" Then
If Application(SiteSN & "RefreshType") = "Special" Then
If DataBaseType=1 Then
GetSpecialPara = " charindex('" & Application(SiteSN & "CurrSpecialID") &"',SpecialID)>0"
Else
GetSpecialPara = " instr(SpecialID,'"& Application(SiteSN & "CurrSpecialID") &"')>0"
End If
Else
GetSpecialPara = " 1=1"
End If
ElseIf (SpecialID = "" Or SpecialID = "0") And (Application(SiteSN & "RefreshType") <> "Special") Then
GetSpecialPara = " 1=1"
Else
GetSpecialPara = " instr(SpecialID,'"& SpecialID &"')>0"
End If
End Function
'**************************************************
'函数名：ReturnChannelAllowUpFilesTF
'作 用：返回频道的是否允许上传文件
'参 数：ChannelID--频道ID
'**************************************************
Public Function ReturnChannelAllowUpFilesTF(ChannelID)
If ChannelID = "" Or Not IsNumeric(ChannelID) Then ChannelID = 0
Dim CRS:Set CRS=Server.CreateObject("ADODB.RECORDSET")
CRS.Open "Select UpFilesTF From KS_Channel Where ChannelID=" & ChannelID, Conn, 1, 1
If CInt(ChannelID) = 0 Or (CRS.EOF And CRS.BOF) Then '默认允许上传文件
ReturnChannelAllowUpFilesTF = True
Else
If CRS(0) = 1 Then ReturnChannelAllowUpFilesTF = True Else ReturnChannelAllowUpFilesTF = False
End If
CRS.Close:Set CRS = Nothing
End Function
'**************************************************
'函数名：ReturnChannelUpFilesDir
'作 用：返回频道后台的上传目录
'参 数：ChannelID--频道ID
'返回值：目录字符串
'**************************************************
Public Function ReturnChannelUpFilesDir(ChannelID)
If ChannelID = "" Or Not IsNumeric(ChannelID) Then
ReturnChannelUpFilesDir = Setting(91)
Exit Function
End If
ReturnChannelUpFilesDir = replace(Setting(3) & C_S(ChannelID,24),"//","/")
ReturnChannelUpFilesDir = Left(ReturnChannelUpFilesDir, Len(ReturnChannelUpFilesDir) - 1)
End Function
'**************************************************
'函数名：ReturnChannelAllowUserUpFilesTF
'作 用：返回频道是否允许会员上传文件
'参 数：ChannelID--频道ID
'**************************************************
Public Function ReturnChannelAllowUserUpFilesTF(ChannelID)
If ChannelID = "" Or Not IsNumeric(ChannelID) Then '默认允许上传文件
ReturnChannelAllowUserUpFilesTF = True:Exit Function
End If
If C_S(ChannelID,26) = 1 Then
ReturnChannelAllowUserUpFilesTF = True
Else
ReturnChannelAllowUserUpFilesTF = False
End If
End Function
'**************************************************
'函数名：ReturnChannelUserUpFilesDir
'作 用：返回频道前台会员的上传目录
'参 数：ChannelID--频道ID,UserFolder-按用户名生成的目录
'返回值：目录字符串
'**************************************************
Public Function ReturnChannelUserUpFilesDir(ChannelID,UserFolder)
Dim Ce:Set Ce=new CtoeCls
UserFolder=Ce.CTOE(R(UserFolder))
Set Ce=Nothing
ChannelID = ChkCLng(ChannelID)
Select Case ChannelID
Case 9999 '用户头像
ReturnChannelUserUpFilesDir=Setting(3)&Setting(91)&"User/" & UserFolder &"/upface/"
Case 9998 '相册封面
ReturnChannelUserUpFilesDir=Setting(3)&Setting(91)&"User/" & UserFolder &"/xc/"
Case 9997 '照片
ReturnChannelUserUpFilesDir=Setting(3)&Setting(91)&"User/" & UserFolder &"/xc/"
Case 9996 '圈子图片
ReturnChannelUserUpFilesDir=Setting(3)&Setting(91)&"User/" & UserFolder &"/team/"
Case Else
ReturnChannelUserUpFilesDir = C_S(ChannelID,27)
ReturnChannelUserUpFilesDir = Setting(3) & Setting(91)&"User/" & UserFolder &"/"& ReturnChannelUserUpFilesDir
End Select
End Function
'**************************************************
'函数名：ReturnChannelAllowUpFilesSize
'作 用：返回频道的最大允许上传文件大小
'参 数：ChannelID--频道ID
'**************************************************
Public Function ReturnChannelAllowUpFilesSize(ChannelID)
ChannelID = ChkClng(ChannelID)
Dim CRS:Set CRS=conn.execute("Select UpFilesSize From KS_Channel Where ChannelID=" & ChannelID)
If CInt(ChannelID) = 0 Or (CRS.EOF And CRS.BOF) Then
ReturnChannelAllowUpFilesSize = Setting(6)
Else
ReturnChannelAllowUpFilesSize = CRS(0)
End If
CRS.Close:Set CRS = Nothing
End Function
'**************************************************
'函数名：ReturnChannelAllowUpFilesType
'作 用：返回频道的允许上传的文件类型
'参 数：ChannelID--频道ID,TypeFlag 0-取全部 1-图片类型 2-flash 类型 3-Windows 媒体类型 4-Real 类型 5-其它类型
'**************************************************
Public Function ReturnChannelAllowUpFilesType(ChannelID, TypeFlag)
If ChkClng(ChannelID) = 0 Then ReturnChannelAllowUpFilesType = Setting(7):Exit Function
If Not IsNumeric(TypeFlag) Then TypeFlag = 0
If TypeFlag = 0 Then '所有允许的类型
ReturnChannelAllowUpFilesType = C_S(ChannelID,28) & "|" & C_S(ChannelID,29) & "|" & C_S(ChannelID,30) & "|" & C_S(ChannelID,31) & "|" & C_S(ChannelID,32)
Else
ReturnChannelAllowUpFilesType = C_S(ChannelID,27+TypeFlag)
End If
End Function
'返回付款方式名称,参数TypeID,0名称 1折扣率
Function ReturnPayment(ID,TypeID)
If Application(SiteSn &"Payment_" & ID&TypeID)="" Then
Dim RS:Set RS=Server.CreateObject("ADODB.RECORDSET")
RS.Open "Select TypeName,Discount From KS_PaymentType Where TypeID=" & ID,conn,1,1
If Not RS.Eof Then
If TypeID=0 Then
ReturnPayment=rs(0)
If RS(1)<100 Then ReturnPayment=ReturnPayment & " 折扣率:" & RS(1) & "%"
Else
ReturnPayment=rs(1)
End if
End iF
Application(SiteSn &"Payment_" & ID&TypeID)=ReturnPayment
Else
ReturnPayment=Application(SiteSn &"Payment_" & ID&TypeID)
End If
End Function
'返回收货方式名称,参数TypeID,0名称 1费用
Function ReturnDelivery(ID,TypeID)
If Application(SiteSn &"Delivery_" & ID&TypeID)="" Then
Dim RS:Set RS=Server.CreateObject("ADODB.RECORDSET")
RS.Open "Select TypeName,fee From KS_Delivery Where TypeID=" & ID,conn,1,1
If Not RS.Eof Then
If TypeID=0 Then
ReturnDelivery=rs(0)
If RS(1)=0 Then ReturnDelivery=ReturnDelivery & " 免费" Else ReturnDelivery=ReturnDelivery & " 加收 " & RS(1) & "元"
Else
ReturnDelivery=rs(1)
End iF
End iF
Application(SiteSn &"Delivery_" & ID&TypeID)=ReturnDelivery
Else
ReturnDelivery=Application(SiteSn &"Delivery_" & ID&TypeID)
End If
End Function
'**********************************************************************
'函数名：ReturnSpecial
'作 用：返回专题名称
'参 数：Selected-预选中项 ,ChannelID--频道ID,FolderID ---目录ID
'返回值：专题名称
'**********************************************************************
Public Function ReturnSpecial(SelectID, ChannelID, FolderID)
Dim RS:Set RS=Server.CreateObject("ADODB.RECORDSET")
Dim ParaStr,SpecialChannelStr
If ChannelID="" Then ChannelID=0
If ChannelID <> 0 Then
ParaStr = ParaStr & " And ChannelID=" & ChannelID
End If
RS.Open "Select SpecialName,SpecialID,FolderID From KS_Special Where 1=1 " & ParaStr, Conn, 1, 1
If Not RS.EOF Then
Do While Not RS.EOF
If FolderID=RS(2) Then SpecialChannelStr="（本频道）" Else SpecialChannelStr=""
If Trim(SelectID) = Trim(RS(1)) Then
ReturnSpecial = ReturnSpecial & ""
Else
ReturnSpecial = ReturnSpecial & ""
End If
RS.MoveNext
Loop
End If
RS.Close:Set RS = Nothing
End Function
'**************************************************
'函数：FoundInArr
'作 用：检查一个数组中所有元素是否包含指定字符串
'参 数：strArr ----字符串
' strToFind ----要查找的字符串
' strSplit ----数组的分隔符
'返回值：True,False
'**************************************************
Public Function FoundInArr(strArr, strToFind, strSplit)
Dim arrTemp, i
FoundInArr = False
If InStr(strArr, strSplit) > 0 Then
arrTemp = Split(strArr, strSplit)
For i = 0 To UBound(arrTemp)
If LCase(Trim(arrTemp(i))) = LCase(Trim(strToFind)) Then
FoundInArr = True:Exit For
End If
Next
Else
If LCase(Trim(strArr)) = LCase(Trim(strToFind)) Then FoundInArr = True
End If
End Function
'检查是否是数字 ，并转换为长整型
Public Function ChkClng(ByVal str)
On error resume next
If IsNumeric(str) Then
ChkClng = CLng(str)
Else
ChkClng = 0
End If
If Err Then ChkClng=0
End Function
'**************************************************
'函数名：ShowPage
'作 用：显示“上一页 下一页”等信息
'参 数：filename ----链接地址
' TotalNumber ----总数量
' MaxPerPage ----每页数量
' ShowAllPages ---是否用下拉列表显示所有页面以供跳转。
' strUnit ----计数单位,CurrentPage--当前页
'返回值：无返回值
'**************************************************
Sub ShowPage(totalnumber, MaxPerPage, FileName, ShowAllPages, strUnit, CurrentPage)
Dim N, I, PageStr
Const Btn_First = "9" '定义第一页按钮显示样式
Const Btn_Prev = "3" '定义前一页按钮显示样式
Const Btn_Next = "4" '定义下一页按钮显示样式
Const Btn_Last = ":" '定义最后一页按钮显示样式
PageStr = ""
If totalnumber Mod MaxPerPage = 0 Then
N = totalnumber \ MaxPerPage
Else
N = totalnumber \ MaxPerPage + 1
End If
If N > 1 Then
PageStr = PageStr & ("页次：" & CurrentPage & "/" & N & "页 共有:" & totalnumber & strUnit & " 每页:" & MaxPerPage & strUnit & " ")
If CurrentPage < 2 Then
PageStr = PageStr & Btn_First & " " & Btn_Prev & " "
Else
PageStr = PageStr & ("" & Btn_First & "" & Btn_Prev & " ")
End If
If N - CurrentPage < 1 Then
PageStr = PageStr & " " & Btn_Next & " " & Btn_Last & " "
Else
PageStr = PageStr & (" " & Btn_Next & "" & Btn_Last & " ")
End If
If ShowAllPages = True Then
PageStr = PageStr & "GO:"
End If
End If
Response.Write (PageStr)
End Sub
'**************************************************
'函数名：ShowPagePara
'作 用：显示“上一页 下一页”等信息
'参 数：filename ----链接地址
' TotalNumber ----总数量
' MaxPerPage ----每页数量
' ShowAllPages ---是否用下拉列表显示所有页面以供跳转。
' strUnit ----计数单位,CurrentPage--当前页,ParamterStr参数
'返回值：无返回值
'**************************************************
Public Function ShowPagePara(totalnumber, MaxPerPage, FileName, ShowAllPages, strUnit, CurrentPage, ParamterStr)
Dim N, I, PageStr
Const Btn_First = "9" '定义第一页按钮显示样式
Const Btn_Prev = "3" '定义前一页按钮显示样式
Const Btn_Next = "4" '定义下一页按钮显示样式
Const Btn_Last = ":" '定义最后一页按钮显示样式
PageStr = ""
If totalnumber Mod MaxPerPage = 0 Then
N = totalnumber \ MaxPerPage
Else
N = totalnumber \ MaxPerPage + 1
End If
If N > 1 Then
PageStr = PageStr & (""
End If
ShowPagePara = PageStr
End Function
Sub ShowPageParamter(totalnumber, MaxPerPage, FileName, ShowAllPages, strUnit, CurrentPage, ParamterStr)
Response.Write (ShowPagePara(totalnumber, MaxPerPage, FileName, ShowAllPages, strUnit, CurrentPage, ParamterStr))
End Sub
'***********************************************************************************************************
'函数名：ReturnLabelFolderTree
'作 用：显示标签目录列表。
'参 数：SelectID ---- 默认目录树ID号,ChannelID频道ID号,FolderType目录类型 0系统函数标签目录,1自由标签目录
'返回值：标签目录列表
'*************************************************************************************************************
Public Function ReturnLabelFolderTree(SelectID, FolderType)
Dim TempStr,ID,FolderName
SelectID = Trim(SelectID)
If FolderType = "" Then FolderType = 0
TempStr = ""
ReturnLabelFolderTree = TempStr
End Function
'************************************************************************************
'函数名：ReturnSubLabelFolderTree
'作 用：查找并返子树数据。
'参 数：ParentID ----父节点ID, FolderID ----选择项ID
'返回值：标签目录子树列表
'************************************************************************************
Public Function ReturnSubLabelFolderTree(ParentID, FolderID)
Dim SubTypeList, SubRS, SpaceStr, k, Total, Num,FolderName, ID,TJ
Set SubRS = Server.CreateObject("ADODB.RECORDSET")
SubRS.Open ("Select count(ID) AS total from KS_LabelFolder Where ParentID='" & ParentID & "'"), Conn, 1, 1
Total = SubRS("Total")
SubRS.Close
SubRS.Open ("Select ID,FolderName,TS from KS_LabelFolder Where ParentID='" & ParentID & "' Order BY AddDate Desc"), Conn, 1, 1
Num = 0
Do While Not SubRS.EOF
Num = Num + 1:SpaceStr = ""
TJ = UBound(Split(SubRS(2), ","))
For k = 1 To TJ - 1
If k = 1 And k <> TJ - 1 Then
SpaceStr = SpaceStr & " │"
ElseIf k = TJ - 1 Then
If Num = Total Then
SpaceStr = SpaceStr & " └ "
Else
SpaceStr = SpaceStr & " ├ "
End If
Else
SpaceStr = SpaceStr & " │"
End If
Next
ID = Trim(SubRS(0))
FolderName = Trim(SubRS(1))
If FolderID = ID Then
SubTypeList = SubTypeList & ""
Else
SubTypeList = SubTypeList & ""
End If
SubTypeList = SubTypeList & ReturnSubLabelFolderTree(ID, FolderID)
SubRS.MoveNext
Loop
SubRS.Close:Set SubRS = Nothing:ReturnSubLabelFolderTree = SubTypeList
End Function
'***********************************************************************************************************
'函数名：ReturnLabelInfo
'参 数：LabelName ---- 默认标签名称,FolderID---标签目录ID号,Descript---标签描述
'返回值：标签基本信息
'*************************************************************************************************************
Public Function ReturnLabelInfo(LabelName, FolderID, Descript)
ReturnLabelInfo = ReturnLabelInfo & ("
")
ReturnLabelInfo = ReturnLabelInfo & ("
")
If g("PageTitle")<>"" Then
ReturnLabelInfo = ReturnLabelInfo & G("PageTitle")
Else
ReturnLabelInfo = ReturnLabelInfo & (" 修 改 标 签 属 性")
End If
ReturnLabelInfo = ReturnLabelInfo & ("
"
End Function
'分页样式
Public Function ReturnPageStyle(PageStyle)
ReturnPageStyle = " 分页样式"
ReturnPageStyle = ReturnPageStyle & " "
End Function
'专题显示样式
Public Function ReturnSpecialStyle(Sel)
ReturnSpecialStyle= "显示样式 "
End Function
'**************************************************
'函数名：ReturnPictureStyle
'作 用：返回图片显示方式的标签(标签中心调用)
'参 数：PicStyle--默认选择的样式
'**************************************************
Public Function ReturnPictureStyle(PicStyle)
If PicStyle = "1" Then ReturnPictureStyle = ("") Else ReturnPictureStyle = ReturnPictureStyle & ("")
If PicStyle = "2" Then ReturnPictureStyle = ReturnPictureStyle & ("") Else ReturnPictureStyle = ReturnPictureStyle & ("")
If PicStyle = "3" Then ReturnPictureStyle = ReturnPictureStyle & ("") Else ReturnPictureStyle = ReturnPictureStyle & ("")
If PicStyle = "4" Then ReturnPictureStyle = ReturnPictureStyle & ("") Else ReturnPictureStyle = ReturnPictureStyle & ("")
If PicStyle = "5" Then ReturnPictureStyle = ReturnPictureStyle & ("") Else ReturnPictureStyle = ReturnPictureStyle & ("")
End Function
'**************************************************
'函数名：ReturnFlashStyle
'作 用：返回Flash显示方式的标签(标签中心调用)
'参 数：PicStyle--默认选择的样式
'**************************************************
Public Function ReturnFlashStyle(PicStyle)
If PicStyle = "1" Then
ReturnFlashStyle = ("")
Else
ReturnFlashStyle = ReturnFlashStyle & ("")
End If
If PicStyle = "2" Then
ReturnFlashStyle = ReturnFlashStyle & ("")
Else
ReturnFlashStyle = ReturnFlashStyle & ("")
End If
If PicStyle = "3" Then
ReturnFlashStyle = ReturnFlashStyle & ("")
Else
ReturnFlashStyle = ReturnFlashStyle & ("")
End If
If PicStyle = "4" Then
ReturnFlashStyle = ReturnFlashStyle & ("")
Else
ReturnFlashStyle = ReturnFlashStyle & ("")
End If
If PicStyle = "5" Then
ReturnFlashStyle = ReturnFlashStyle & ("")
Else
ReturnFlashStyle = ReturnFlashStyle & ("")
End If
If PicStyle = "6" Then
ReturnFlashStyle = ReturnFlashStyle & ("")
Else
ReturnFlashStyle = ReturnFlashStyle & ("")
End If
If PicStyle = "7" Then
ReturnFlashStyle = ReturnFlashStyle & ("")
Else
ReturnFlashStyle = ReturnFlashStyle & ("")
End If
End Function
'**************************************************
'函数名：ReturnMovieStyle
'作 用：返回影片显示方式的标签(标签中心调用)
'参 数：PicStyle--默认选择的样式
'**************************************************
Public Function ReturnMovieStyle(PicStyle)
If PicStyle = "1" Then
ReturnMovieStyle = ("")
Else
ReturnMovieStyle = ReturnMovieStyle & ("")
End If
If PicStyle = "2" Then
ReturnMovieStyle = ReturnMovieStyle & ("")
Else
ReturnMovieStyle = ReturnMovieStyle & ("")
End If
If PicStyle = "3" Then
ReturnMovieStyle = ReturnMovieStyle & ("")
Else
ReturnMovieStyle = ReturnMovieStyle & ("")
End If
If PicStyle = "4" Then
ReturnMovieStyle = ReturnMovieStyle & ("")
Else
ReturnMovieStyle = ReturnMovieStyle & ("")
End If
If PicStyle = "5" Then
ReturnMovieStyle = ReturnMovieStyle & ("")
Else
ReturnMovieStyle = ReturnMovieStyle & ("")
End If
If PicStyle = "6" Then
ReturnMovieStyle = ReturnMovieStyle & ("")
Else
ReturnMovieStyle = ReturnMovieStyle & ("")
End If
If PicStyle = "7" Then
ReturnMovieStyle = ReturnMovieStyle & ("")
Else
ReturnMovieStyle = ReturnMovieStyle & ("")
End If
End Function
'**************************************************
'函数名：ReturnProductStyle
'作 用：返回图片显示方式的标签(标签中心调用)
'参 数：PicStyle--默认选择的样式
'**************************************************
Public Function ReturnProductStyle(PicStyle)
ReturnProductStyle=""
End Function
'商品按钮显示方式
Function ReturnProductButton(Sel)
ReturnProductButton=""
End Function
'商品价格显示方式
Function ReturnProductPrice(Sel)
ReturnProductPrice="