classcommon.asp

依蓝旅游网站管理系统Elan2008.SP2

   Public Function GetParentPath(ByVal ChannelID, ByVal ChannelDir, ByVal ClassID)
      Dim ParentCmd, ArrParent, i
	  Dim RetString, StrPath
	  ClassID = ELClng(ClassID)
	  If ClassID = 0 Then Exit Function
	  Call InitCommand(ParentCmd, "EL_SP_ClassParentPath")
	  With ParentCmd
	     .Parameters.Append .CreateParameter("RETURN", 2, 4)
		 .Parameters.Append .CreateParameter("@ClassID", 3, 1, 4, ClassID)
		 .Parameters.Append .CreateParameter("@ChannelID", 3, 1, 4, ChannelID)
		 .Parameters.Append .CreateParameter("@Ret", 200, 2, 4000)
		 .Execute()
	  End With
	  If ParentCmd(0) = 0 Then
	     Set ParentCmd = Nothing
		 Exit Function
	  End If
	  StrPath = Lang("BaseConfig.Path", " >> ")
	  ArrParent = Split(ParentCmd(3).value, "$")
	  RetString = ""
	  For i = UBound(ArrParent) To 0 Step -1
	     Dim arrTemp
		 arrTemp = Split(ArrParent(i), "|")
	     RetString = RetString & StrPath &"<a href="& InstallDir & ChannelDir &"/ShowClass.asp?ClassID="& arrTemp(0) &">"& arrTemp(1) &"</a> "
	  Next
	  Set ParentCmd = Nothing
	  GetParentPath = RetString
   End Function
   
   Public Function ShowNearInfo(ByVal TableName, ByVal IDField, ByVal TitleField, ByVal StrCondition, ByVal OrderField, ByVal InfoID)
      Dim NearCmd, PrevID, PrevTitle, NextID, NextTitle, RetString
	  Call InitCommand(NearCmd, "EL_SP_NearInfo")
	  With NearCmd
	    .Parameters.Append .CreateParameter("@TableName", 200, 1, 100, TableName)
		.Parameters.Append .CreateParameter("@IDField", 200, 1, 100, IDField)
		.Parameters.Append .CreateParameter("@TitleField", 200, 1, 100, TitleField)
		.Parameters.Append .CreateParameter("@StrCondition", 200, 1, LenParameter(StrCondition), StrCondition)
		.Parameters.Append .CreateParameter("@OrderField", 200, 1, 100, OrderField)
		.Parameters.Append .CreateParameter("@InfoID", 3, 1, 4, InfoID)
		.Parameters.Append .CreateParameter("@PrevID", 3, 2, 4)
		.Parameters.Append .CreateParameter("@PrevTitle", 200, 2, 255)
		.Parameters.Append .CreateParameter("@NextID", 3, 2, 4)
		.Parameters.Append .CreateParameter("@NextInfo", 200, 2, 255)
		.Execute()
	  End With
	  PrevID = NearCmd(6)
	  PrevTitle = NearCmd(7)
	  NextID = NearCmd(8)
	  NextTitle = NearCmd(9)
	  Set NearCmd = Nothing
	  ShowNearInfo = PrevID & VBCRLF & PrevTitle & VBCRLF & NextID & VBCRLF & NextTitle
   End Function
   
   Public Function KeywordList(ByVal Keywords, ByVal ChannelDir)
      KeywordList = ""
      If Trim(Keywords) = "" Or IsNULL(Keywords) Then
		 Exit Function
	  End If
	  Dim arr, i
	  arr = Split(Keywords, "|")
	  For i = 0 To UBOUND(arr)
	     KeywordList = KeywordList &"<a href="& InstallDir & ChannelDir &"/Search.asp?Keyword="& EL_Common.ServerURLEncode(arr(i)) &" target='_blank' class='keywordlist'>"& arr(i) &"</a>&nbsp;&nbsp;"
	  Next
   End Function
   
   Public Function ReplaceKeyLink(ByVal Content, ByVal ReplaceType)
      Dim Temp, KeyLinkCmd, rsKeyLink, RowCount, i
	  Temp = Content
	  ReplaceKeyLink = ""
	  If Temp = "" Or IsNULL(Temp) Then Exit Function
	  Select Case ReplaceType
	     Case 0: Call InitCommonCmd(KeyLinkCmd, rsKeyLink, "EL_KeyLink", "KeyType,KeyText,ReplaceText", "KeyType=0 Order By KeyLevel DESC")
		 Case 1: Call InitCommonCmd(KeyLinkCmd, rsKeyLink, "EL_KeyLink", "KeyType,KeyText,ReplaceText", "KeyType=1 Order By KeyLevel DESC")
		 Case Else: Call InitCommonCmd(KeyLinkCmd, rsKeyLink, "EL_KeyLink", "KeyText,ReplaceText", "1=1 Order By KeyLevel DESC")
	  End Select
	  rsKeyLink.Close()
	  RowCount = KeyLinkCmd(0)
	  If RowCount > 0 Then
	     rsKeyLink.Open()
		 For i = 1 To RowCount
		    Select Case rsKeyLink(0)
			   Case 0: Temp = Replace(Temp, rsKeyLink(1), "<a href='"& rsKeyLink(2) &"' target='_blank' class='keylinkA'>"& rsKeyLink(1) &"</a>")
			   Case 1: Temp = Replace(Temp, rsKeyLink(1), rsKeyLink(2))
			End Select
			If i<RowCount Then rsKeyLink.MoveNext
		 Next
		 rsKeyLink.Close()
	  End If
	  Set rsKeyLink = Nothing
	  Set KeyLinkCmd = Nothing
	  ReplaceKeyLink = Temp
   End Function
   
   Public Sub UpdateHits(ByVal ChannelID, ByVal InfoID)
      Dim HitsCmd
	  Call InitCommand(HitsCmd, "EL_SP_UpdateInfoHits")
	  With HitsCmd
	     .Parameters.Append .CreateParameter("@InfoID", 3, 1, 4, InfoID)
		 .Parameters.Append .CreateParameter("@ChannelID", 3, 1, 4, ChannelID)
		 .Execute()
	  End With
	  Set HitsCmd = Nothing
   End Sub
   
   Public Function GetConfirmType()
      Dim ConfirmType
	  ConfirmType = EL_Common.GetFieldValue("BookConfirmType", "EL_Config", "1=1")
	  If ConfirmType = "" Or ISNULL(ConfirmType) Then Exit Function
	  Dim ArrConfirmType, i
	  ArrConfirmType = Split(ConfirmType, "|")
	  GetConfirmType = "<select id='ConfirmType' name='ConfirmType'>"
	  For i = 0 To UBound(ArrConfirmType)
	     GetConfirmType = GetConfirmType &"<option value='"& ArrConfirmType(i) &"'>"& ArrConfirmType(i) &"</option>"
	  Next
	  GetConfirmType = GetConfirmType &"</select>"
   End Function
      
   Public Function Join2String(ByVal Str1, ByVal Str2, StrDivide)
      If Str1="" OR IsNULL(Str1) Then
	     Join2String = Str2
	  Else
	     If Str2="" OR IsNULL(Str2) Then
		    Join2String = Str1
		 Else
		    Join2String = Str1 & StrDivide & Str2
		 End If
	  End If
   End Function
   
   Public Function FormatDecimal(ByVal Decimal)
      If Decimal < 1 And Decimal > 0 Then
	     FormatDecimal = "0"& Decimal
	  Else
	     FormatDecimal = Decimal
	  End If
   End Function 
   
   Public Function CheckComefrom(ByVal StrComeURL, ByVal StrCurrentURL)
      If Trim(StrComeURL) = "" Then
         CheckComefrom = False
      Else
		 If Instr(StrComeURL, "?") > 0 Then
		    StrComeURL = Left(StrComeURL, Instr(StrComeURL, "?")-1)
		 End If
		 If LCase(Left(StrComeURL, InStrRev(StrComeURL, "/"))) <> LCase(Left(StrCurrentURL, InStrRev(StrCurrentURL, "/"))) Then
	        CheckComefrom = False
	     Else
	        CheckComefrom = True
	     End If
      End If
   End Function
      
   Public Function ShowBoolean(ByVal bValue, TrueText, FalseText)
      If LCase(TypeName(bValue)) <> "boolean" Then
	     ShowBoolean = ""
		 Exit Function
	  End If
	  If bValue = True Then
	     ShowBoolean = TrueText
	  Else
	     ShowBoolean = FalseText
	  End If
   End Function
   
   Public Function CheckIsPictrue(ByVal str)
      CheckIsPictrue = False
	  If Trim(str) = "" Or IsNULL(str) Then Exit Function
	  Dim Temp, ArrExt, i
	  ArrExt = Split("jpg|bmp|gif|png|jpeg", "|")
	  Temp = Right(str, Len(str)-InstrRev(str, "."))
	  For i = 0 To Ubound(ArrExt)
	     If Temp = ArrExt(i) Then
		    CheckIsPictrue = True
			Exit Function
		 End If
	  Next
   End Function
   
   Public Function PictrueURL(ByVal URL, ByVal FilePath)
      PictrueURL = InstallDir &"Images/nopic.gif"
      If Trim(URL) = "" Or IsNULL(URL) Then Exit Function
	  URL = Trim(replace(LCase(URL), "\", "/"))
	  If Instr(URL, "http://") = 1 Or Left(URL, 1) = "/"Then
	     PictrueURL = URL
	  Else
	     PictrueURL = FilePath & URL
	  End If
   End Function
   
   Public Function FoundInArray(ByVal arr, ByVal FoundValue)
      FoundInArray = False
	  If IsArray(arr) = False Or Trim(FoundValue)="" Or IsNULL(FoundValue) Then Exit Function
	  If UBound(arr) < 0 Then Exit Function
      Dim i
	  For i = 0 To UBound(arr)
	     If Trim(arr(i)) = Trim(FoundValue) Then
		    FoundInArray = True
			Exit Function
		 End If
	  Next
   End Function
   
   Public Function SetObjectChecked(StrValue, DefaultValue)
      If Trim(StrValue) = Trim(DefaultValue) Then
         SetObjectChecked = "checked"
      Else
         SetObjectChecked = ""
      End If
   End Function
   
   Public Function SetObjectSelected(StrValue, DefaultValue)
      If Trim(StrValue) = Trim(DefaultValue) Then
         SetObjectSelected = "selected"
      Else
         SetObjectSelected = ""
      End If
   End Function    
   
   Public Sub ShowSuccessMsg(SuccessMsg)
      Dim strSuccess
      strSuccess = strSuccess & "<html><head><title>成功信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>"
      strSuccess = strSuccess & "<br><table cellpadding=5 cellspacing=1 border=0 width=400 style='border:1px solid #70777b' align=center>"
      strSuccess = strSuccess & "  <tr align='center' style='background:#0650D2;color:#FFFFFF;font-size:12px;'><td height='22'><strong>恭喜你！</strong></td></tr>"
      strSuccess = strSuccess & "  <tr style='background:#F0F1F5;font-size:12px;'><td height='100' valign='top'><br>" & SuccessMsg & "</td></tr>"
      strSuccess = strSuccess & "  <tr align='center' style='background:#F0F1F5;font-size:12px;'><td>"
      If ComeURL <> "" Then
         strSuccess = strSuccess & "<a href='" & ComeURL & "'>【返回上一页】</a>"
      Else
         strSuccess = strSuccess & "<a href='javascript:window.opener=null;window.close();'>【关闭】</a>"
      End If
      strSuccess = strSuccess & "</td></tr>"
      strSuccess = strSuccess & "</table><br>"
      strSuccess = strSuccess & "</body></html>"
      Response.Write strSuccess
   End Sub
   
   Public Sub ShowErrorMsg(ErrorMsg)
      Dim strError
      strError = strError & "<html><head><title>错误信息</title><meta http-equiv='Content-Type' content='text/html; charset=gb2312'>" & vbCrLf
      strError = strError & "<br><table cellpadding=5 cellspacing=1 border=0 width=400 style='border:1px solid #70777b' align=center>" & vbCrLf
      strError = strError & "  <tr align='center' style='background:#0650D2;color:#FFFFFF;font-size:12px;'><td height='25'><strong>错误信息</strong></td></tr>" & vbCrLf
      strError = strError & "  <tr style='background:#F0F1F5;font-size:12px;'><td height='100' valign='top'><font color=red>" & ErrorMsg & "</font></td></tr>" & vbCrLf
      strError = strError & "  <tr align='center' style='background:#F0F1F5;font-size:12px;'><td>"
      If ComeURL <> "" Then
         strError = strError & "<a href='javascript:history.back()'>【返回上一页】</a>"
      Else
        strError = strError & "<a href='javascript:window.opener=null;window.close();'>【关闭】</a>"
      End If
      strError = strError & "</td></tr>" & vbCrLf
      strError = strError & "</table><br>" & vbCrLf
      strError = strError & "</body></html>" & vbCrLf
      Response.Write strError
   End Sub
   
   Public Sub InitCommand(ObjectCmd, SpName)
      Set ObjectCmd = Server.CreateObject("ADODB.COMMAND")
	  With ObjectCmd
	     .ActiveConnection = Conn
		 .CommandText = SpName
		 .CommandType = 4
		 .Prepared = True
	  End With
   End Sub
   
   Public Sub InitCommonCmd(ObjectCmd, ObjectRecordSet, TableName, ArrFields, StrCondition)
      Set ObjectCmd = Server.CreateObject("ADODB.COMMAND")
	  With ObjectCmd
	     .ActiveConnection = Conn
		 .CommandText = "EL_SP_CommonPROC"
		 .CommandType = 4
		 .Prepared = True
		 .Parameters.Append .CreateParameter("RETURN", 3, 4, 4)
		 .Parameters.Append .CreateParameter("@TableName", 200, 1, StrLength(TableName), TableName)
		 .Parameters.Append .CreateParameter("@ArrFields", 200, 1, StrLength(ArrFields), ArrFields)
		 .Parameters.Append .CreateParameter("@StrCondition", 200, 1, StrLength(StrCondition), StrCondition)
		 Set ObjectRecordSet = .Execute()
	  End With
   End Sub
   
   Public Function LenParameter(strParameter)
      If Trim(strParameter)="" Or IsNULL(strParameter) Then
	     LenParameter = 1
	  Else
	     LenParameter = Len(strParameter)
	  End If	  
   End Function
   
   Public Function ReplaceBadChar(ByVal bString)
      If bString = "" Or IsNull(bString) Or EL_BadChar="" Then
          ReplaceBadChar = ""
          Exit Function
      End If
      Dim ArrBadChar, TempString, i
      ArrBadChar = Split(EL_BadChar, ",")
      TempString = bString
      For i = 0 To UBound(ArrBadChar)
        TempString = Replace(TempString, ArrBadChar(i), "")
      Next
      ReplaceBadChar = TempString
   End Function
   
   Public Function GetTopic(ByVal str, ByVal strlen)
      If str = "" Or IsNULL(str) Then
         GetTopic = ""
         Exit Function
      End If
	  If ELCLng(strlen) = 0 Then
	     GetTopic = str
		 Exit Function
	  End If
	  
	  If ELCLng(strlen) < 0 Then
	     GetTopic = ""
		 Exit Function
	  End If
	  
      Dim l, t, c, i, strTemp
      str = Replace(Replace(Replace(Replace(str, "&nbsp;", " "), "&quot;", Chr(34)), "&gt;", ">"), "&lt;", "<")
      l = Len(str)
      t = 0
      strTemp = str
      strlen = ELCLng(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