classcommon.asp

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

	  Set Matches = CommonRegExp.Execute(Content)
	  rsList.Open()
	  ReturnString = Content
	  Dim Temp, FParameters
	  Temp = ""
	  For Each Match In Matches
	     rsList.MoveFirst
		 MatchString = Match.Value
		 MatchString = ReplaceText(MatchString, "\[Loop\]", "")
		 MatchString = ReplaceText(MatchString, "\[\/Loop\]", "")
		 Dim ItemHTML
		 ItemHTML = ""
		 For i = 1 To RowCount
		    ItemHTML = MatchString
			ItemHTML = DynamicLabelField(ItemHTML, rsList)
			Temp = Temp & ItemHTML
			If i<RowCount Then rsList.MoveNext
		 Next
		 ReturnString = Replace(ReturnString, Match.Value, Temp)
	  Next
	  rsList.Close()
	  Set rsList = Nothing
	  Set ListCmd = Nothing
	  UserDefinedDynamicLabel = ReturnString
   End Function 
   
   Private Function DynamicLabelPara(ByVal HTML, ByVal ArrParameter)
      Dim Match, Matches, ReturnString, PParameters, StrTemp
	  CommonRegExp.Pattern = "\{\$Para\(([ 0-9]+),([ 0-9]+)\)\}"        
	  Set Matches = CommonRegExp.Execute(HTML)
	  ReturnString = HTML
	  For Each Match in Matches
	     PParameters = GetLabelParameters(Match.Value, "Para")		
		 PParameters(0) = ELClng(Trim(PParameters(0)))
		 PParameters(1) = ELClng(Trim(PParameters(1)))
		 StrTemp = ""
		 StrTemp = ArrParameter(PParameters(0))
		 Select Case PParameters(1)
		    Case 0: '文本类型			   
			   StrTemp = ReplaceBadChar(StrTemp)
			   StrTemp = "'"& StrTemp &"'"
			Case 1: '数字类型
			   StrTemp = ELClng(StrTemp)
			Case 2: '布尔类型
			   StrTemp = lCase(StrTemp)
			   StrTemp = Replace(StrTemp, "false", EL_False)
			   StrTemp = Replace(StrTemp, "true", EL_True)
			   If StrTemp <> lCase(EL_True) And StrTemp <> lCase(EL_False) Then
			      StrTemp = EL_False
			   End If
			Case 3: '日期类型
			   If Not IsDate(StrTemp) Then
			      StrTemp = Now()
			   End If
			   StrTemp = "'"& StrTemp &"'"
		 End Select 
		 ReturnString = Replace(ReturnString, Match.Value, StrTemp)
	  Next
	  DynamicLabelPara = ReturnString	  
   End Function
   
   Private Function DynamicLabelField(ByVal HTML, ByVal rsValue)
      Dim Match, Matches, ReturnString, FParameters, StrTemp
	  CommonRegExp.Pattern = "<!--\{\$Field\(([ 0-9]+),([ 0-9]+),([\u4e00-\u9fa5\|\w ]*),([\u4e00-\u9fa5\|\w ]*)\)\}-->"        
	  Set Matches = CommonRegExp.Execute(HTML)
	  ReturnString = HTML
	  For Each Match in Matches
	     FParameters = GetLabelParameters(Match.Value, "Field")		 
		 FParameters(0) = ELClng(Trim(FParameters(0)))
		 FParameters(1) = ELClng(Trim(FParameters(1)))
		 StrTemp = ""
		 StrTemp = rsValue(FParameters(0))
		 Select Case FParameters(1)
		    Case 0: '文本类型
			   FParameters(2) = ELClng(Trim(FParameters(2)))
			   FParameters(3) = ELClng(Trim(FParameters(3)))
			   StrTemp = GetTopic2(StrTemp, FParameters(2))
			   If FParameters(3) = 1 Then
			      StrTemp = RemoveHTML(StrTemp)
			   ElseIf FParameters(3) = 2 Then
			      StrTemp = ServerHTMLEncode(StrTemp)
			   End If			   
			Case 1: '数字类型
			   FParameters(2) = ELClng(Trim(FParameters(2)))
			   StrTemp = ELClng(StrTemp)
			   If FParameters(2) > 0 Then
			      StrTemp = FormatNumber(StrTemp, FParameters(2))
			   End If
			Case 2: '布尔类型			   
			   If StrTemp = True Then
			      StrTemp = FParameters(2)
			   Else
			      StrTemp = FParameters(3)
			   End If
			Case 3: '日期类型
			   FParameters(2) = ELClng(Trim(FParameters(2)))
			   If IsDate(StrTemp) Then
			      If FParameters(2) = 1 Then
			         StrTemp = FormatDateTime(StrTemp, 2)
			      ElseIf FParameters(2) = 2 Then
				     StrTemp = Month(StrTemp) &"-"& Day(StrTemp)
			      End If
			   End If
		 End Select
		 ReturnString = Replace(ReturnString, Match.Value, StrTemp)		 
	  Next
	  
	  CommonRegExp.Pattern = "\{\$Field\(([ 0-9]+),([ 0-9]+),([\u4e00-\u9fa5\|\w ]*),([\u4e00-\u9fa5\|\w ])*\)\}"        
	  Set Matches = CommonRegExp.Execute(HTML)
	  For Each Match in Matches
	     FParameters = GetLabelParameters(Match.Value, "Field")		 
		 FParameters(0) = ELClng(Trim(FParameters(0)))
		 FParameters(1) = ELClng(Trim(FParameters(1)))
		 StrTemp = ""
		 StrTemp = rsValue(FParameters(0))
		 Select Case FParameters(1)
		    Case 0: '文本类型
			   FParameters(2) = ELClng(Trim(FParameters(2)))
			   FParameters(3) = ELClng(Trim(FParameters(3)))			   
			   If FParameters(3) = 1 Then
			      StrTemp = RemoveHTML(StrTemp)
			   ElseIf FParameters(3) = 2 Then
			      StrTemp = ServerHTMLEncode(StrTemp)
			   End If	
			   StrTemp = GetTopic2(StrTemp, FParameters(2))		   
			Case 1: '数字类型
			   FParameters(2) = ELClng(Trim(FParameters(2)))
			   StrTemp = ELClng(StrTemp)
			   StrTemp = FormatNumber(StrTemp, FParameters(2))
			Case 2: '布尔类型			   
			   If StrTemp = True Then
			      StrTemp = FParameters(2)
			   Else
			      StrTemp = FParameters(3)
			   End If
			Case 3: '日期类型
			   FParameters(2) = ELClng(Trim(FParameters(2)))
			   If IsDate(StrTemp) Then
			      If FParameters(2) = 1 Then
			         StrTemp = FormatDateTime(StrTemp, 2)
			      ElseIf FParameters(2) = 2 Then
				     StrTemp = Month(StrTemp) &"-"& Day(StrTemp)
			      End If
			   End If
		 End Select		 
		 ReturnString = Replace(ReturnString, Match.Value, StrTemp)		 
	  Next
	  
	  Set Matches = Nothing
	  DynamicLabelField = ReturnString
   End Function
   
   Public Function GetLabelParameters(ByVal Label, ByVal StrName)
      Dim TempLabel
	  TempLabel = LCase(GetFunctionName(Label))
	  TempLabel = Replace(TempLabel, LCase(StrName), "")
	  TempLabel = Replace(Replace(TempLabel, "(", ""), ")", "")
	  GetLabelParameters = Split(TempLabel, ",")
   End Function
   
   Public Function GetLabelName(ByVal StrLableName)
      GetLabelName = Trim(Replace(Replace(StrLableName, "{$", ""), "}", ""))
   End Function
   
   Public Function GetFunctionName(ByVal StrLableName)
      GetFunctionName = Replace(Replace(Replace(Replace(Replace(Replace(StrLableName, "{$", ""), "}", ""), "<!--", ""), "-->", ""), " ", ""), CHR(32), "")
   End Function
   
   Public Function Lang(ByVal NString, ByVal DefaultValue)
      Dim Root
	  If NString = "" Then
	     Lang = DefaultValue
	  Else
		 Set Root = LangXML.SelectSingleNode("//"& Replace(NString, ".", "/"))
		 If Not Root Is Nothing Then Lang = Root.Text
		 If Lang = "" Then Lang = DefaultValue
	  End If
	  If Lang <> "" And Not ISNULL(Lang) Then Lang = BaseLabel(Lang)
   End Function
   
   Public Function Template(ByVal ChannelID, ByVal TemplateType, ByVal TemplateID)
      Dim CacheFlag, Content, CacheName
	  If ChannelID = "" Or IsNULL(ChannelID) Or TemplateType = "" Or IsNULL(TemplateType) Then	     
		 ShowErrorMsg(Lang("BaseConfig.TemplateError", "未找到指定模板"))
		 Call ApplicationTerminate()
	  End If
	  
	  If TemplateType = -1 Then
	     If Cache_Template_Index = 1 Then
	        CacheFlag = True
	     Else
	        CacheFlag = False
	     End If
	  Else
	     CacheFlag = FoundInArray(Split(Eval("Cache_Template_"& ChannelID), ","), Cstr(TemplateType))
	  End If
	  
	  If CacheFlag Then
	     If ELClng(TemplateType) = -1 Then	        
			CacheName = "Template.Index"
		 Else
		    If ELClng(TemplateID) = 0 Then 			   
			   CacheName = "Template."& ChannelID &"."& TemplateType
			Else			   
			   CacheName = "Template."& ChannelID &"."& TemplateType &"."& TemplateID
			End If
		 End If
		 Content = EL_Cache.GetCache(CacheName, 0)
		 If Content = "" Then
		    Content = GetTemplateContent(ChannelID, TemplateType, TemplateID)
			Call EL_Cache.SetCache(CacheName, Content, -1)
		 End If
	  Else
	     Content = GetTemplateContent(ChannelID, TemplateType, TemplateID)
	  End If 	  	  
	  Template = Content
   End Function
   
   Private Function GetTemplateContent(ByVal ChannelID, ByVal TemplateType, ByVal TemplateID)
      Dim TemplateCmd, rsTemplate
	  If ELClng(TemplateID) = 0 Then
	     Call InitCommonCmd(TemplateCmd, rsTemplate, "EL_Template", "Content", "ChannelID="& ChannelID &" AND TemplateType="& TemplateType &" And Defaulted="& EL_True)
	  Else
	     Call InitCommonCmd(TemplateCmd, rsTemplate, "EL_Template", "Content", "ChannelID="& ChannelID &" AND TemplateType="& TemplateType &" And TemplateID="& TemplateID)
	  End If	 
	  rsTemplate.Close()
	  If TemplateCmd(0) = 0 Then
	     ShowErrorMsg(Lang("BaseConfig.TemplateError", "未找到指定模板"))
		 Call ApplicationTerminate()
	  Else
	     rsTemplate.Open()
		 GetTemplateContent = rsTemplate(0)
		 rsTemplate.Close()
	  End If
	  Set rsTemplate = Nothing
	  Set TemplateCmd = Nothing
   End Function
   
   Public Function Skin(ByVal ChannelID, ByVal ClassID, ByVal dSkinID)
      Dim SkinCmd
	  If dSkinID <> 0 Then
	     Skin = "<link href='"& InstallDir &"Skin/DefaultStyle"& dSkinID &".css' type='text/css' rel='stylesheet'>"
		 Exit Function
	  End If
	  Call EL_Common.InitCommand(SkinCmd, "EL_SP_GetDefaultSkin")
	  With SkinCmd
	    .Parameters.Append .CreateParameter("@ChannelID", 3, 1, 4, ChannelID)
		.Parameters.Append .CreateParameter("@ClassID", 3, 1, 4, ClassID)
		.Parameters.Append .CreateParameter("@SkinID", 3, 2, 4)
		.Execute()
	  End With
	  Skin = "<link href='"& InstallDir &"Skin/DefaultStyle"& SkinCmd(2) &".css' type='text/css' rel='stylesheet'>"
	  Set SkinCmd = Nothing
   End Function
   
   Public Function CheckEnableBook(CheckType)
      Dim ConfigCmd, rsConfig, EnableUserBook, EnableVisitorBook
	  Call EL_Common.InitCommonCmd(ConfigCmd, rsConfig, "EL_Config", "EnableUserBook, EnableVisitorBook", "1=1")
	  EnableUserBook = rsConfig(0)
	  EnableVisitorBook = rsConfig(1)
	  rsConfig.Close()
	  Set rsConfig = Nothing
	  
	  If CheckType = 0 Then
	     If EnableUserBook = False Then
		    EL_Common.ShowErrorMsg(EL_Common.Lang("BaseConfig.DisabledUserBook", "本站暂时不接受会员预订"))
		    Call ApplicationTerminate()
	     End If
	  Else
	     If EnableVisitorBook = False Then
		    EL_Common.ShowErrorMsg(EL_Common.Lang("BaseConfig.DisabledVisitorBook", "本站暂时不接受游客预订"))
		    Call ApplicationTerminate()
	     End If
	  End If
   End Function
   
   Public Function GetFieldValue(ByVal FieldName, ByVal TableName, ByVal SQLCondition)
      Dim FValueCmd, rsFValue, ArrField, i, length
	  ArrField = Split(FieldName, ",")
	  length = UBOUND(ArrField)
	  Call InitCommonCmd(FValueCmd, rsFValue, TableName, FieldName, SQLCondition)
	  rsFValue.Close()
	  If FValueCmd(0) <> 1 Then	     
	     If length = 0 Then
		    GetFieldValue = ""
		 Else
		    ReDim arrTemp(length)
			For i = 0 To length
			   arrTemp(i) = ""
			Next
			GetFieldValue = arrTemp
		 End If
	  Else
	     rsFValue.Open()
		 If length = 0 Then
		    GetFieldValue = rsFValue(0)
		 Else
		    ReDim arrTemp(length)
		    For i = 0 To length
		       arrTemp(i) = rsFValue(i)
		    Next
			GetFieldValue = arrTemp
		 End If
		 rsFValue.Close()
	  End If
	  Set rsFValue = Nothing
	  Set FValueCmd = Nothing
   End Function
   
   Public Function GetAllChildID(ByVal ParentID)
      Dim ChildCmd
	  Call InitCommand(ChildCmd, "EL_SP_GetAllChildID")
	  With ChildCmd
	     .Parameters.Append .CreateParameter("@ParentID", 3, 1, 4, ParentID)
		 .Parameters.Append .CreateParameter("@AllChildID", 200, 2, 8000)
		 .Execute()
	  End With
	  GetAllChildID = ChildCmd(1)
	  Set ChildCmd = Nothing
   End Function
   
   Public Function GetAllClassID(ByVal ArrClassID)
      Dim i, arr, AllChildID
	  GetAllClassID = ""
	  arr = Split(Replace(ArrClassID, " ", ""), "|")
	  For i = 0 To Ubound(arr)
	     If arr(i) <> "" Then
		    AllChildID = EL_Common.GetAllChildID(arr(i))
			arr(i) = Join2String(arr(i), AllChildID, ",")
			GetAllClassID = Join2String(GetAllClassID, arr(i), ",")
		 End If		 
	  Next
   End Function