" & vbCrLf
strHTML = strHTML & "" & vbCrLf
Else
If Source = "" Then
Call ShowWap(0, 0, 0, 0)
Else
Source = ReplaceBadChar(Source)
Call ProSource(Source)
End If
End If
strHTML = strHTML & "" & vbCrLf
Response.Write unicode(strHTML)
End Sub
'**************************************************
'函数名:ProSource
'作 用:参数处理
'**************************************************
Sub ProSource(ByVal iText)
Dim StrRow, Mtype, ChannelID, ArticleID, ClassID
StrRow = Split(iText, "|")
Action = StrRow(0)
ChannelID = StrRow(1)
If ChannelID = "" Then
ChannelID = 0
Else
ChannelID = PE_CLng(ChannelID)
End If
If ChannelID > 0 Then
GetChannel (ChannelID)
End If
Select Case Action
Case "ChannelList"
Call ShowWap(ChannelID, 0, 0, 0)
Case "ClassList"
ClassID = StrRow(2)
If ClassID = "" Then
ClassID = 0
Else
ClassID = PE_CLng(ClassID)
End If
Call ShowWap(ChannelID, ClassID, 0, 0)
Case "ShowArticle"
ArticleID = StrRow(2)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Call ShowArticle(ChannelID, ArticleID, StrRow(3))
Case "ShowSoft"
ArticleID = StrRow(2)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Call ShowSoft(32, ChannelID, ArticleID)
Case "ShowPhoto"
ArticleID = StrRow(2)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Call ShowPhoto(32, ChannelID, ArticleID)
Case "ShowProduct"
ArticleID = StrRow(2)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Call ShowProduct(32, ChannelID, ArticleID)
Case "AComment"
Mtype = StrRow(2)
If Mtype = "" Then
Mtype = 1
Else
Mtype = PE_CLng(Mtype)
End If
ClassID = StrRow(3)
If ClassID = "" Then
ClassID = 0
Else
ClassID = PE_CLng(ClassID)
End If
ArticleID = StrRow(4)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Call Comment(0, ArticleID, ChannelID, Mtype, ClassID)
Case "AComment2"
Mtype = StrRow(2)
If Mtype = "" Then
Mtype = 1
Else
Mtype = PE_CLng(Mtype)
End If
ClassID = StrRow(3)
If ClassID = "" Then
ClassID = 1
Else
ClassID = PE_CLng(ClassID)
End If
ArticleID = StrRow(4)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Call Comment(1, ArticleID, ChannelID, Mtype, ClassID)
Case "CommentSave"
Mtype = StrRow(2)
If Mtype = "" Then
Mtype = 1
Else
Mtype = PE_CLng(Mtype)
End If
ArticleID = StrRow(3)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Call CommentSave(ChannelID, Mtype, ArticleID, StrRow(4), StrRow(5), StrRow(6))
Case "AFuJian"
ArticleID = StrRow(2)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Call Appendix(ChannelID, ArticleID)
Case "dg"
ArticleID = StrRow(2)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Call dg(ChannelID, ArticleID)
Case "dgacept"
ArticleID = StrRow(2)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Dim iID
If StrRow(3) = "" Then
iID = 0
Else
iID = PE_CLng(StrRow(3))
End If
Call dgacept(ChannelID, ArticleID, iID, StrRow(4), StrRow(5), StrRow(6), StrRow(7))
Case "getjynum"
ArticleID = StrRow(2)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Call getjynum(ChannelID, ArticleID, 1, "none", "none")
Case "getjynum2"
ArticleID = StrRow(2)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Call getjynum(ChannelID, ArticleID, 2, StrRow(3), StrRow(4))
Case "ManageLogin"
Call ManageLogin(ChannelID, StrRow(2), StrRow(3))
Case "ChannelManage"
Call ChannelManage(ChannelID, StrRow(2), StrRow(3))
Case "ArticlePass"
ArticleID = StrRow(2)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Call ArticlePass(ChannelID, ArticleID, StrRow(3), StrRow(4))
Case "SoftPass"
ArticleID = StrRow(2)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Call SoftPass(ChannelID, ArticleID, StrRow(3), StrRow(4))
Case "PhotoPass"
ArticleID = StrRow(2)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Call PhotoPass(ChannelID, ArticleID, StrRow(3), StrRow(4))
Case "GuestPass"
ArticleID = StrRow(2)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Call GuestPass(ChannelID, ArticleID, StrRow(3), StrRow(4))
Case "ProductPass"
ArticleID = StrRow(2)
If ArticleID = "" Then
ArticleID = 0
Else
ArticleID = PE_CLng(ArticleID)
End If
Call ProductPass(ChannelID, ArticleID, StrRow(3), StrRow(4))
End Select
End Sub
'**************************************************
'前台浏览部分开始
'**************************************************
Sub ShowWap(ByVal iChannelID, ByVal iClassID, ByVal iHot, ByVal iElite)
Dim sqlChannel, rsChannel, sqlArticle, rsArticle, ModuleType, HitsOfHot
strHTML = strHTML & "" & vbCrLf
If iChannelID = 0 Then '如果是显示首页
sqlChannel = "select ChannelID,OrderID,ChannelName,ChannelDir,ModuleType,ChannelType,Disabled from PE_Channel where Disabled = " & PE_False & " and ChannelType<2 order by OrderID"
Set rsChannel = Conn.Execute(sqlChannel)
If rsChannel.BOF And rsChannel.EOF Then
strHTML = strHTML & "
" & SiteLogo & vbCrLf
Do While Not rsChannel.EOF
If rsChannel("ModuleType") = 1 Or rsChannel("ModuleType") = 2 Or rsChannel("ModuleType") = 3 Or rsChannel("ModuleType") = 5 Then
If rsChannel("ModuleType") = 5 Then
strHTML = strHTML & " " & rsChannel("ChannelName") & "" & vbCrLf
Else
strHTML = strHTML & " " & rsChannel("ChannelName") & "" & vbCrLf
End If
End If
rsChannel.MoveNext
Loop
If ShowWapManage = True Then strHTML = strHTML & " ----- " & XmlText("Wap", "ManageLogin", "-管理登录-") & "" & vbCrLf
End If
strHTML = strHTML & "
" & XmlText("Wap", "News", "-最新更新-") & vbCrLf
Set rsChannel = Conn.Execute("select ChannelName,ChannelDir,ModuleType,HitsOfHot,UploadDir from PE_Channel where ChannelID=" & iChannelID & " and Disabled = " & PE_False & " and ChannelType<2 order by OrderID")
ChannelName = rsChannel("ChannelName")
ChannelDir = rsChannel("ChannelDir")
ModuleType = rsChannel("ModuleType")
HitsOfHot = rsChannel("HitsOfHot")
UploadDir = rsChannel("UploadDir")
rsChannel.Close
Set rsChannel = Nothing
Select Case ModuleType
Case 1
sqlArticle = "select top 12 A.ArticleID,A.ChannelID,A.ClassID,A.Title,A.Hits,A.UpdateTime,A.Elite,A.Status,A.IncludePic,A.LinkUrl,A.Deleted,C.ClassPurview from PE_Article A inner join PE_Class C on A.ClassID=C.ClassID Where A.ChannelID=" & iChannelID & " and C.ClassPurview<2"
If iClassID <> 0 Then sqlArticle = sqlArticle & " and A.ClassID=" & iClassID
sqlArticle = sqlArticle & " and A.Status=3 and A.Deleted=" & PE_False
If iHot = 1 Then
sqlArticle = sqlArticle & " order by A.Hits Desc"
ElseIf iElite = 1 Then
sqlArticle = sqlArticle & " order by A.Elite " & PE_OrderType & ",A.UpdateTime Desc"
Else
sqlArticle = sqlArticle & " order by A.UpdateTime Desc"
End If
Set rsArticle = Conn.Execute(sqlArticle)
If Not (rsArticle.BOF And rsArticle.EOF) Then
Do While Not rsArticle.EOF
If rsArticle(9) = "" Then
strHTML = strHTML & " " & ReplaceText(GetSubStr(xml_nohtml(rsArticle(3)), 20, False), 2) & ""
If rsArticle(8) > 0 Then strHTML = strHTML & "-图" & vbCrLf
If rsArticle(4) > HitsOfHot Then strHTML = strHTML & "-热" & vbCrLf
If rsArticle(6) = True Then strHTML = strHTML & "-荐" & vbCrLf
End If
rsArticle.MoveNext
Loop
Else
strHTML = strHTML & "无文章" & vbCrLf
End If
rsArticle.Close
Case 2
sqlArticle = "select top 12 A.SoftID,A.ChannelID,A.ClassID,A.SoftName,A.Hits,A.UpdateTime,A.Elite,A.Status,A.Deleted,C.ClassPurview from PE_Soft A inner join PE_Class C on A.ClassID=C.ClassID Where A.ChannelID=" & iChannelID & " and C.ClassPurview<2"
If iClassID <> 0 Then sqlArticle = sqlArticle & " and A.ClassID=" & iClassID
sqlArticle = sqlArticle & " and A.Status=3 and A.Deleted=" & PE_False
If iHot = 1 Then
sqlArticle = sqlArticle & " order by A.Hits Desc"
ElseIf iElite = 1 Then
sqlArticle = sqlArticle & " order by A.Elite " & PE_OrderType & ",A.UpdateTime Desc"
Else
sqlArticle = sqlArticle & " order by A.UpdateTime Desc"
End If
Set rsArticle = Conn.Execute(sqlArticle)
If Not (rsArticle.BOF And rsArticle.EOF) Then
Do While Not rsArticle.EOF
strHTML = strHTML & " " & GetSubStr(xml_nohtml(rsArticle(3)), 20, False) & ""
If rsArticle(6) = True Then strHTML = strHTML & "-荐" & vbCrLf
If rsArticle(4) > HitsOfHot Then strHTML = strHTML & "-热" & vbCrLf
rsArticle.MoveNext
Loop
Else
strHTML = strHTML & "无下载" & vbCrLf
End If
rsArticle.Close
Case 3
sqlArticle = "select top 12 A.PhotoID,A.ChannelID,A.ClassID,A.PhotoName,A.Hits,A.UpdateTime,A.Elite,A.Status,A.Deleted,C.ClassPurview from PE_Photo A inner join PE_Class C on A.ClassID=C.ClassID Where A.ChannelID=" & iChannelID & " and C.ClassPurview<2"
If iClassID <> 0 Then sqlArticle = sqlArticle & " and A.ClassID=" & iClassID
sqlArticle = sqlArticle & " and A.Status=3 and A.Deleted=" & PE_False
If iHot = 1 Then
sqlArticle = sqlArticle & " order by A.Hits Desc"
ElseIf iElite = 1 Then
sqlArticle = sqlArticle & " order by A.Elite " & PE_OrderType & ",A.UpdateTime Desc"
Else
sqlArticle = sqlArticle & " order by A.UpdateTime Desc"
End If
Set rsArticle = Conn.Execute(sqlArticle)
If Not (rsArticle.BOF And rsArticle.EOF) Then
Do While Not rsArticle.EOF
strHTML = strHTML & " " & GetSubStr(xml_nohtml(rsArticle(3)), 20, False) & ""
If rsArticle(6) = True Then strHTML = strHTML & "-荐" & vbCrLf
If rsArticle(4) > HitsOfHot Then strHTML = strHTML & "-热" & vbCrLf
rsArticle.MoveNext
Loop
Else
strHTML = strHTML & "无图片" & vbCrLf
End If
rsArticle.Close
Case 5
sqlArticle = "select top 12 ProductID,ChannelID,ClassID,ProductName,IsHot,IsElite,UpdateTime,Hits,Deleted from PE_Product Where ChannelID=" & iChannelID
If iClassID <> 0 Then sqlArticle = sqlArticle & " and ClassID=" & iClassID
sqlArticle = sqlArticle & " and Deleted=" & PE_False
If iHot = 1 Then
sqlArticle = sqlArticle & " order by Hits Desc"
ElseIf iElite = 1 Then
sqlArticle = sqlArticle & " order by IsElite " & PE_OrderType & ",UpdateTime Desc"
Else
sqlArticle = sqlArticle & " order by UpdateTime Desc"
End If
Set rsArticle = Conn.Execute(sqlArticle)
If Not (rsArticle.BOF And rsArticle.EOF) Then
Do While Not rsArticle.EOF
strHTML = strHTML & " " & GetSubStr(xml_nohtml(rsArticle(3)), 20, False) & ""
If rsArticle(4) = True Then strHTML = strHTML & "-热" & vbCrLf
If rsArticle(5) = True Then strHTML = strHTML & "-荐" & vbCrLf
rsArticle.MoveNext
Loop
Else
strHTML = strHTML & "无商品" & vbCrLf
End If
rsArticle.Close
End Select
Set rsArticle = Nothing
strHTML = strHTML & "
" & vbCrLf
strHTML = strHTML & GetChildClass(iChannelID, iClassID)
End If
strHTML = strHTML & "" & vbCrLf
End Sub
Function GetChildClass(ByVal iChannelID, ByVal iClassID)
Dim rsClass, strtmp
strtmp = "
-子栏目-" & vbCrLf
If iClassID = 0 Then
Set rsClass = Conn.Execute("select ClassID,ClassName,Child from PE_Class where ChannelID=" & iChannelID & " and ClassType=1 and ParentID =0")
If Not (rsClass.BOF And rsClass.EOF) Then
Do While Not rsClass.EOF
strtmp = strtmp & " [" & rsClass("ClassName") & "]" & vbCrLf
rsClass.MoveNext
Loop
End If
strtmp = strtmp & " [首页]" & vbCrLf
Else
Set rsClass = Conn.Execute("select ClassID,ClassName,Child from PE_Class where ParentID=" & iClassID & " and ClassType=1 order by OrderID")
If rsClass.BOF And rsClass.EOF Then
strtmp = strtmp & " [首页]" & vbCrLf
Else
Do While Not rsClass.EOF
strtmp = strtmp & " [" & rsClass("ClassName") & "]" & vbCrLf
rsClass.MoveNext
Loop
strtmp = strtmp & " [首页]" & vbCrLf
End If
End If
rsClass.Close
Set rsClass = Nothing
GetChildClass = strtmp & "
" & vbCrLf
End Function
'**************************************************
'函数名:ShowArticle
'作 用:显示文章内容
'**************************************************
Sub ShowArticle(ByVal iChannelID, ByVal iArticleID, ByVal iPage)
Dim sqlArticle, rsArticle
strHTML = strHTML & "" & vbCrLf
If iArticleID = 0 Then
strHTML = strHTML & "
无此文章!
" & vbCrLf
Else
sqlArticle = "select * from PE_Article Where ArticleID=" & iArticleID & " and Status=3 and Deleted=" & PE_False & " and InfoPoint=0"
Set rsArticle = Conn.Execute(sqlArticle)
If rsArticle.BOF And rsArticle.EOF Then
strHTML = strHTML & "
" & getpage(iChannelID, iArticleID, ReplaceText(Replace(xml_nohtml(rsArticle("Content")), "[NextPage]", ""), 1), iPage) & vbCrLf
If EnableWapPl = True Then strHTML = strHTML & " 评论" & vbCrLf
If ShowWapAppendix = True Then
If rsArticle("IncludePic") > 0 Then strHTML = strHTML & " 图片" & vbCrLf
End If
strHTML = strHTML & " 返回
" & vbCrLf
End If
rsArticle.Close
Set rsArticle = Nothing
End If
strHTML = strHTML & "" & vbCrLf
End Sub
'**************************************************
'函数名:ShowSoft
'作 用:显示下载内容
'**************************************************
Sub ShowSoft(ByVal iSize, ByVal iChannelID, ByVal iSoftID)
Dim sqlSoft, rsSoft
strHTML = strHTML & "" & vbCrLf
If iSoftID = 0 Then
strHTML = strHTML & "
无此下载!
" & vbCrLf
Else
sqlSoft = "select * from PE_Soft Where SoftID=" & iSoftID & " and Status=3 and Deleted=" & PE_False & " and InfoPoint=0"
Set rsSoft = Conn.Execute(sqlSoft)
If rsSoft.BOF And rsSoft.EOF Then
strHTML = strHTML & "
收费软件,请登录网站下载!
" & vbCrLf
Else
strHTML = strHTML & "
名称:" & GetSubStr2(xml_nohtml(rsSoft("SoftName")), iSize) & " " & vbCrLf
If Not IsNull(rsSoft("SoftVersion")) Then strHTML = strHTML & "版本:" & GetSubStr2(xml_nohtml(rsSoft("SoftVersion")), iSize) & " " & vbCrLf
If Not IsNull(rsSoft("SoftIntro")) Then strHTML = strHTML & "简介:" & GetSubStr2(xml_nohtml(rsSoft("SoftIntro")), 80) & " " & vbCrLf
strHTML = strHTML & GetDownloadUrlList(rsSoft("DownloadUrl"))
If EnableWapPl = True Then strHTML = strHTML & "评论" & vbCrLf
strHTML = strHTML & " 返回
" & vbCrLf
End If
rsSoft.Close
Set rsSoft = Nothing
End If
strHTML = strHTML & "" & vbCrLf
End Sub
'**************************************************
'函数名:ShowPhoto
'作 用:显示图片内容
'**************************************************
Sub ShowPhoto(ByVal iSize, ByVal iChannelID, ByVal iPhotoID)
Dim sqlPhoto, rsPhoto
strHTML = strHTML & "" & vbCrLf
If iPhotoID = 0 Then
strHTML = strHTML & "
无此图片!
" & vbCrLf
Else
sqlPhoto = "select * from PE_Photo Where PhotoID=" & iPhotoID & " and Status=3 and Deleted=" & PE_False & " and InfoPoint=0"
Set rsPhoto = Conn.Execute(sqlPhoto)
If rsPhoto.BOF And rsPhoto.EOF Then
strHTML = strHTML & "
收费图片,请登录网站浏览!
" & vbCrLf
Else
strHTML = strHTML & "
" & GetSubStr2(xml_nohtml(rsPhoto("PhotoName")), iSize) & " " & vbCrLf
If ShowWapAppendix = True Then
If rsPhoto("PhotoThumb") > "" Then
If Left(rsPhoto("PhotoThumb"), 4) = "http" Then
strHTML = strHTML & " " & vbCrLf
Else
strHTML = strHTML & " " & vbCrLf
End If
End If
End If
If EnableWapPl = True Then strHTML = strHTML & "评论" & vbCrLf
strHTML = strHTML & " 返回
" & vbCrLf
End If
rsPhoto.Close
Set rsPhoto = Nothing
End If
strHTML = strHTML & "" & vbCrLf
End Sub
'**************************************************
'函数名:ShowProduct
'作 用:显示商品内容
'**************************************************
Sub ShowProduct(ByVal iSize, ByVal iChannelID, ByVal iProductID)
Dim sqlProduct, rsProduct
strHTML = strHTML & "" & vbCrLf
If iProductID = 0 Then
strHTML = strHTML & "
无此商品!
" & vbCrLf
Else
sqlProduct = "select * from PE_Product Where ProductID=" & iProductID & " and EnableSale=" & PE_True & " and Deleted=" & PE_False & " and Stocks>0"
Set rsProduct = Conn.Execute(sqlProduct)
If rsProduct.BOF And rsProduct.EOF Then
strHTML = strHTML & "
无此商品!
" & vbCrLf
Else
strHTML = strHTML & "
名称:" & GetSubStr2(xml_nohtml(rsProduct("ProductName")), iSize) & " " & vbCrLf
strHTML = strHTML & "厂商:" & GetSubStr2(xml_nohtml(rsProduct("ProducerName")), iSize) & " " & vbCrLf
strHTML = strHTML & "品牌:" & GetSubStr2(xml_nohtml(rsProduct("TrademarkName")), iSize) & " " & vbCrLf
strHTML = strHTML & "原价:" & rsProduct("Price_Original") & " " & vbCrLf
strHTML = strHTML & "现价:" & rsProduct("Price") & " " & vbCrLf
If Not IsNull(rsProduct("ProductIntro")) Then strHTML = strHTML & "简介:" & GetSubStr2(xml_nohtml(rsProduct("ProductIntro")), 160) & " " & vbCrLf
If ShowWapAppendix = True Then
If rsProduct("ProductThumb") > "" Then
If Left(rsProduct("ProductThumb"), 4) = "http" Then
strHTML = strHTML & " " & vbCrLf
Else
strHTML = strHTML & " " & vbCrLf
End If
End If
End If
If EnableWapPl = True Then strHTML = strHTML & "评论" & vbCrLf
If ShowWapShop = True Then strHTML = strHTML & " 订购" & vbCrLf
strHTML = strHTML & " 返回
" & vbCrLf
End If
rsProduct.Close
Set rsProduct = Nothing
End If
strHTML = strHTML & "" & vbCrLf
End Sub
'**************************************************
'函数名:Comment
'作 用:显示或发表评论
'**************************************************
Sub Comment(ByVal iType, ByVal iID, ByVal iChannelID, ByVal iModuleType, ByVal iClassID)
Dim sqlComment, rsComment, rsClass
strHTML = strHTML & "" & vbCrLf
If iID = 0 Then
strHTML = strHTML & "
无此对象!
" & vbCrLf
Else
If iType = 0 Then
sqlComment = "select top 10 * from PE_Comment where InfoID=" & iID & " and Passed=" & PE_True & " order by WriteTime desc"
Set rsComment = Conn.Execute(sqlComment)
If rsComment.BOF And rsComment.EOF Then
strHTML = strHTML & "
" & vbCrLf
End If
rsComment.Close
Set rsComment = Nothing
Else
Set rsClass = Conn.Execute("select EnableComment,CheckComment from PE_Class Where ClassID=" & iClassID)
If rsClass.BOF And rsClass.EOF Then
strHTML = strHTML & "
本栏禁止评论!
" & vbCrLf
Else
If rsClass("EnableComment") = True Then
strHTML = strHTML & "
" & vbCrLf
Else
strHTML = strHTML & "提交" & vbCrLf
End If
Else
strHTML = strHTML & "
本栏禁止评论
" & vbCrLf
End If
End If
rsClass.Close
Set rsClass = Nothing
End If
End If
strHTML = strHTML & "" & vbCrLf
End Sub
'**************************************************
'函数名:CommentSave
'作 用:保存评论
'**************************************************
Sub CommentSave(ByVal iChannelID, ByVal iModuleType, ByVal iID, ByVal iName, ByVal iComcont, ByVal iCheck)
Dim sqlComment, rsComment
strHTML = strHTML & "" & vbCrLf
If iName = "" Or iComcont = "" Then
strHTML = strHTML & "
请填写内容!" & vbCrLf
Else
sqlComment = "Select * from PE_Comment"
Set rsComment = Server.CreateObject("Adodb.RecordSet")
rsComment.Open sqlComment, Conn, 1, 3
rsComment.addnew
rsComment("ModuleType") = iModuleType
rsComment("InfoID") = iID
rsComment("UserType") = 0
rsComment("UserName") = UTF2GB(iName)
rsComment("Sex") = 0
rsComment("WriteTime") = Now()
rsComment("Score") = 3
rsComment("Content") = UTF2GB(iComcont)
If iCheck = 1 Then
rsComment("Passed") = True
Else
rsComment("Passed") = False
End If
rsComment.Update
rsComment.Close
Set rsComment = Nothing
strHTML = strHTML & "
" & vbCrLf
Else
Dim rsUser, sqlUser
sqlUser = "select UserName,UserPassword,CheckNum from PE_User Where UserName='" & UTF2GB(iUser) & "' and UserPassword='" & MD5(iPass, 16) & "'"
Set rsUser = Conn.Execute(sqlUser)
If rsUser.BOF And rsUser.EOF Then
strHTML = strHTML & "
" & vbCrLf
End If
rsUser.Close
Set rsUser = Nothing
End If
strHTML = strHTML & "" & vbCrLf
End Sub
'**************************************************
'函数名:dg
'作 用:订购商品
'**************************************************
Sub dg(ByVal iChannelID, ByVal iID)
strHTML = strHTML & "" & vbCrLf
If iID = 0 Then
strHTML = strHTML & "
" & vbCrLf
End If
strHTML = strHTML & "" & vbCrLf
End Sub
'**************************************************
'函数名:dgacept
'作 用:确认订购商品
'**************************************************
Sub dgacept(ByVal iChannelID, ByVal iID, ByVal iNumber, ByVal ishuliang, ByVal iaddress, ByVal izipcode, ByVal iemail)
Dim trs, sqlOrder, rsOrder, rsItem, rsUser, rsProduct, OrderFormID, OrderFormNum
'得到订单ID
Set trs = Conn.Execute("select max(OrderFormID) from PE_OrderForm")
If trs.BOF And trs.EOF Then
OrderFormID = 0
Else
If IsNull(trs(0)) Then
OrderFormID = 1
Else
OrderFormID = trs(0) + 1
End If
End If
Set trs = Nothing
'得到订单编号
OrderFormNum = Prefix_OrderFormNum & GetNumString()
strHTML = strHTML & "" & vbCrLf
If iID = 0 Then
strHTML = strHTML & "
参数错! " & vbCrLf
Else
If iNumber = 0 Or ishuliang = "" Then
strHTML = strHTML & "
请填写内容!" & vbCrLf
Else
Set rsUser = Conn.Execute("select U.UserID,U.UserName,U.IsLocked,U.CheckNum,C.Address,C.Email,C.ZipCode,C.Mobile,C.OfficePhone,C.HomePhone,U.ClientID from PE_User U inner join PE_Contacter C on U.ContacterID=C.ContacterID Where U.CheckNum=" & iNumber)
If rsUser.BOF And rsUser.EOF Then
strHTML = strHTML & "
交易号码错!" & vbCrLf
Else
If rsUser(2) = True Then
strHTML = strHTML & "
您已被锁定无法完成交易!" & vbCrLf
ElseIf IsNull(rsUser(4)) Or IsNull(rsUser(5)) Or IsNull(rsUser(6)) Then
strHTML = strHTML & "
" & vbCrLf
Else
Set rsProduct = Conn.Execute("Select * from PE_Product Where ProductID= " & iID & " and Stocks>0")
If rsProduct.BOF And rsProduct.EOF Then
strHTML = strHTML & "
暂时无货!" & vbCrLf
Else
sqlOrder = "Select * from PE_OrderForm"
Set rsOrder = Server.CreateObject("Adodb.RecordSet")
rsOrder.Open sqlOrder, Conn, 1, 3
rsOrder.addnew
rsOrder("OrderFormID") = OrderFormID
rsOrder("OrderFormNum") = OrderFormNum
rsOrder("UserName") = rsUser(1)
rsOrder("ClientID") = rsUser(10)
If iaddress = "none" Then
rsOrder("Address") = rsUser(4)
Else
rsOrder("Address") = ConvChinese(iaddress)
End If
If izipcode = "none" Then
rsOrder("ZipCode") = rsUser(6)
Else
rsOrder("ZipCode") = izipcode
End If
If PhoneNumber = "" Then
rsOrder("Mobile") = rsUser(7)
Else
rsOrder("Mobile") = PhoneNumber
End If
If rsUser(8) = "" Then
rsOrder("Phone") = rsUser(9)
Else
rsOrder("Phone") = rsUser(8)
End If
If iemail = "none" Then
rsOrder("Email") = rsUser(5)
Else
rsOrder("Email") = ConvChinese(iemail)
End If
rsOrder("PaymentType") = 1
rsOrder("DeliverType") = 3
rsOrder("NeedInvoice") = False
rsOrder("InvoiceContent") = "发票抬头:"
rsOrder("Invoiced") = False
rsOrder("Remark") = "本订单通过手机订购,请尽快联系客户"
rsOrder("MoneyTotal") = rsProduct("Price") * ishuliang
rsOrder("MoneyGoods") = 0
rsOrder("PresentMoney") = 0
rsOrder("PresentExp") = 0
rsOrder("MoneyReceipt") = 0
rsOrder("BeginDate") = FormatDateTime(Date, 2)
rsOrder("InputTime") = Now()
rsOrder("Status") = 1
rsOrder("DeliverStatus") = 1
rsOrder("EnableDownload") = False
rsOrder("Discount_Payment") = rsProduct("Discount")
rsOrder("Charge_Deliver") = 1
rsOrder.Update
rsOrder.Close
rsOrder.Open "select top 1 * from PE_OrderFormItem", Conn, 1, 3
'添加进订单详细表中
rsOrder.addnew
rsOrder("ItemID") = GetItemID()
rsOrder("OrderFormID") = OrderFormID
rsOrder("ProductID") = rsProduct("ProductID")
rsOrder("SaleType") = 1
rsOrder("Price_Original") = rsProduct("Price_Original")
rsOrder("Price") = rsProduct("Price")
rsOrder("TruePrice") = rsProduct("Price")
rsOrder("Amount") = ishuliang
rsOrder("Subtotal") = rsProduct("Price") * ishuliang
rsOrder("Remark") = "手机订购"
rsOrder("BeginDate") = FormatDateTime(Date, 2)
rsOrder("ServiceTerm") = rsProduct("ServiceTerm")
rsOrder("PresentExp") = rsProduct("PresentExp")
rsOrder.Update
rsOrder.Close
Set rsOrder = Nothing
strHTML = strHTML & "
成功!订单编号: " & vbCrLf
strHTML = strHTML & OrderFormNum & vbCrLf
End If
rsProduct.Close
Set rsProduct = Nothing
End If
End If
rsUser.Close
Set rsUser = Nothing
End If
strHTML = strHTML & " 返回
" & vbCrLf
End If
strHTML = strHTML & "" & vbCrLf
End Sub
Function GetItemID()
Dim trs
Set trs = Conn.Execute("select max(ItemID) from PE_OrderFormItem")
If IsNull(trs(0)) Then
GetItemID = 1
Else
GetItemID = trs(0) + 1
End If
Set trs = Nothing
End Function
'**************************************************
'网站管理部分开始
'**************************************************
Sub ManageLogin(ByVal iStep, ByVal iUsername, ByVal iPassword)
strHTML = strHTML & "" & vbCrLf
If iStep = 0 Or iStep = 1 Then
strHTML = strHTML & "
" & UTF2GB(iUsername) & "您好:" & vbCrLf
sqlChannel = "select ChannelID,OrderID,ChannelName,ChannelShortName,ChannelDir,ModuleType,Disabled from PE_Channel where Disabled = " & PE_False & " order by OrderID"
Set rsChannel = Conn.Execute(sqlChannel)
Do While Not rsChannel.EOF
If rsChannel("ModuleType") > 0 And rsChannel("ModuleType") < 6 Then
strHTML = strHTML & " " & rsChannel("ChannelShortName") & "管理" & vbCrLf
End If
rsChannel.MoveNext
Loop
rsChannel.Close
Set rsChannel = Nothing
End If
strHTML = strHTML & " ----- 退出管理
" & vbCrLf
End If
strHTML = strHTML & "" & vbCrLf
End Sub
Sub ChannelManage(ByVal iChannelID, ByVal iUsername, ByVal iPassword)
Dim rsChannel, sqlChannel, rsArticle, sqlArticle, ModuleType
strHTML = strHTML & "" & vbCrLf
If CheckAdmin(iUsername, iPassword) = False Then
strHTML = strHTML & "
权限不足,请登录网站管理!" & vbCrLf
Else
sqlChannel = "select ChannelID,OrderID,ModuleType,Disabled from PE_Channel where ChannelID=" & iChannelID & " and Disabled = " & PE_False & " order by OrderID"
Set rsChannel = Conn.Execute(sqlChannel)
If rsChannel.BOF And rsChannel.EOF Then
strHTML = strHTML & "
待审列表:"
Select Case ModuleType
Case 1
sqlArticle = "select ArticleID,ChannelID,Title,Status from PE_Article Where ChannelID=" & iChannelID & " and Status=0 order by UpdateTime desc"
Set rsArticle = Conn.Execute(sqlArticle)
If Not (rsArticle.BOF And rsArticle.EOF) Then
Do While Not rsArticle.EOF
strHTML = strHTML & " " & xml_nohtml(rsArticle("Title")) & ""
rsArticle.MoveNext
Loop
Else
strHTML = strHTML & " 无未审核文章" & vbCrLf
End If
Case 2
sqlArticle = "select SoftID,ChannelID,SoftName,Status from PE_Soft Where ChannelID=" & iChannelID & " and Status=0 order by UpdateTime desc"
Set rsArticle = Conn.Execute(sqlArticle)
If Not (rsArticle.BOF And rsArticle.EOF) Then
Do While Not rsArticle.EOF
strHTML = strHTML & " " & xml_nohtml(rsArticle("SoftName")) & ""
rsArticle.MoveNext
Loop
Else
strHTML = strHTML & " 无未审核软件" & vbCrLf
End If
Case 3
sqlArticle = "select PhotoID,ChannelID,PhotoName,Status from PE_Photo Where ChannelID=" & iChannelID & " and Status=0 order by UpdateTime desc"
Set rsArticle = Conn.Execute(sqlArticle)
If Not (rsArticle.BOF And rsArticle.EOF) Then
Do While Not rsArticle.EOF
strHTML = strHTML & " " & xml_nohtml(rsArticle("PhotoName")) & ""
rsArticle.MoveNext
Loop
Else
strHTML = strHTML & " 无未审核图片" & vbCrLf
End If
Case 4
sqlArticle = "select top 20 * from PE_GuestBook Where GuestIsPassed=" & PE_False & " order by GuestDatetime desc"
Set rsArticle = Conn.Execute(sqlArticle)
If Not (rsArticle.BOF And rsArticle.EOF) Then
Do While Not rsArticle.EOF
strHTML = strHTML & " " & xml_nohtml(rsArticle("GuestTitle")) & ""
rsArticle.MoveNext
Loop
Else
strHTML = strHTML & " 无未审核留言" & vbCrLf
End If
Case 5
sqlArticle = "select ProductID,ChannelID,ProductName,EnableSale from PE_Product Where ChannelID=" & iChannelID & " and EnableSale=" & PE_False & " order by UpdateTime desc"
Set rsArticle = Conn.Execute(sqlArticle)
If Not (rsArticle.BOF And rsArticle.EOF) Then
Do While Not rsArticle.EOF
strHTML = strHTML & " " & xml_nohtml(rsArticle("ProductName")) & ""
rsArticle.MoveNext
Loop
Else
strHTML = strHTML & " 无停止销售商品" & vbCrLf
End If
End Select
rsArticle.Close
Set rsArticle = Nothing
End If
rsChannel.Close
Set rsChannel = Nothing
End If
strHTML = strHTML & " ----- 退出管理
" & vbCrLf
strHTML = strHTML & "" & vbCrLf
End Sub
Sub ArticlePass(ByVal iChannelID, ByVal iArticleID, ByVal iUsername, ByVal iPassword)
If CheckAdmin(iUsername, iPassword) = False Then
strHTML = strHTML & "" & vbCrLf
strHTML = strHTML & "
" & vbCrLf
strHTML = strHTML & "" & vbCrLf
Else
Conn.Execute ("update PE_Product set EnableSale=" & PE_True & " where ProductID=" & iArticleID & "")
Call ChannelManage(iChannelID, iUsername, iPassword)
End If
End Sub
'**************************************************
'通用函数部分开始
'**************************************************
'**************************************************
'函数名:GetSubStr2
'作 用:截字符串且不替换空格,汉字一个算两个字符,英文算一个字符
'**************************************************
Function GetSubStr2(ByVal str, ByVal strlen)
If str = "" Then
GetSubStr2 = ""
Exit Function
End If
Dim l, t, c, i, strTemp
str = Replace(Replace(Replace(Replace(str, " ", " "), """, Chr(34)), ">", ">"), "<", "<")
l = Len(str)
t = 0
strTemp = str
strlen = PE_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 & "…"
End If
GetSubStr2 = Replace(Replace(Replace(strTemp, Chr(34), """), ">", ">"), "<", "<")
End Function
'**************************************************
'函数名:getpage
'作 用:根据字数分页函数(文章内容专用)
'**************************************************
Function getpage(ByVal iChannelID, ByVal iArticleID, ByVal str, ByVal PageNum)
Dim StartWord, Length, PageAll, strlen, i, textmp
StartWord = 1
strlen = 160 '每页字数
Length = Len(str) '要显示内容的总的长度
PageAll = (Length + strlen - 1) \ strlen '该篇新闻总共可分的总页数
i = PageNum '第几页的标记
textmp = Mid(str, StartWord + i * strlen, strlen)
If 0 <= i < PageAll Then
textmp = textmp & " (" & i + 1 & "/" & PageAll & ")"
If CInt(i) < CInt(PageAll) - 1 Then
textmp = textmp & " 下页"
End If
If CInt(i) > 0 Then
textmp = textmp & " 上页"
End If
textmp = textmp & " 返回列表" & vbCrLf
End If
getpage = textmp
End Function
'**************************************************
'函数名:UTF2GB
'作 用:将UTF-8转换为GB2312码
'**************************************************
Function UTF2GB(ByVal UTFStr)
Dim Dig, GBStr
For Dig = 1 To Len(UTFStr)
If Mid(UTFStr, Dig, 1) = "%" Then
If Len(UTFStr) >= Dig + 8 Then
GBStr = GBStr & ConvChinese(Mid(UTFStr, Dig, 9))
Dig = Dig + 8
Else
GBStr = GBStr & Mid(UTFStr, Dig, 1)
End If
Else
GBStr = GBStr & Mid(UTFStr, Dig, 1)
End If
Next
UTF2GB = GBStr
End Function
Function ConvChinese(ByVal x)
Dim a, i, j, DigS, unicode
a = Split(Mid(x, 2), "%")
i = 0
j = 0
For i = 0 To UBound(a)
a(i) = c16to2(a(i))
Next
For i = 0 To UBound(a) - 1
DigS = InStr(a(i), "0")
unicode = ""
For j = 1 To DigS - 1
If j = 1 Then
a(i) = Right(a(i), Len(a(i)) - DigS)
unicode = unicode & a(i)
Else
i = i + 1
a(i) = Right(a(i), Len(a(i)) - 2)
unicode = unicode & a(i)
End If
Next
If Len(c2to16(unicode)) = 4 Then
ConvChinese = ConvChinese & ChrW(Int("&H" & c2to16(unicode)))
Else
ConvChinese = ConvChinese & Chr(Int("&H" & c2to16(unicode)))
End If
Next
End Function
Function c2to16(ByVal x)
Dim i
i = 1
For i = 1 To Len(x) Step 4
c2to16 = c2to16 & Hex(c2to10(Mid(x, i, 4)))
Next
End Function
Function c2to10(ByVal x)
Dim i
c2to10 = 0
If x = "0" Then Exit Function
i = 0
For i = 0 To Len(x) - 1
If Mid(x, Len(x) - i, 1) = "1" Then c2to10 = c2to10 + 2 ^ (i)
Next
End Function
Function c16to2(ByVal x)
Dim i, tempstr
i = 0
For i = 1 To Len(Trim(x))
tempstr = c10to2(CInt(Int("&h" & Mid(x, i, 1))))
Do While Len(tempstr) < 4
tempstr = "0" & tempstr
Loop
c16to2 = c16to2 & tempstr
Next
End Function
Function c10to2(ByVal x)
Dim mysign, DigS, tempnum, i
mysign = Sgn(x)
x = Abs(x)
DigS = 1
Do
If x < 2 ^ DigS Then
Exit Do
Else
DigS = DigS + 1
End If
Loop
tempnum = x
i = 0
For i = DigS To 1 Step -1
If tempnum >= 2 ^ (i - 1) Then
tempnum = tempnum - 2 ^ (i - 1)
c10to2 = c10to2 & "1"
Else
c10to2 = c10to2 & "0"
End If
Next
If mysign = -1 Then c10to2 = "-" & c10to2
End Function
'**************************************************
'函数名:CheckAdmin
'作 用:验证管理员身份
'**************************************************
Function CheckAdmin(ByVal iName, ByVal iWord)
Dim rsUser, sqlUser
CheckAdmin = False
sqlUser = "select * from PE_Admin Where UserName='" & UTF2GB(iName) & "' and Password='" & MD5(iWord, 16) & "' and Purview=1"
Set rsUser = Conn.Execute(sqlUser)
If rsUser.BOF And rsUser.EOF Then
CheckAdmin = False
Else
CheckAdmin = True
End If
rsUser.Close
Set rsUser = Nothing
End Function
'**************************************************
'函数名:ReplaceText
'作 用:过滤非法字符串
'参 数:iText-----输入字符串
'返回值:替换后字符串
'**************************************************
Function ReplaceText(iText, iType)
Dim rText, rsKey, sqlKey, i, Keyrow, Keycol
If PE_Cache.GetValue("Site_ReplaceText") = "" Then
Set rsKey = Server.CreateObject("Adodb.RecordSet")
sqlKey = "Select Source,ReplaceText,OpenType,ReplaceType,Priority from PE_KeyLink where isUse=1 and LinkType=1 order by Priority"
rsKey.Open sqlKey, Conn, 1, 1
If Not (rsKey.BOF And rsKey.EOF) Then
PE_Cache.SetValue "Site_ReplaceText", rsKey.GetString(, , "|||", "@@@", "")
rsKey.Close
Set rsKey = Nothing
Else
rsKey.Close
Set rsKey = Nothing
ReplaceText = iText
Exit Function
End If
End If
rText = iText
Keyrow = Split(PE_Cache.GetValue("Site_ReplaceText"), "@@@")
For i = 0 To UBound(Keyrow) - 1
Keycol = Split(Keyrow(i), "|||")
If Int(Keycol(3)) = 0 Or Int(Keycol(3)) = iType Then rText = PE_Replace(rText, Keycol(0), Keycol(1))
Next
ReplaceText = rText
End Function
Function GetDownloadUrlList(DownloadUrls)
Dim arrDownloadUrls, arrUrls, iTemp, strUrls
Dim rsDownServer, sqlDownServer, ShowServerName, iShowModule
If DownloadUrls = "" Then
GetDownloadUrlList = ""
Exit Function
End If
strUrls = ""
If InStr(DownloadUrls, "@@@") > 0 Then
'构建镜像服务器下载地址列表
arrDownloadUrls = Trim(Replace(DownloadUrls, "@@@", "")) '得PE_Soft中的Url地址
sqlDownServer = "select * from PE_DownServer"
Set rsDownServer = Server.CreateObject("adodb.recordset")
rsDownServer.Open sqlDownServer, Conn, 1, 3
If rsDownServer.BOF Or rsDownServer.EOF Then
strUrls = "对不起,未找到任何镜像服务器信息!"
End If
Do While Not rsDownServer.EOF
If rsDownServer("ShowType") = 0 Then
ShowServerName = rsDownServer("ServerName")
Else
ShowServerName = ""
End If
'设置了下载点数的处理(PE_DownServer中有收费相关字段)
If rsDownServer("InfoPoint") = 0 Then
strUrls = strUrls & "" & ShowServerName & " "
End If
rsDownServer.MoveNext
Loop
GetDownloadUrlList = strUrls
rsDownServer.Close
Set rsDownServer = Nothing
Else
arrDownloadUrls = Split(DownloadUrls, "$$$")
For iTemp = 0 To UBound(arrDownloadUrls)
arrUrls = Split(arrDownloadUrls(iTemp), "|")
If UBound(arrUrls) >= 1 Then
If arrUrls(1) <> "" And arrUrls(1) <> "http://" Then
If Left(arrUrls(1), 1) <> "/" And InStr(arrUrls(1), "://") <= 0 Then
strUrls = strUrls & "" & arrUrls(0) & " "
Else
strUrls = strUrls & "" & arrUrls(0) & " "
End If
End If
End If
Next
GetDownloadUrlList = strUrls
End If
End Function
%>