📄 cls.common.asp

📁 网人分类信息5.0商业版。非常优秀的分类信息系统。比较少见。
💻 ASP
📖 第 1 页 / 共 4 页
字号:
上一页 1 2 34
   Function GetServer()
     GetServer = False
     If Instr(Request.ServerVariables("Server_NAME"),"127.0.") > 0 Or Instr(Request.ServerVariables("Server_NAME"),"192.168.") > 0 Or Instr(Request.ServerVariables("Server_NAME"),"localhost") > 0 Then GetServer = True
   End Function

   '##################################################################################################
   '存储缓Cookies
   Sub SCookies(CName,Str,CDay)
     If CDay > 0 Then Response.Cookies(CacheName&CName).Expires=Date+CDay
     If Ucase(CName) = "CODE" Or Left(Ucase(CName),6) = "MYCITY" Then Response.Cookies(CName) = Str Else Response.Cookies(CacheName&CName) = Str
   End Sub
   '清除Cookies
   Sub DelCookies(CName)
     If Ucase(CName) = "CODE" Or Left(Ucase(CName),6) = "MYCITY" Then Response.Cookies(CName) = Empty Else Response.Cookies(CacheName&CName) = Empty
   End Sub
   '获取Cookies
   Function GetCookies(CName)
     GetCookies = Empty
     If Ucase(CName) = "CODE" Or Left(Ucase(CName),6) = "MYCITY" Then
	   If Request.Cookies(CName) <> "" and IsEmpty(Request.Cookies(CName)) = False and IsNUll(Request.Cookies(CName)) = False Then GetCookies = Request.Cookies(CName)
	 Else
	   If Request.Cookies(CacheName&CName) <> "" and IsEmpty(Request.Cookies(CacheName&CName)) = False and IsNUll(Request.Cookies(CacheName&CName)) = False Then GetCookies = Request.Cookies(CacheName&CName)
	 End If
   End Function

   '以下为缓存操作
   '=============================
   '存储缓存
   Sub SCache(CName,Str)
     Application(CacheName&CName) = Str
   End Sub
   '清除缓存
   Sub DelCache(CName)
     Application.Lock
       Application.Contents.Remove(CacheName&CName)
	 Application.Unlock
   End Sub
   '获取缓存
   Function GetCache(CName)
     GetCache = Application(CacheName&CName)
   End Function
      '系统缓存
   Sub Cache()
	 Server_Url = "ht"&"tp:/"&"/ser"&"ver.wa"&"ngr"&"en.n"&"et/"
     SystemVersionType = 0
     ConnTime = "Now()"
	 If SystemVersionType > 1 Then ConnTime = "GetDate()"
	 If IsEmpty(GetCache("Setting")) Then
       If IsObject(Conn) = False Then Call DBConnBegin()
       Set aRs = Conn.Execute("Select WM_Config,WM_Setting,WM_MailServer,WM_SiteUpLoad,WM_ClassAD,WM_Other,WM_User,WM_Company,WM_Area,WM_Prop,WM_Faith,WM_Code From WM_Config")
         If Not aRs.Eof Then
		   SCache "Setting",aRs(0)&"§§§"&aRs(1)
		   SCache "Mail",aRs(2)
		   SCache "UpLoad",aRs(3)
		   SCache "ClassAD",aRs(4)
		   SCache "Other",aRs(5)
		   SCache "Member",aRs(6)
		   SCache "Company",aRs(7)
		   SCache "Area",aRs(8)
		   SCache "Prop",aRs(9)
		   SCache "Faith",aRs(10)
		   SCache "Code",aRs(11)
           aRs.Close
         Else
		   aRs.Close
           Call ErrView("·网站配置数据丢失！系统无法正常运行！", 0)
		 End If
	 End If
     WR_Setting = Split(GetCache("Setting"),"§§§")
     WR_Mail = Split(GetCache("Mail"),"§§§")
     WR_UpLoad = Split(GetCache("UpLoad"),"§§§")
     WR_ClassAD = Split(GetCache("ClassAD"),"§§§")
     WR_Other = Split(GetCache("Other"),"§§§")
     WR_User = Split(GetCache("Member"),"§§§")
     WR_Company = Split(GetCache("Company"),"§§§")
     WR_Area = Split(GetCache("Area"),"§§§")
     WR_Prop = Split(GetCache("Prop"),"|")
	 WR_Faith = Split(GetCache("Faith"),"|")
	 WR_Code = Split(GetCache("Code"),"@@")
	 WR_CodeQA = Split(WR_Code(3),vbCrLf)

     '模板缓存
	 If IsEmpty(GetCache("Templates")) Then
	    If IsObject(Conn) = False Then Call DBConnBegin()
        Set aRs = Conn.Execute("Select WM_ID,WM_TempPath,WM_SortID,WM_ChannelID,WM_Name From WM_Templates Where WM_SkinFolder = '" & WR_Setting(5) & "' Order By WM_IsDefault Desc,WM_ID")
        If Not aRs.Eof And Not aRs.Bof Then 
          SCache "Templates",aRs.GetRows()
        End If 
        aRs.Close
	 End If

     '标签缓存
	 If IsEmpty(GetCache("Label")) Then
	    If IsObject(Conn) = False Then Call DBConnBegin()
        Set aRs = Conn.Execute("Select WM_Name,WM_Content,WM_Cache From WM_Label Where WM_Type in(1,2) and WM_SkinDir = '" & WR_Setting(5) & "' Order By WM_Type,WM_Taxis Desc")
        If Not aRs.Eof And Not aRs.Bof Then 
		  SCache "Label",aRs.GetRows()
        End If 
        aRs.Close
	 End If
    
	 '统计缓存
	 If IsEmpty(GetCache("DynamicCache")) Then
       If IsObject(Conn) = False Then Call DBConnBegin()
       Set aRs = Conn.Execute("Select WM_UserNum,WM_NewUser,WM_ClassNum,WM_ArticleNum,WM_CompanyNum,WM_UserFaith,WM_CompanyReNum,WM_CouponNum From WM_Config")
       If Not aRs.Eof Then
		 SCache "UserNum",aRs(0)
		 SCache "NewUser",aRs(1)
		 SCache "ClassNum",aRs(2)
		 SCache "ArticleNum",aRs(3)
		 SCache "CompanyNum",aRs(4)
		 SCache "UserFaith",aRs(5)
		 SCache "CompanyReNum",aRs(6)
		 SCache "CouponNum",aRs(7)
       End If
       aRs.Close
	   SCache "DynamicCache","True"
	 End If
	 W_UserNum = GetCache("UserNum")
	 W_NewUser = GetCache("NewUser")
	 W_ClassNum = GetCache("ClassNum")
	 W_ArticleNum = GetCache("ArticleNum")
	 W_CompanyNum = GetCache("CompanyNum")
	 W_UserFaith = GetCache("UserFaith")
	 W_CompanyReNum = GetCache("CompanyReNum")
	 W_CouponNum = GetCache("CouponNum")

     '地区缓存
	 If IsEmpty(GetCache("AreaList")) Then
       If IsObject(Conn) = False Then Call DBConnBegin()
	   SCache "DefaultArea","0|"&WR_Area(0)&"|www||0"
       Set aRs = Conn.Execute("Select WM_ID,WM_Name,WM_Eng,WM_Domain,WM_TempID,WM_Default from WM_Area Where WM_Key = 1")
       Do While Not aRs.Eof
	     If aRs(5) = 1 Then SCache "DefaultArea",aRs(0)&"|"&aRs(1)&"|"&aRs(2)&"|"&aRs(3)&"|"&aRs(4)
         If AreaList = "" Then
		   AreaList = aRs(0)&"|"&aRs(1)&"|"&aRs(2)&"|"&aRs(3)&"|"&aRs(4)
		 Else
		   AreaList = aRs(0)&"|"&aRs(1)&"|"&aRs(2)&"|"&aRs(3)&"|"&aRs(4)&","&AreaList
		 End If
       aRs.MoveNext
	   Loop
	   aRs.Close
	   SCache "AreaList",AreaList
     End If
	 AreaList = GetCache("AreaList")
	 DefaultArea = Split(GetCache("DefaultArea"),"|")
   End Sub
   '##################################################################################################
   '以下为Fso操作函数
   '===========================
   Sub FsoBegin()
     On Error Resume Next
     Set Fso = Server.CreateObject(WR_Setting(14))
     If Err Then Err.Clear:Call ErrView("·空间不支持FSO组件或FSO组件已改名，请联系空间商", 0)
   End Sub
   Sub FsoEnd()
     Set Fso = nothing
   End Sub
   '删除文件/目录
   Sub FsoDel(iType,iPath)
     On Error Resume Next
     Select Case UCASE(iType)
	   Case "DIR"
	     If Len(Server.MapPath(iPath)&"\") > Len(Request.ServerVariables("APPL_PHYSICAL_PATH"))+Len(WR_Setting(3))-1 Then
	       If Fso.FolderExists(Server.MapPath(iPath)) Then Fso.DeleteFolder (Server.MapPath(iPath)), True
		 End If
	   Case "FILE"
         If Fso.FileExists(Server.MapPath(iPath)) Then Fso.DeleteFile (Server.MapPath(iPath)), True
	 End Select
	 If Err Then Err.Clear:Exit Sub
   End Sub
   '检查文件/目录是否成在
   Function FsoIsTrue(iType,iPath)
     Select Case UCASE(iType)
	   Case "DIR"
	     If Fso.FolderExists(Server.MapPath(iPath)) Then FsoIsTrue = True Else FsoIsTrue = False
	   Case "FILE"
         If Fso.FileExists(Server.MapPath(iPath)) Then FsoIsTrue = True Else FsoIsTrue = False
	 End Select
   End Function
   '生成页面
   Sub CreateFile(iPath,iHtml)
     Dim cHtml
	 Set cHtml=Server.CreateObject("ADODB.Stream")
	  With cHtml
		  .Type=2
		  .Open
	   	  .Charset="gb2312"
		  .Position=cHtml.Size
		  .WriteText=iHtml
		  .SaveToFile Server.Mappath(iPath),2
		  .Close
	  End With
	 Set cHtml=Nothing
   End Sub
   '生成目录
   Sub CreFolder(iPath)
        Dim CreateP
		CreateP = ""
		If Fso.FolderExists(Server.MapPath(iPath)) = False Then
	      For ai=0 to UBound(Split(iPath,"/"))
	        CreateP = CreateP & Split(iPath,"/")(ai) & "/"
	        CreateP = Replace(CreateP,"//","/")
	        If Fso.FolderExists(Server.MapPath(CreateP)) = False Then
	          Fso.CreateFolder Server.MapPath(CreateP)
	        End If
	      Next
		End If
   End Sub
   '复制文件
   Sub FileCopy(iFile,iNewFile)
     If Fso.FileExists(Server.MapPath(iNewFile)) = False and Fso.FileExists(Server.MapPath(iFile)) Then 
       Fso.CopyFile Server.MapPath(iFile), Server.MapPath(iNewFile),False
	 End If
   End Sub
   '复制目录
   Sub FolderCopy(iPath,iNewPath)
     If Fso.FolderExists(Server.MapPath(iNewPath)) = False and Fso.FolderExists(Server.MapPath(iPath)) Then 
       Fso.CopyFolder Server.MapPath(iPath), Server.MapPath(iNewPath),False
	 End If
   End Sub
   '提取文件内容
   Function GetHtml(iPath)
      Dim Fso_Content,Temp_Html
      GetHtml = ""
	  If Not(Fso.FileExists(Server.MapPath(iPath))) then
         Call ErrView("文件("&iPath&")不存在",0)
	  Else
        Set Fso_Content=Server.CreateObject("ADODB.Stream")
			Fso_Content.Charset="gb2312"
			Fso_Content.Open
			Fso_Content.LoadFromFile Server.MapPath(iPath)
			Temp_Html=Fso_Content.ReadText
	    Set Fso_Content=Nothing
      End If
	  If Temp_Html = "" Then
	    GetHtml = ""
	  Else
	    Temp_Html = Split(Temp_Html,chr(13)&chr(10))
	    LineNum = UBound(Temp_Html)
	    If Temp_Html(UBound(Temp_Html)) = "" Then LineNum = LineNum - 1
        For ai = 0 To LineNum
	      If GetHtml = "" Then
		    GetHtml = Temp_Html(ai)
		  Else
		    GetHtml = GetHtml & chr(13)&chr(10) & Temp_Html(ai)
		  End If
	    Next
	  End If
   End Function
   '生成电话等图片
   'aID 信息ID，aType 1 Class 2 Company
   'Class  EMAIL,电话，QQ，地址
   'Company 传真，电话，手机，地址
   Sub CreTextToImg(aID,aType,aStr1,aStr2,aStr3,aStr4)
      If Int(WR_UpLoad(41)) = 0 Then Exit Sub
      Dim CreJpeg,TTI_FileName,TTI_Type,TTI_Path,TTI_Str,TTI_W
	  Select Case aType
	    Case 1
		  TTI_Type = "C"
		Case 2
		  TTI_Type = "Co"
	  End Select
      TTI_Path = UrlPath&WR_UpLoad(0)&"/"&WR_UpLoad(47)&"/"&TTI_Type&"/"&aID&"/"
	  Call FsoBegin()
	  Call CreFolder(TTI_Path)
	  Call FsoEnd()
      Set CreJpeg = Server.CreateObject("Persits.Jpeg")
	  For ai = 1 To 4
	    TTI_FileName = MD5(0,aID&TTI_Type&ai)&".gif"
	    Select Case ai
		  Case 1
		    TTI_Str = aStr1
		  Case 2
		    TTI_Str = aStr2
		  Case 3
		    TTI_Str = aStr3
		  Case 4
		    TTI_Str = aStr4
		End Select
		TTI_Str = GetReplace(TTI_Str,"&nbsp;"," ")
		If TTI_Str <> "" and IsNull(TTI_Str) = False Then
        CreJpeg.Open Server.MapPath("../images/crebg.gif")
        If IsNUll(WR_UpLoad(42)) = False Then CreJpeg.Canvas.Font.Color = Replace(WR_UpLoad(42),"#","&H")           '水印字体颜色
        If IsNUll(WR_UpLoad(43)) = False Then CreJpeg.Canvas.Font.Size = WR_UpLoad(43)                              '水印字体大小   
        If IsNUll(WR_UpLoad(44)) = False Then CreJpeg.Canvas.Font.Family = WR_UpLoad(44)                            '水印字体 
        If WR_UpLoad(45) > 0 Then CreJpeg.Canvas.Font.Bold = True Else CreJpeg.Canvas.Font.Bold = False             '是否粗体，粗体用：1  
        If IsNUll(WR_UpLoad(46)) = False Then CreJpeg.Canvas.Font.BkMode = Replace(WR_UpLoad(46),"#","&H")          '字体背景颜色
        CreJpeg.Canvas.Print 1, 1, TTI_Str
        CreJpeg.Save Server.MapPath(TTI_Path&TTI_FileName)
        CreJpeg.Open Server.MapPath(TTI_Path&TTI_FileName)
        CreJpeg.crop 0,0,StrLength(TTI_Str)*8+2,18 
        CreJpeg.Save Server.MapPath(TTI_Path&TTI_FileName)
		End If
	  Next
      Set CreJpeg = Nothing 
   End Sub
   
   '得到上传时间目录
   Function SaveTimeDir()
     Select Case Int(WR_UpLoad(1))
       Case 0
	     SaveTimeDir = "/"
       Case 1
	     SaveTimeDir = "/"&Year(Date())&"/"
       Case 2
	     SaveTimeDir = "/"&Year(Date())&Right("0"&Month(Date()),2)&"/"
       Case 3
	     SaveTimeDir = "/"&Year(Date())&Right("0"&Month(Date()),2)&Right("0"&Day(Date()),2)&"/"
       Case 4
	     SaveTimeDir = "/"&Year(Date())&Right("0"&Month(Date()),2)&"/"&Right("0"&Day(Date()),2)&"/"
       Case 5
	     SaveTimeDir = "/"&Year(Date())&"/"&Right("0"&Month(Date()),2)&"/"&Right("0"&Day(Date()),2)&"/"
     End Select
   End Function
End Class
Set WRMPS = New Cls_Main
%>
<!--#include file="Cls.User.asp"-->
<!--#include file="Cls.CityReh.asp"-->
<!--#include file="Cls.Page.asp"-->
<!--#include file="Cls.DB.asp"-->
上一页 1 2 34
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -