<%
'Response.Buffer=True
Dim SqlNowString,DataPart_D,DataPart_Y,DataPart_H,DataPart_S,DataPart_W,DataPart_M
Dim Conn,DBPath,CollectDBPath,DataServer,DataUser,DataBaseName,DataBasePsw,ConnStr,CollcetConnStr
'***********牛摩网发邮件配置 start****************************
Const Newmotor_Email_UserName ="1815400921@qq.com" '牛摩网邮箱帐号
Const Newmotor_Email_Password ="xiegao" '牛摩网邮箱密码
Const Newmotor_Email_Name ="牛摩网"' '发信人姓名
Const Newmotor_Email_smtpServer ="smtp.qq.com" '邮箱SMTP 服务器名称
'***********牛摩网发邮件配置 end****************************
Const DataBaseType=1 '系统数据库类型，"1"为MS SQL2000数据库，"0"为MS ACCESS 2000数据库
Const MsxmlVersion=".3.0" '系统采用XML版本设置
Const EnableSiteManageCode = true '是否启用后台管理认证码 是： True 否： False
Const SiteManageCode = "6518" '后台管理认证码，请修改，这样即使有人知道了您的后台用户名和密码也不能登录后台
Const Newmotor_isDebug = false '判断牛摩网是否是正在测试，true：表示测试阶段，false 表示不测试
'没测试的时候务必把true改为false，这样可以提高网站访问速度
'图片文件上传到指定的服务器上面
Const uploadFileServerPath = "http://img2.newmotor.com.cn"
Const upload_FileServerPath2 = "img2.newmotor.com.cn"
Session.Timeout=24 'SEESION有效时间为:24小时
If DataBaseType=0 then
'如果是ACCESS数据库，请认真修改好下面的数据库的文件名
DBPath = "/KS_Data/KesionCMS7.mdb" 'ACCESS数据库的文件名，请使用相对于网站根目录的的绝对路径
Else
'如果是SQL数据库，请认真修改好以下数据库选项
DataServer = "23.224.235.74" '数据库服务器IP 电信ip：14.152.95.180
DataUser = "newmotor" '访问数据库用户名
DataBaseName = "newmotor" '数据库名称
'DataBaseName = "new" '数据库名称
DataBasePsw = "pxhTyJ9Yj}0pOPv[M2CnrqO&SsR!L" '访问数据库密码
End if
'采集数据库路径
CollectDBPath="\KS_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 & ";"
'asp 连接sql server2008
'ConnStr= "provider=sqloledb;Data source=" & DataServer & ",3819;uid=" & DataUser & ";pwd="& DataBasePsw &";database=" & DataBaseName
ConnStr= "provider=sqloledb;Data source=" & DataServer & ",1433;uid=" & DataUser & ";pwd="& DataBasePsw &";database=" & DataBaseName
SqlNowString = "getdate()"
DataPart_D = "d"
DataPart_Y = "y"
DataPart_H = "hour"
DataPart_S = "s"
DataPart_W = "week"
DataPart_M = "month"
Else
ConnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(DBPath)
SqlNowString = "Now()"
DataPart_D = "'d'"
DataPart_Y = "'yyyy'"
DataPart_H = "'h'"
DataPart_S = "'s'"
DataPart_W = "'w'"
DataPart_M = "'m'"
End If
Set conn = Server.CreateObject("ADODB.Connection")
conn.open ConnStr
If Err Then Err.Clear:Set conn = Nothing:Response.Write "数据库正在迁移，请稍候访问... " & Err.Description:Response.End
CollcetConnStr ="Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath(CollectDBPath)
'CollcetConnStr ="Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Server.MapPath(CollectDBPath)
End Sub
Sub CloseConn()
On Error Resume Next
Conn.close:Set Conn=nothing
End sub
'====================================如果频道启用二级域名,请正确配置以下参数,否则可能导致会员不能登录==========================
Const EnabledSubDomain =true rem 网站频道是否启用二级域名 true表示启用 false表示没有启用
Const RootDomain = "newmotor.com.cn" rem 网站主域名根,如果有多个子域名,必须设置
'=============================================二级域名配置结束========================================================
'==============================================全局变量类开始==============================
Dim GCls:Set GCls=New GlobalVarCls
Class GlobalVarCls
Public Sql_Use
Public StaticPreList,StaticPreContent,StaticExtension,ClubPreContent,ClubPreList
Private Sub Class_Initialize()
StaticPreList = "list" rem 内容模型伪静态列表前缀 不能包含"?"及"-"
staticPreContent = "thread" rem 内容模型伪静态内容前缀
StaticExtension = ".html" rem 内容模型伪静态扩展名
ClubPreContent = "forumthread" rem 伪静态小论坛帖子前缀地址
ClubPreList = "forum" rem 伪静态小论坛版面列表前缀地址
End Sub
Private Sub Class_Terminate()
Set GCls=Nothing
End Sub
Public Function Execute(Command)
If Not IsObject(Conn) Then OpenConn()
On Error Resume Next
Set Execute = Conn.Execute(Command)
If Err Then
Response.Write("查询语句为：" & Command & " ")
Response.Write("错误信息为：" & Err.Description & " ")
Err.Clear
Set Execute = Nothing
Response.End()
End If
Sql_Use = Sql_Use + 1
End Function
Function GetUrl()
On Error Resume Next
Dim strTemp
If LCase(Request.ServerVariables("HTTPS")) = "off" Then
strTemp = "http://"
Else
strTemp = "https://"
End If
strTemp = strTemp & Request.ServerVariables("SERVER_NAME")
If Request.ServerVariables("SERVER_PORT") <> 80 Then
strTemp = strTemp & ":" & Request.ServerVariables("SERVER_PORT")
end if
strTemp = strTemp & Request.ServerVariables("URL")
If Trim(Request.QueryString) <> "" Then
strTemp = strTemp & "?" & Trim(Request.QueryString)
end if
GetUrl = strTemp
End Function
'====================标志来访地址================
Public Property Let ComeUrl(ByVal strVar)
Session("M_ComeUrl") = strVar
End Property
Public Property Get ComeUrl
ComeUrl= Session("M_ComeUrl")
End Property
'================================================
End Class
'==============================================全局临时变量类结束==============================
%>
<%
'****************************************************
'Newmotor.com.cn
'****************************************************
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 = KS.InitialObject(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 = KS.InitialObject("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
on error resume next
TextWidth = objImage.Canvas.GetTextExtent(Text)
if err then err.clear:TextWidth =200
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.Quality=80
objImage.Save FileName
Case 2
If Not KS.IsObjInstalled("wsImage.Resize") Then
Exit Function
End If
Set objImage = KS.InitialObject("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 = KS.InitialObject("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 = KS.InitialObject("Persits.Jpeg")
Set objMark = KS.InitialObject("Persits.Jpeg")
objImage.Open FileName
If objImage.OriginalWidth < MarkWidth Or objImage.OriginalHeight < MarkHeight Then
Exit Function
End If
objMark.Open Server.MapPath(MarkPicture)
'objImage.Canvas.DrawImage 0,objImage.OriginalHeight/2-33,objMark,0.6,&HFFFFFF
GetPostion CInt(MarkPosition), x, y, objImage.OriginalWidth, objImage.OriginalHeight, MarkWidth, MarkHeight
If MarkTranspColor <> "" Then
objImage.Canvas.DrawImage x, y, objMark, MarkOpacity, MarkTranspColor
'objImage.Canvas.DrawImage x, y, objMark, MarkOpacity,&HFFFFFF
Else
objImage.DrawImage x, y, objMark, MarkOpacity
End If
objImage.Quality=80
objImage.Save FileName
Case 2
If Not KS.IsObjInstalled("wsImage.Resize") Then
Exit Function
End If
Set objImage = KS.InitialObject("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 = KS.InitialObject("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(ByVal FileName, ByVal ThumbFileName)
CreateThumbs = False
If KS.TbSetting(0) <> "0" And (Not IsNull(KS.TbSetting(0))) Then
If KS.TbSetting(1) = "0" Then
Dim ThumbnailsConfig,Width,Height,GoldenPoint
ThumbnailsConfig= Session("ThumbnailsConfig")
If ThumbnailsConfig="" Then
GoldenPoint= Round(KS.TbSetting(18))
Width=CInt(KS.TbSetting(2))
Height= CInt(KS.TbSetting(3))
Else
ThumbnailsConfig=Split(ThumbnailsConfig,"|")
If Not IsNumeric(ThumbnailsConfig(0)) Then
GoldenPoint= 0
Else
GoldenPoint= Round(ThumbnailsConfig(0))
End If
If Not IsNumeric(ThumbnailsConfig(1)) Then
Width=100
Else
Width=CInt(ThumbnailsConfig(1))
End If
If Not IsNumeric(ThumbnailsConfig(2)) Then
Height=80
Else
Height= CInt(ThumbnailsConfig(2))
End If
End If
CreateThumbs = CreateThumb(FileName,Width ,Height,GoldenPoint, 0, ThumbFileName)
Else
CreateThumbs = CreateThumb(FileName, 0, 0, GoldenPoint,CSng(KS.TbSetting(4)), ThumbFileName)
End If
End If
End Function
'由原图片根据数据里保存的设置生成缩略图
Function CreateSimilThumbs(ByVal FileName, ByVal ThumbFileName)
CreateSimilThumbs = False
If KS.TbSetting(0) <> "0" And (Not IsNull(KS.TbSetting(0))) Then
If KS.TbSetting(1) = "0" Then
Dim ThumbnailsConfig,Width,Height,GoldenPoint
ThumbnailsConfig= Session("ThumbnailsConfig")
If ThumbnailsConfig="" Then
GoldenPoint= Round(KS.TbSetting(18))
Else
ThumbnailsConfig=Split(ThumbnailsConfig,"|")
If Not IsNumeric(ThumbnailsConfig(0)) Then
GoldenPoint= 0
Else
GoldenPoint= Round(ThumbnailsConfig(0))
End If
End If
Width= 50
Height= 50
CreateSimilThumbs = CreateThumb(FileName,Width ,Height,GoldenPoint, 0, ThumbFileName)
Else
CreateSimilThumbs = CreateThumb(FileName, 0, 0, GoldenPoint,CSng(KS.TbSetting(4)), ThumbFileName)
End If
End If
End Function
'由原图片生成指定宽度和高度的缩略图
Function CreateThumb(FileName, Width, Height,GoldenPoint, 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 = KS.InitialObject("Persits.Jpeg")
objImage.Open FileName
If Rate = 0 And (Width <> 0 Or Height <> 0) Then
If Width < objImage.OriginalWidth And Height < objImage.OriginalHeight And Height<>0 Then
dim qjazhro_h,qjazhro_w,qjazhro_t,qjazhro_hj,qjazhro,mznvhai
qjazhro=round((Width/Height),3)
mznvhai=round((objImage.OriginalWidth/objImage.OriginalHeight),3)
If qjazhromznvhai Then
objImage.Width = Width
objImage.Height = round((objImage.OriginalHeight / objImage.OriginalWidth * Width),3)
qjazhro_h=objImage.Height-Height
qjazhro_hj=qjazhro_h*GoldenPoint 'GoldenPoint为黄金分割点，你可以按自己的要求修改这个值
qjazhro_t=Height+qjazhro_hj
objImage.crop 0,qjazhro_hj,Width,qjazhro_t
ElseIf qjazhro=mznvhai Then
objImage.Width = Width
objImage.Height = Height
End If
End If
If Height=0 Then '当高度为0时,自适应高度
Height=Width * objImage.OriginalHeight / objImage.OriginalWidth
objImage.Height=Height
objImage.Width=Width
End If
ElseIf Rate <> 0 Then
objImage.Width = objImage.OriginalWidth * Rate
objImage.Height = objImage.OriginalHeight * Rate
End If
objImage.Interpolation=0
objImage.Quality=80
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 = KS.InitialObject("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 = KS.InitialObject("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 = KS.InitialObject("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
%>
<%
'****************************************************
'Newmotor.com.cn
'****************************************************
Class CtoECls
Private Sub Class_Initialize()
End Sub
Private Sub Class_Terminate()
End Sub
function CTOE(str)
dim codestr:codestr=Join(UTF8ToANSIArray(str), ",")
dim n,tt
tt=split(codestr,",")
for n=0 to ubound(tt)
CTOE=CTOE&getpychar(tt(n))
next
end function
Public Function LShift(ByVal lValue, ByVal iBit)
LShift = lValue * (2 ^ iBit)
End Function
'整合高低位字节为整数
Public Function MAKEWORD(ByVal iHigh, ByVal iLow)
MAKEWORD = (iHigh And &HFF) Or LShift((iLow And &HFF), 8)
End Function
'将Unicode字符串转换成GBK编码数组
'该函数用于CodePage=65001环境
Public Function UTF8ToANSIArray(ByVal strData)
Dim objStream
Dim ret, i, k
Set objStream = Server.CreateObject("ADODB.Stream")
objStream.Type = 2
objStream.Mode = 3
objStream.Charset = "gbk"
objStream.Open
objStream.WriteText strData
objStream.Position = 0
objStream.Type = 1
ReDim ret(objStream.Size - 1)
For i = 0 To UBound(ret)
ret(i) = AscB(objStream.Read(1))
Next
k = 0
For i = 0 To UBound(ret)
If ret(i) < 128 Then
ret(k) = ret(i)
Else
ret(k) = MAKEWORD(ret(i + 1), ret(i))
i = i + 1
End If
k = k + 1
Next
ReDim Preserve ret(k - 1)
objStream.Close
Set objStream = Nothing
UTF8ToANSIArray = ret
End Function
function getpychar(tmp)
'tmp=65536+asc(char)
if(tmp>=45217 and tmp<=45252) then
getpychar= "a"
elseif(tmp>=45253 and tmp<=45760) then
getpychar= "b"
elseif(tmp>=45761 and tmp<=46317) then
getpychar= "c"
elseif(tmp>=46318 and tmp<=46825) then
getpychar= "d"
elseif(tmp>=46826 and tmp<=47009) then
getpychar= "e"
elseif(tmp>=47010 and tmp<=47296) then
getpychar= "f"
elseif(tmp>=47297 and tmp<=47613) then
getpychar= "g"
elseif(tmp>=47614 and tmp<=48118) then
getpychar= "h"
elseif(tmp>=48119 and tmp<=49061) then
getpychar= "j"
elseif(tmp>=49062 and tmp<=49323) then
getpychar= "k"
elseif(tmp>=49324 and tmp<=49895) then
getpychar= "l"
elseif(tmp>=49896 and tmp<=50370) then
getpychar= "m"
elseif(tmp>=50371 and tmp<=50613) then
getpychar= "n"
elseif(tmp>=50614 and tmp<=50621) then
getpychar= "o"
elseif(tmp>=50622 and tmp<=50905) then
getpychar= "p"
elseif(tmp>=50906 and tmp<=51386) then
getpychar= "q"
elseif(tmp>=51387 and tmp<=51445) then
getpychar= "r"
elseif(tmp>=51446 and tmp<=52217) then
getpychar= "s"
elseif(tmp>=52218 and tmp<=52697) then
getpychar= "t"
elseif(tmp>=52698 and tmp<=52979) then
getpychar= "w"
elseif(tmp>=52980 and tmp<=53688) then
getpychar= "x"
elseif(tmp>=53689 and tmp<=54480) then
getpychar= "y"
elseif(tmp>=54481 and tmp<=62289) then
getpychar= "z"
else
getpychar=chr(tmp)
end if
end function
End Class
%>
<%
'****************************************************
'Newmotor.com.cn
'****************************************************
Class KesionCls
Private Sub Class_Initialize()
End Sub
Private Sub Class_Terminate()
End Sub
'系统版本号
Public Property Get KSVer
KSVer="KS V7 全能版"
End Property
'系统缓存名称,如果你的一个站点下安装多套牛摩系统，请分别将各个目录下的系统的缓存名称设置成不同
Public Property Get SiteSN
SiteSN="KS7"
End Property
End Class
%>
<%
'****************************************************
'Newmotor.com.cn
'****************************************************
Const ClassField="ID,FolderName,Folder,ClassPurview,FolderDomain,TemplateID,ClassBasicInfo,ClassDefineContent,TS,ClassID,Tj,DefaultDividePercent,ChannelID,TN,ClassType,FolderOrder,AdminPurview,AllowArrGroupID,CommentTF,Child,PubTf,MailTF" '定义载入缓存的栏目字段
Class PublicCls
Public SiteSN,Version
Public Setting,TbSetting,SSetting,JSetting,ASetting,WSetting
Private Sub Class_Initialize()
if Not Response.IsClientConnected then die ""
Call Initialize_Kesion_Config
End Sub
Private Sub Class_Terminate()
End Sub
Function InitialObject(str)
'iis5创建对象方法Server.CreateObject(ObjectName);
'iis6创建对象方法CreateObject(ObjectName);
'默认为iis6，如果在iis5中使用，需要改为Server.CreateObject(str);
Set InitialObject=CreateObject(str)
End Function
'*******************************************************************************************************************
'函数名：Initialize_Kesion_Config
'作 用: 加载KesionCMS的必要参数
'备 注：以下参数请不要更改。否则系统可能无法正常运行
'*******************************************************************************************************************
Public Function Initialize_Kesion_Config()
Dim KCls:Set KCls=New KesionCls
SiteSN =KCls.SiteSN
Version = KCls.KSVer
Set KCls=Nothing
'Call InitialConfig()
'Call IsIPlock() 'IP访问限制
End Function
'*********新增ks——v9.5函数 start**********************************************************************
'生成商品品牌缓存
Sub CreateBrandCache()
Dim XMLStr,RS:Set RS=Server.CreateObject("adodb.recordset")
RS.Open "Select B.ID,R.ClassID,B.BrandName From KS_ClassBrand B inner join KS_ClassBrandR R On B.id=R.BrandID order by B.orderid",conn,1,1
If Not RS.EOf Then
XMLStr="" &vbcrlf
XMLStr=XMLStr&"" &vbcrlf
Do While Not RS.Eof
XMLStr=XMLStr & "" &vbcrlf
RS.MoveNext
Loop
XMLStr=XMLStr&"" &vbcrlf
Call WriteTOFile(Setting(3) & "config/shopbrand.xml",xmlstr)
End If
RS.CLose
Set RS=Nothing
End Sub
Function ReadSetting(no)
dim config:config=split(ReadFromFile(Setting(3) & "config/config.txt") &"♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂♂","♂")
ReadSetting=config(no)
End Function
'*********新增ks——v9.5函数 end **********************************************************************
'不提示,批量清除缓存,参数 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 RSObj':Set RSObj=Server.CreateObject("ADODB.RECORDSET")
'RSObj.Open "SELECT top 1 Setting,TbSetting,SpaceSetting,JobSetting,AskSetting,WapSetting from [KS_Config]",conn,1,1
Set RSObj=Conn.Execute("PRO_GetSetting")
Dim i,node,xml,j,DataArray,rs
Set xml = Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
xml.appendChild(xml.createElement("xml"))
If Not RSObj.EOF Then
DataArray=RSObj.GetRows(1)
RSObj.Close:Set RSObj=Nothing
For i=0 To UBound(DataArray,2)
Set Node=xml.createNode(1,"config","")
node.attributes.setNamedItem(xml.createNode(2,LCase("Setting"),"")).text= Replace(DataArray(0,i),vbcrlf,"$br$")& ""
node.attributes.setNamedItem(xml.createNode(2,LCase("TbSetting"),"")).text= Replace(DataArray(1,i),vbcrlf,"$br$")& ""
node.attributes.setNamedItem(xml.createNode(2,LCase("SpaceSetting"),"")).text= Replace(DataArray(2,i),vbcrlf,"$br$")& ""
node.attributes.setNamedItem(xml.createNode(2,LCase("JobSetting"),"")).text= Replace(DataArray(3,i),vbcrlf,"$br$")& ""
node.attributes.setNamedItem(xml.createNode(2,LCase("AskSetting"),"")).text= Replace(DataArray(4,i),vbcrlf,"$br$")& ""
node.attributes.setNamedItem(xml.createNode(2,LCase("WapSetting"),"")).text= Replace(DataArray(5,i),vbcrlf,"$br$")& ""
xml.documentElement.appendChild(Node)
Next
End If
DataArray=Null
Set Application(SiteSN&"_Config")=Xml
End Sub
Public Sub InitialConfig()
If not IsObject(Application(SiteSN&"_Config")) Then GetSetting
Setting=Split(Replace(Application(SiteSN&"_Config").documentElement.selectSingleNode("config/@setting").text,"$br$",vbcrlf),"^%^")
TbSetting=Split(Replace(Application(SiteSN&"_Config").documentElement.selectSingleNode("config/@tbsetting").text,"$br$",vbcrlf),"^%^")
SSetting=Split(Replace(Application(SiteSN&"_Config").documentElement.selectSingleNode("config/@spacesetting").text,"$br$",vbcrlf),"^%^")
JSetting=Split(Replace(Application(SiteSN&"_Config").documentElement.selectSingleNode("config/@jobsetting").text,"$br$",vbcrlf),"^%^")
ASetting=Split(Replace(Application(SiteSN&"_Config").documentElement.selectSingleNode("config/@asksetting").text,"$br$",vbcrlf),"^%^")
WSetting=Split(Replace(Application(SiteSN&"_Config").documentElement.selectSingleNode("config/@wapsetting").text,"$br$",vbcrlf),"^%^")
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
'xmlroot跟节点名称 row记录行节点名称*******(通过优化执行速度快2015-01-10)
Public Function RecordsetToxml2(RSObj,row,xmlroot)
Dim i,node,rs,j,DataArray,fieldsCount
If xmlroot="" Then xmlroot="xml"
If row="" Then row="row"
Set RecordsetToxml2=Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
RecordsetToxml2.appendChild(RecordsetToxml2.createElement(xmlroot))
If Not RSObj.EOF Then
DataArray=RSObj.GetRows(-1)
fieldsCount = RSObj.Fields.count
RSObj.close:Set RSObj=Nothing
For i=0 To UBound(DataArray,2)
Set Node=RecordsetToxml2.createNode(1,row,"")
j=0
For j=0 To fieldsCount-1
node.attributes.setNamedItem(RecordsetToxml2.createNode(2,"ks"&j,"")).text= DataArray(j,i)& ""
next
RecordsetToxml2.documentElement.appendChild(Node)
Next
End If
DataArray=Null
End Function
'xmlroot跟节点名称 row记录行节点名称
Public Function RsToxml(RSObj,row,xmlroot)
Dim i,node,rs,j,DataArray,fieldName
If xmlroot="" Then xmlroot="xml"
If row="" Then row="row"
Set RsToxml = Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
RsToxml.appendChild(RsToxml.createElement(xmlroot))
If Not RSObj.EOF Then
DataArray=RSObj.GetRows(-1)
For i=0 To UBound(DataArray,2)
Set Node=RsToxml.createNode(1,row,"")
j=0
For Each rs in RSObj.Fields
fieldName=LCase(rs.name)
if fieldName="username" then
node.attributes.setNamedItem(RsToxml.createNode(2,fieldName,"")).text= lcase(DataArray(j,i))& ""
else
node.attributes.setNamedItem(RsToxml.createNode(2,fieldName,"")).text= DataArray(j,i)& ""
end if
j=j+1
Next
RsToxml.documentElement.appendChild(Node)
Next
End If
DataArray=Null
End Function
'xmlroot跟节点名称 row记录行节点名称---(这是优化能够提升执行速度的函数2015-01-12)
Public Function RsToxml2(rsFields,DataArray,row,xmlroot)
Dim i,node,rs,j,fieldName
If xmlroot="" Then xmlroot="xml"
If row="" Then row="row"
Set RsToxml2 = Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
RsToxml2.appendChild(RsToxml2.createElement(xmlroot))
rsFields = Split(rsFields,",")
'DataArray=RSObj.GetRows(-1)
For i=0 To UBound(DataArray,2)
Set Node=RsToxml2.createNode(1,row,"")
j=0
for j=0 to ubound(rsFields)
FieldName = rsFields(j)
if fieldName="username" then
node.attributes.setNamedItem(RsToxml2.createNode(2,LCase(fieldName),"")).text= lcase(DataArray(j,i))& ""
else
node.attributes.setNamedItem(RsToxml2.createNode(2,LCase(fieldName),"")).text= DataArray(j,i)& ""
end If
Next
RsToxml2.documentElement.appendChild(Node)
Next
DataArray=Null
End Function
Public Function ArrayToxml(DataArray,Recordset,row,xmlroot)
Dim i,node,rs,j
If xmlroot="" Then xmlroot="xml"
Set ArrayToxml = Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
ArrayToxml.appendChild(ArrayToxml.createElement(xmlroot))
If row="" Then row="row"
For i=0 To UBound(DataArray,2)
Set Node=ArrayToxml.createNode(1,row,"")
j=0
For Each rs in Recordset.Fields
node.attributes.setNamedItem(ArrayToxml.createNode(2,LCase(rs.name),"")).text= DataArray(j,i)& ""
j=j+1
Next
ArrayToxml.documentElement.appendChild(Node)
Next
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,ChargeType,FsoListNum,UserTF,DiggByVisitor,DiggByIP,DiggRepeat,DiggPerTimes,UserClassStyle,UserEditTF,FsoContentRule,FsoClassListRule,FsoClassPreTag,ThumbnailsConfig,LatestNewDay,StaticTF,PubTimeLimit,AnnexPoint,ModelIco,ModelShortName From KS_Channel Order by ChannelID")
'Set Application(SiteSN&"_ChannelConfig")=RecordsetToxml(rs,"channel","ChannelConfig")
'Set Rs=Nothing
Dim RS:Set Rs=conn.execute("PRO_LoadChannelConfig")
Set Application(SiteSN&"_ChannelConfig")=RecordsetToxml2(rs,"channel","ChannelConfig")
Application.unLock
End Function
Function C_S(sChannelID,FieldID)
If IsNul(sChannelID) Then Exit Function
If not IsObject(Application(SiteSN&"_ChannelConfig")) Then LoadChannelConfig()
Dim Node:Set Node=Application(SiteSN&"_ChannelConfig").documentElement.selectSingleNode("channel[@ks0=" & sChannelID & "]/@ks" & FieldID & "")
If Not Node Is Nothing Then C_S = Node.Text Else C_S=0
Set Node = Nothing
End Function
Public Function LoadClassConfig()
If not IsObject(Application(SiteSN&"_class")) Then
Application.Lock
'Dim RS:Set Rs=conn.execute("select " & ClassField & " From KS_Class Order by root,folderorder")
'Set Application(SiteSN&"_class")=RecordsetToxml(rs,"class","classConfig")
'Set Rs=Nothing
Dim RS:Set Rs=conn.execute("PRO_LoadClassConfig")
Set Application(SiteSN&"_class")=RecordsetToxml2(rs,"class","classConfig")
Application.unLock
End If
End Function
'加载所有要生成的产品数据
Public Function LoadAllCreateProdct()
If not IsObject(Application(SiteSN&"_LoadAllCreateProduct")) Then
Application.Lock
Dim RS:Set RS=Conn.Execute("exec ks_LoadAllCreateProduct")
'Dim DataArray_:DataArray_ = rs.GetRows(-1)
'Set Application(SiteSN&"_LoadAllCreateProduct")= ArrayToXml(DataArray_,RS,"row","allcreateproductConfig")
'RS.Close:Set RS=Nothing
Dim rsFieldsStr,DataArray_:DataArray_ = rs.GetRows(-1)
RS.Close:Set RS=Nothing
rsFieldsStr="ID,ProID,Tid,KeyWords,Title,PhotoUrl,BigPhoto,Intro,ProModel,ProSpecificat,ProducerName,TrademarkName,ServiceTerm,Rank,Unit,Hits,TotalNum,AlarmNum,ProductType,Discount,Price,Price_Original,Price_Market,Price_Member,AddDate,JSID,TemplateID,Fname,RefreshTF,Recommend,Rolls,Popular,Verific,Comment,IsSpecial,IsTop,Slide,Point,DelTF,GroupPrice,BrandID,HitsByDay,HitsByWeek,HitsByMonth,LastHitsTime,Strip,ClassID,ShowOnSpace,BigClassID,SmallClassID,AttributeCart,Inputer,WapTemplateID,IsChangedBuy,ChangeBuyNeedPrice,ChangeBuyPresentPrice,IsLimitbuy,LimitBuyPrice,LimitBuyTaskID,LimitBuyAmount,weight,KS_chexing,KS_fupinpai,KS_ckg,KS_zhouju,KS_lidijianxie,KS_zuodiangao,KS_youxiangrongliang,KS_kongchezhiliang,KS_zhengbeizhiliang,KS_gangshu,KS_chonchengshu,KS_lenquefangshi,KS_yasuobi,KS_zuidagonglv,KS_zuidaniuju,KS_zuigaochesu,KS_gonyoufangshi,KS_jingjihaoyou,KS_qidongfangshi,KS_zhidongfangshi,KS_liheqixingshi,KS_ppId,ks_ppname,KS_pinyin,KS_bbsid,KS_shichangjia,KS_pailiang,KS_isshengcheng,KS_Score,KS_Rnumber,KS_SSSH,KS_ZCTC,KS_lunshu,KS_QLGZ,KS_HLGZ,KS_KXYS,KS_HBBZ,KS_BXQXH,KS_lunwang,KS_mbh,KS_pingjunjia,KS_shangjiashu,KS_shuxing,HitsByYear,HitsByYear2012,KS_tjindex,KS_cuxiaourl,KS_isNew,KS_isDianDongChe,KS_CDCLX,KS_CDCGG,KS_CDCSL,KS_CDQLX,KS_CDDY,KS_DJEDEL,KS_DJEDDY,KS_PeiJian,ks_fabunum"
rsFieldsStr = LCase(rsFieldsStr)
Set Application(SiteSN&"_LoadAllCreateProduct")= ArrayToxml2(rsFieldsStr,DataArray_,"row","allcreateproductConfig")
Application.unLock
End If
End Function
'加载所有要生成的品牌数据
Public Function LoadAllCreate_PPB()
If not IsObject(Application(SiteSN&"_LoadAllCreate_PPB")) Then
Application.Lock
Dim rsFieldsStr,RS:Set RS=Conn.Execute("exec ks_LoadAllCreate_PPB")
Dim DataArray_:DataArray_ = rs.GetRows(-1)
'Set Application(SiteSN&"_LoadAllCreate_PPB")= ArrayToXml(DataArray_,RS,"row","allcreatePPBConfig")
RS.Close:Set RS=Nothing
rsFieldsStr="ID,TID,KeyWords,TitleType,Title,FullTitle,Intro,ShowComment,TitleFontColor,TitleFontType,ArticleContent,PageTitle,Author,Origin,Rank,Hits,HitsByDay,HitsByWeek,HitsByMonth,LastHitsTime,AddDate,JSID,TemplateID,WapTemplateID,Fname,RefreshTF,Inputer,PhotoUrl,PicNews,Changes,Recommend,Rolls,Strip,Popular,Verific,Slide,Comment,IsTop,IsVideo,DelTF,OrderID,IsSign,SignUser,SignDateLimit,SignDateEnd,Province,City,InfoPurview,ArrGroupID,ReadPoint,ChargeType,PitchTime,ReadTimes,DividePercent,MapMarker,KS_ppzm,ks_ppid,ks_ppname,KS_pinyin,KS_paixu,KS_tsdh,KS_ppQQ1,KS_ppQQ2,KS_ppQQ3,KS_QQ1sm,KS_QQ2sm,KS_QQ3sm,KS_bbsid,KS_isshengcheng,KS_erweima,KS_tanchuang,KS_VIPkehu,KS_isNew,KS_productNum"
rsFieldsStr = LCase(rsFieldsStr)
Set Application(SiteSN&"_LoadAllCreate_PPB")= ArrayToxml2(rsFieldsStr,DataArray_,"row","allcreatePPBConfig")
Application.unLock
End If
End Function
Public Function ArrayToxml2(rsFields,DataArray,row,xmlroot)
Dim i,node,rs,j,r,FieldName
If xmlroot="" Then xmlroot="xml"
Set ArrayToxml2 = Server.CreateObject("msxml2.FreeThreadedDOMDocument"& MsxmlVersion)
ArrayToxml2.appendChild(ArrayToxml2.createElement(xmlroot))
If row="" Then row="row"
rsFields = Split(rsFields,",")
For i=0 To UBound(DataArray,2)
Set Node=ArrayToxml2.createNode(1,row,"")
j=0
for r=0 to ubound(rsFields)
FieldName = rsFields(r)
node.attributes.setNamedItem(ArrayToxml2.createNode(2,LCase(FieldName),"")).text= DataArray(j,i)& ""
j=j+1
Next
ArrayToxml2.documentElement.appendChild(Node)
Next
End Function
'添加节点
Public Function AddArrayToxml2(rsFields,DataArray,row,xmlroot,Application_key)
If isnul(Application_key) Then Exit Function
Application_key = Trim(Application_key)
Dim i,node,rs,j,r,FieldName
If IsOBJECT(Application(Application_key)) Then
If xmlroot="" Then xmlroot="xml"
If row="" Then row="row"
Set AddArrayToxml2 = Application(Application_key)
rsFields = Split(rsFields,",")
For i=0 To UBound(DataArray,2)
Set Node=AddArrayToxml2.createNode(1,row,"")
j=0
for r=0 to ubound(rsFields)
FieldName = rsFields(r)
node.attributes.setNamedItem(AddArrayToxml2.createNode(2,LCase(FieldName),"")).text = DataArray(j,i) & ""
j=j+1
Next
AddArrayToxml2.documentElement.appendChild(Node)
Next
End If
End Function
'加载所有产品数据
Public Function LoadAllproductData()
If not IsObject(Application(SiteSN&SiteSN&"_LoadAllproductData")) Then
Application.Lock
Dim RS:Set RS=Conn.Execute("exec KS_LoadAllproductData")
Dim DataArray_,rsFieldsStr:DataArray_ = rs.GetRows(-1)
RS.Close:Set RS=Nothing
rsFieldsStr = "ID,ProID,Tid,KeyWords,Title,PhotoUrl,BigPhoto,Intro,ProModel,ProSpecificat,ProducerName,TrademarkName,ServiceTerm,Rank,Unit,Hits,TotalNum,AlarmNum,ProductType,Discount,Price,Price_Original,Price_Market,Price_Member,AddDate,JSID,TemplateID,Fname,RefreshTF,Recommend,Rolls,Popular,Verific,Comment,IsSpecial,IsTop,Slide,Point,DelTF,GroupPrice,BrandID,HitsByDay,HitsByWeek,HitsByMonth,LastHitsTime,Strip,ClassID,ShowOnSpace,BigClassID,SmallClassID,AttributeCart,Inputer,WapTemplateID,IsChangedBuy,ChangeBuyNeedPrice,ChangeBuyPresentPrice,IsLimitbuy,LimitBuyPrice,LimitBuyTaskID,LimitBuyAmount,weight,KS_chexing,KS_fupinpai,KS_ckg,KS_zhouju,KS_lidijianxie,KS_zuodiangao,KS_youxiangrongliang,KS_kongchezhiliang,KS_zhengbeizhiliang,KS_gangshu,KS_chonchengshu,KS_lenquefangshi,KS_yasuobi,KS_zuidagonglv,KS_zuidaniuju,KS_zuigaochesu,KS_gonyoufangshi,KS_jingjihaoyou,KS_qidongfangshi,KS_zhidongfangshi,KS_liheqixingshi,KS_ppId,ks_ppname,KS_pinyin,KS_bbsid,KS_shichangjia,KS_pailiang,KS_isshengcheng,KS_Score,KS_Rnumber,KS_SSSH,KS_ZCTC,KS_lunshu,KS_QLGZ,KS_HLGZ,KS_KXYS,KS_HBBZ,KS_BXQXH,KS_lunwang,KS_mbh,KS_pingjunjia,KS_shangjiashu,KS_shuxing,HitsByYear,HitsByYear2012,KS_tjindex,KS_cuxiaourl,KS_isNew,KS_isDianDongChe,KS_CDCLX,KS_CDCGG,KS_CDCSL,KS_CDQLX,KS_CDDY,KS_DJEDEL,KS_DJEDDY,KS_PeiJian"'这里的字段可以不区分大小写
Set LoadAllproductData=ArrayToxml2(rsFieldsStr,DataArray_,"row","LoadAllproductData")
Set Application(SiteSN&SiteSN&"_LoadAllproductData")= LoadAllproductData
Application.unLock
Else
Set LoadAllproductData = Application(SiteSN&SiteSN&"_LoadAllproductData")
End If
End Function
Public Function UpdProductArrayToxml2(productId)
If 0 = ChkClng(productId) Then Exit Function
Application.Lock
If IsObject(Application(SiteSN&SiteSN&"_LoadAllproductData")) Then
Dim GXML,objRootlist
Set GXML = Application(SiteSN&SiteSN&"_LoadAllproductData")
'删除老节点
For Each objRootlist in GXML.DocumentElement.SelectNodes("row[@id="& productId &"]")
GXML.documentElement.RemoveChild(objRootlist)'删除老数据
Next
Dim RS:Set RS=Conn.Execute("exec KS_LoadAllproductDataById " & productId)
Dim DataArray_,rsFieldsStr:DataArray_ = rs.GetRows(-1)
RS.Close:Set RS=Nothing
rsFieldsStr = "ID,ProID,Tid,KeyWords,Title,PhotoUrl,BigPhoto,Intro,ProModel,ProSpecificat,ProducerName,TrademarkName,ServiceTerm,Rank,Unit,Hits,TotalNum,AlarmNum,ProductType,Discount,Price,Price_Original,Price_Market,Price_Member,AddDate,JSID,TemplateID,Fname,RefreshTF,Recommend,Rolls,Popular,Verific,Comment,IsSpecial,IsTop,Slide,Point,DelTF,GroupPrice,BrandID,HitsByDay,HitsByWeek,HitsByMonth,LastHitsTime,Strip,ClassID,ShowOnSpace,BigClassID,SmallClassID,AttributeCart,Inputer,WapTemplateID,IsChangedBuy,ChangeBuyNeedPrice,ChangeBuyPresentPrice,IsLimitbuy,LimitBuyPrice,LimitBuyTaskID,LimitBuyAmount,weight,KS_chexing,KS_fupinpai,KS_ckg,KS_zhouju,KS_lidijianxie,KS_zuodiangao,KS_youxiangrongliang,KS_kongchezhiliang,KS_zhengbeizhiliang,KS_gangshu,KS_chonchengshu,KS_lenquefangshi,KS_yasuobi,KS_zuidagonglv,KS_zuidaniuju,KS_zuigaochesu,KS_gonyoufangshi,KS_jingjihaoyou,KS_qidongfangshi,KS_zhidongfangshi,KS_liheqixingshi,KS_ppId,ks_ppname,KS_pinyin,KS_bbsid,KS_shichangjia,KS_pailiang,KS_isshengcheng,KS_Score,KS_Rnumber,KS_SSSH,KS_ZCTC,KS_lunshu,KS_QLGZ,KS_HLGZ,KS_KXYS,KS_HBBZ,KS_BXQXH,KS_lunwang,KS_mbh,KS_pingjunjia,KS_shangjiashu,KS_shuxing,HitsByYear,HitsByYear2012,KS_tjindex,KS_cuxiaourl,KS_isNew,KS_isDianDongChe,KS_CDCLX,KS_CDCGG,KS_CDCSL,KS_CDQLX,KS_CDDY,KS_DJEDEL,KS_DJEDDY,KS_PeiJian"'这里的字段可以不区分大小写
Set UpdProductArrayToxml2=AddArrayToxml2(rsFieldsStr,DataArray_,"row","LoadAllproductData",SiteSN&SiteSN&"_LoadAllproductData")
Set Application(SiteSN&SiteSN&"_LoadAllproductData") = UpdProductArrayToxml2
End If
Application.unLock
End function
Function C_C(ClassID,FieldID)
If ClassID="" Or IsNull(ClassID) Then Exit Function
LoadClassConfig()
Dim Node:Set Node=Application(SiteSN&"_class").documentElement.selectSingleNode("class[@ks0=" & classID & "]/@ks" & FieldID & "")
If Not Node Is Nothing Then C_C=Node.text
Set Node=Nothing
End Function
'加载品牌缓存
Sub LoadBrandCache()
If Not IsObject(Application(SiteSN&"_ClassBrand")) Then
Application.Lock
'Dim RS:Set Rs=conn.execute("select id,BrandName,BrandEname,PhotoUrl From KS_ClassBrand Order by ID")
'Set Application(SiteSN&"_ClassBrand")=RsToxml(rs,"row","classbrand")
'Set Rs=Nothing
Dim RS:Set Rs=conn.execute("PRO_LoadBrandCache")
Dim rsFieldsStr,DataArray_:DataArray_ = rs.GetRows(-1)
rs.close:Set Rs=Nothing
rsFieldsStr = "id,BrandName,BrandEname,PhotoUrl"
rsFieldsStr = LCase(rsFieldsStr)
Set Application(SiteSN&"_ClassBrand")=RsToxml2(rsFieldsStr,DataArray_,"row","classbrand")
Application.unLock
End If
End Sub
Function C_B(BrandID,FieldName)
If BrandID="" Or IsNull(BrandID) Then Exit Function
LoadBrandCache()
Dim Node:Set Node=Application(SiteSN&"_classbrand").documentElement.selectSingleNode("row[@id=" & BrandID & "]/@" & LCase(FieldName) & "")
If Not Node Is Nothing Then C_B=Node.text
Set Node=Nothing
End Function
'加载用户组缓存
Sub LoadUserGroup()
If Not IsObject(Application(SiteSN&"_UserGroup")) Then
Application.Lock
'Dim RS:Set Rs=conn.execute("select id,groupname,powerlist,descript,usertype,formid,templatefile,showonreg,ChargeType,GroupPoint,GroupSetting From KS_UserGroup Order by ID")
'Set Application(SiteSN&"_UserGroup")=RsToxml(rs,"row","groupConfig")
Dim RS:Set Rs=conn.execute("PRO_LoadUserGroup")
Dim rsFieldsStr,DataArray_:DataArray_ = rs.GetRows(-1)
rs.close:Set Rs=Nothing
rsFieldsStr = "id,groupname,powerlist,descript,usertype,formid,templatefile,showonreg,ChargeType,GroupPoint,GroupSetting"
rsFieldsStr = LCase(rsFieldsStr)
Set Application(SiteSN&"_UserGroup")=RsToxml2(rsFieldsStr,DataArray_ ,"row","groupConfig")
Set Rs=Nothing
Application.unLock
End If
End Sub
'获取用户组特殊权限
Function U_S(GroupID,i)
If IsNul(GroupID) Then U_S=0 : Exit Function
Dim GroupSetting:GroupSetting=U_G(GroupID,"GroupSetting") &",0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0"
Dim GroupSetArr:GroupSetArr=Split(GroupSetting,",")
U_S=GroupSetArr(i)
End Function
Function U_G(GroupID,FieldName)
If IsNul(GroupID) Then Exit Function
LoadUserGroup
Dim Node:Set Node=Application(SiteSN&"_UserGroup").DocumentElement.selectSingleNode("row[@id=" & GroupID & "]/@" & Lcase(FieldName))
If Not Node Is Nothing Then U_G=Node.text
Set Node=Nothing
End Function
'加载论坛/问答等级
Sub LoadAskGrade()
If Not IsObject(Application(SiteSN&"_AskGrade")) Then
Application.Lock
'Dim RS:Set Rs=conn.execute("select gradeid,UserTitle,score,Ico,ClubPostNum,Color,TypeFlag,Special From KS_AskGrade Order by GradeID")
'Set Application(SiteSN&"_AskGrade")=RsToxml(rs,"row","AskGrade")
'Set Rs=Nothing
Dim RS:Set Rs=conn.execute("PRO_LoadAskGrade")
Dim rsFieldsStr,DataArray_:DataArray_ = rs.GetRows(-1)
rs.close:Set Rs=Nothing
rsFieldsStr = "gradeid,UserTitle,score,Ico,ClubPostNum,Color,TypeFlag,Special"
rsFieldsStr = LCase(rsFieldsStr)
Set Application(SiteSN&"_AskGrade")=RsToxml2(rsFieldsStr,DataArray_,"row","AskGrade")
Application.unLock
End If
End Sub
'取KS_AskGrade表的配置
Function A_G(GradeID,FieldName)
If IsNul(GradeID) Then Exit Function
LoadAskGrade
Dim Node:Set Node=Application(SiteSN&"_AskGrade").DocumentElement.selectSingleNode("row[@gradeid=" & GradeID & "]/@" & Lcase(FieldName))
If Not Node Is Nothing Then A_G=Node.text
Set Node=Nothing
End Function
'加载留言版面缓存
Sub LoadClubBoard()
If Not IsObject(Application(SiteSN&"_ClubBoard")) Then
Application.Lock
'Dim RS:Set Rs=conn.execute("select [id],[boardname],[note],[master],[todaynum],[postnum],[topicnum],[parentid],[LastPost],[BoardRules],[Settings] From KS_GuestBoard Where Locked<>1 Order by orderid,ID")
'Set Application(SiteSN&"_ClubBoard")=RsToxml(rs,"row","clubConfig")
'Set Rs=Nothing
Dim RS:Set Rs=conn.execute("PRO_LoadClubBoard")
Dim rsFieldsStr,DataArray_:DataArray_ = rs.GetRows(-1)
rs.close:Set Rs=Nothing
rsFieldsStr = "id,boardname,note,master,todaynum,postnum,topicnum,parentid,LastPost,BoardRules,Settings"
rsFieldsStr = LCase(rsFieldsStr)
Set Application(SiteSN&"_ClubBoard")=RsToxml2(rsFieldsStr,DataArray_,"row","clubConfig")
Application.unLock
End If
End Sub
Sub LoadClubBoardCategory()
If Not IsObject(Application(SiteSN&"_ClubBoardCategory")) Then
Application.Lock
'Dim RS:Set Rs=conn.execute("select [categoryid],[categoryname],[BoardID],[ico] From KS_GuestCategory Where Status=1 Order by orderid,CategoryID")
'Set Application(SiteSN&"_ClubBoardCategory")=RsToxml(rs,"row","boardcategory")
'Set Rs=Nothing
Dim RS:Set Rs=conn.execute("PRO_LoadClubBoardCategory")
Dim rsFieldsStr,DataArray_:DataArray_ = rs.GetRows(-1)
rs.close:Set Rs=Nothing
rsFieldsStr = "categoryid,categoryname,BoardID,ico"
rsFieldsStr = LCase(rsFieldsStr)
Set Application(SiteSN&"_ClubBoardCategory")=RsToxml2(rsFieldsStr,DataArray_,"row","classbrand")
Application.unLock
End If
End Sub
'**************************************************
'函数名：LoadClassOption
'作 用：加载栏目选项
'参 数：ChannelID-----当前模型ID,ShowPub 不允许发布的栏目显示灰色
'返回值：整棵树
'**************************************************
Public Function LoadClassOption(ChannelID,ShowPub)
Dim Node,K,SQL,NodeText,Pstr,TJ,SpaceStr,TreeStr,nbsp
LoadClassConfig()
If ChannelID<>0 Then Pstr="and @ks12=" & channelid & ""
For Each Node In Application(SiteSN&"_class").DocumentElement.SelectNodes("class[@ks14=1" & Pstr&"]")
SpaceStr=""
If (C("SuperTF")=1 or FoundInArr(Node.SelectSingleNode("@ks16").text,C("AdminName"),",") or Instr(C("ModelPower"),C_S(Node.SelectSingleNode("@ks12").text,10)&"1")>0) and (C_S(Node.SelectSingleNode("@ks12").text,21)=1 or Node.SelectSingleNode("@ks12").text=5) Then
TJ=Node.SelectSingleNode("@ks10").text
If TJ>1 Then
For k = 1 To TJ - 1
SpaceStr = SpaceStr & "──"
Next
End If
If ShowPub=true Then
If Node.SelectSingleNode("@ks20").text="1" Then
TreeStr = TreeStr & ""
Else
TreeStr = TreeStr & "