cls_main.asp

网络办公系统源码

		
		If Not IsNull(url) And Trim(url) <> "" And LCase(url) <> "http://" Then
			strTempUrl = InstallDir & ChannelDir
			If CheckUrl(url) = 1 Then
				strImageUrl = Trim(url)
			ElseIf CheckUrl(url) = 2 Then
				strImageUrl = url
			Else
				strImageUrl = Replace(url, "../", "")
				strImageUrl = Trim(strTempUrl & strImageUrl)
			End If
		Else
			strImageUrl = InstallDir & "images/no_pic.gif"
		End If
		GetImageUrl = strImageUrl
	End Function
	'-----------------------------------------------------------------
	'================================================
	'作  用：读取图片或者FLASH
	'参  数：url ----文件URL
	'        height ----高度
	'        width ----宽度
	'================================================
	Function GetFlashAndPic(ByVal url, ByVal height, ByVal width)
		On Error Resume Next
		Dim sExtName, ExtName, strTemp
		Dim strHeight, strWidth
		
		If Not IsNumeric(height) Or height < 1 Then
			strHeight = ""
		Else
			strHeight = " height=" & height
		End If
		If Not IsNumeric(width) Or width < 1 Then
			strWidth = ""
		Else
			strWidth = " width=" & width
		End If
		sExtName = Split(url, ".")
		ExtName = sExtName(UBound(sExtName))
		If LCase(ExtName) = "swf" Then
			strTemp = "<embed src=""" & url & """" & strWidth & strHeight & ">"
		Else
			strTemp = "<img src=""" & url & """" & strWidth & strHeight & " border=0>"
		End If
		GetFlashAndPic = strTemp
	End Function
	'================================================
	'函数名：ReadFileUrl
	'作  用：读取文件URL
	'================================================
	Public Function ReadFileUrl(url)
		On Error Resume Next
		ReadFileUrl = ""
		If url = "" Then Exit Function
		Dim strTemp
		If CheckUrl(url) = 1 Then
			strTemp = Trim(url)
		ElseIf CheckUrl(url) = 2 Then
			strTemp = Trim(url)
		Else
			strTemp = Replace(url, "../", "")
			strTemp = Trim(InstallDir & strTemp)
		End If
		ReadFileUrl = strTemp
	End Function
	Public Function CheckUrl(ByVal url)
		Dim strUrl
		If Left(url, 1) = "/" Then
			CheckUrl = 1
			Exit Function
		End If
		strUrl = LCase(Left(url, 6))
		Select Case Trim(strUrl)
		Case "http:/", "https:", "ftp://", "rtsp:/", "mms://"
			CheckUrl = 2
			Exit Function
		Case Else
			CheckUrl = 0
		End Select
	End Function
	
'================================================
' 函数名：ChkMapPath
' 作  用：相对路径转换为绝对路径
' 参  数：strPath ----原路径
' 返回值：绝对路径
'================================================
Public Function ChkMapPath(ByVal strPath)
	On Error Resume Next
	Dim fullPath
	strPath = Replace(Replace(Trim(strPath), "//", "/"), "\\", "\")

	If strPath = "" Then strPath = "."
	If InStr(strPath,":\") = 0 Then 
		fullPath = Server.MapPath(strPath)
	Else
		strPath = Replace(strPath,"/","\")
		fullPath = Trim(strPath)
		If Right(fullPath, 1) = "\" Then
			fullPath = Left(fullPath, Len(fullPath) - 1)
		End If
	End If
	ChkMapPath = fullPath
End Function

	'-- 生成目录
	
	Public Function CreatPathEx(ByVal sPath)
		sPath = Replace(sPath, "/", "\")
		sPath = Replace(sPath, "\\", "\")
		On Error Resume Next
		
		Dim strHostPath,strPath
		Dim sPathItem,sTempPath
		Dim i,fso
		
		Set fso = Server.CreateObject("Scripting.FileSystemObject")
		strHostPath = Server.MapPath("/")
		If InStr(sPath, ":") = 0 Then sPath = Server.MapPath(sPath)
		If fso.FolderExists(sPath) Or Len(sPath) < 3 Then
			CreationPath = True
			Exit Function
		End If
		
		strPath = Replace(sPath, strHostPath, vbNullString,1,-1,1)
		sPathItem = Split(strPath, "\")
		
		If InStr(LCase(sPath), LCase(strHostPath)) = 0 Then
			sTempPath = sPathItem(0)
		Else
			sTempPath = strHostPath
		End If
		
		For i = 1 To UBound(sPathItem)
			If sPathItem(i) <> "" Then
				sTempPath = sTempPath & "\" & sPathItem(i)
				If fso.FolderExists(sTempPath) = False Then
					fso.CreateFolder sTempPath
				End If
			End If
		Next
		Set fso = Nothing
		If Err.Number <> 0 Then Err.Clear
		CreatPathEx = True
	End Function
	
'================================================
' 函数名：CreatePath
' 作  用：按月份自动创建文件夹
' 参  数：fromPath ----原文件夹路径
'================================================
Function CreatePath(fromPath)
	Dim objFSO, uploadpath
	uploadpath = Year(Now) & "-" & Month(Now) '以年月创建上传文件夹，格式：2003－8
	On Error Resume Next
	Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
	If objFSO.FolderExists(Server.MapPath(fromPath & uploadpath)) = False Then
		objFSO.CreateFolder Server.MapPath(fromPath & uploadpath)
	End If
	If Err.Number = 0 Then
		CreatePath = uploadpath & "/"
	Else
		CreatePath = ""
	End If
	Set objFSO = Nothing
End Function	
	'================================================
	'函数名：FilesDelete
	'作  用：FSO删除文件
	'参  数：filepath   ----文件路径
	'返回值：False  ----  True
	'================================================
	Public Function FileDelete(ByVal FilePath)
		'On Error Resume Next
		FileDelete = False
		Dim fso
		Set fso = Server.CreateObject("Scripting.FileSystemObject")
		If FilePath = "" Then Exit Function
		If InStr(FilePath, ":") = 0 Then FilePath = Server.MapPath(FilePath)
		If fso.FileExists(FilePath) Then
			fso.DeleteFile FilePath, True
			FileDelete = True
		End If
		Set fso = Nothing
		If Err.Number <> 0 Then Err.Clear
	End Function
	'================================================
	'函数名：FolderDelete
	'作  用：FSO删除目录
	'参  数：folderpath   ----目录路径
	'返回值：False  ----  True
	'================================================
	Public Function FolderDelete(ByVal FolderPath)
		FolderDelete = False
		On Error Resume Next
		Dim fso
		Set fso = Server.CreateObject("Scripting.FileSystemObject")
		If FolderPath = "" Then Exit Function
		If InStr(FolderPath, ":") = 0 Then FolderPath = Server.MapPath(FolderPath)
		If fso.FolderExists(FolderPath) Then
			fso.DeleteFolder FolderPath, True
			FolderDelete = True
		End If
		Set fso = Nothing
		If Err.Number <> 0 Then Err.Clear
	End Function
	'================================================
	'函数名：CopyToFile
	'作  用：复制文件
	'参  数：SoureFile   ----原文件路径
	'        NewFile  ----目标文件路径
	'================================================
	Public Function CopyToFile(ByVal SoureFile, ByVal NewFile)
		'On Error Resume Next
		If SoureFile = "" Then Exit Function
		If NewFile = "" Then Exit Function
		If InStr(SoureFile, ":") = 0 Then SoureFile = Server.MapPath(SoureFile)
		If InStr(NewFile, ":") = 0 Then NewFile = Server.MapPath(NewFile)
		Dim fso
		Set fso = Server.CreateObject("Scripting.FileSystemObject")
		If fso.FileExists(SoureFile) Then
			fso.CopyFile SoureFile, NewFile
		End If
		Set fso = Nothing
		If Err.Number <> 0 Then Err.Clear
	End Function
	
	
	'================================================
	'函数名：CopyToFolder
	'作  用：复制文件夹
	'参  数：SoureFolder   ----原路径
	'        NewFolder  ----目标路径
	'================================================
	Public Function CopyToFolder(ByVal SoureFolder, ByVal NewFolder)
		On Error Resume Next
		If SoureFolder = "" Then Exit Function
		If NewFolder = "" Then Exit Function
		If InStr(SoureFolder, ":") = 0 Then SoureFolder = Server.MapPath(SoureFolder)
		If InStr(NewFolder, ":") = 0 Then NewFolder = Server.MapPath(NewFolder)
		Dim fso
		Set fso = Server.CreateObject("Scripting.FileSystemObject")
		If fso.FolderExists(SoureFolder) Then
			fso.CopyFolder SoureFolder, NewFolder
		End If
		Set fso = Nothing
		If Err.Number <> 0 Then Err.Clear
	End Function
	'================================================
	'函数名：CreatedTextFile
	'作  用：创建文本文件
	'参  数：filename  ----文件名
	'        body  ----主要内容
	'================================================
	Public Function CreatedTextFile(ByVal fromPath, ByVal body)
		On Error Resume Next
		Dim fso,fff
		If InStr(fromPath, ":") = 0 Then fromPath = Server.MapPath(fromPath)
		Set fso = Server.CreateObject("Scripting.FileSystemObject")
		Set fff = fso.OpenTextFile(fromPath, 2, True)
		fff.Write body
		fff.Close
		Set fff = Nothing
		Set fso = Nothing
		If Err.Number <> 0 Then Err.Clear
	End Function
	'
	Public Function CreatedTextFiles(ByVal FileName, ByVal body)
		On Error Resume Next
		If InStr(FileName, ":") = 0 Then FileName = Server.MapPath(FileName)
		Dim oStream
		Set oStream = CreateObject("ADODB.Stream")
		oStream.Type = 2 '设置为可读可写
		oStream.Mode = 3 '设置内容为文本
		oStream.Charset = "GB2312"
		oStream.Open
		oStream.Position = oStream.Size
		oStream.WriteText body
		oStream.SaveToFile FileName, 2
		oStream.Close
		Set oStream = Nothing
		If Err.Number <> 0 Then Err.Clear
	End Function
	

	'================================================
	'函数名：Readfile
	'作  用：读取文件内容
	'参  数：fromPath   ----来源文件路径
	'================================================
	Public Function Readfile(ByVal fromPath)
		On Error Resume Next
		Dim strTemp,fso,f
		If InStr(fromPath, ":") = 0 Then fromPath = Server.MapPath(fromPath)
		Set fso = Server.CreateObject("Scripting.FileSystemObject")
		If fso.FileExists(fromPath) Then
			Set f = fso.OpenTextFile(fromPath, 1, True)
			strTemp = f.ReadAll
			f.Close
			Set f = Nothing
		End If
		Set fso = Nothing
		Readfile = strTemp
		If Err.Number <> 0 Then Err.Clear
	End Function
	
	'================================================
	'函数名：CutMatchContent
	'作  用：截取相匹配的内容
	'参  数：Str   ----原字符串
	'        PatStr   ----符合条件字符
	'================================================
	Public Function CutMatchContent(ByVal str, ByVal start, ByVal last, ByVal Condition)
        
		Dim Match,s,re
		Dim FilterStr,MatchStr
		Dim strContent,ArrayFilter
		Dim i, n,bRepeat
		
		If Len(start) = 0 Or Len(last) = 0 Then Exit Function
		
		On Error Resume Next
		
		MatchStr = "(" & CorrectPattern(start) & ")(.+?)(" & CorrectPattern(last) & ")"

		Set re = New RegExp
		re.IgnoreCase = True
		re.Global = True
		re.Pattern = MatchStr
		Set s = re.Execute(str)
		n = 0
		For Each Match In s
			If n = 0 Then
				n = n + 1
				ReDim ArrayFilter(n)
				ArrayFilter(n) = Match
			Else
				bRepeat = False
				For i = 0 To UBound(ArrayFilter)
					If UCase(Match) = UCase(ArrayFilter(i)) Then
						bRepeat = True
						Exit For
					End If
				Next
				If bRepeat = False Then
					n = n + 1
					ReDim Preserve ArrayFilter(n)
					ArrayFilter(n) = Match
				End If
			End If
		Next
		
		Set s = Nothing
		Set re = Nothing
		
		If CBool(Condition) Then
			strContent = Join(ArrayFilter, "|||")
		Else
			strContent = Join(ArrayFilter, "|||")
			strContent = Replace(strContent, start, "")
			strContent = Replace(strContent, last, "")
		End If
		
		CutMatchContent = Replace(strContent, "|||", vbNullString, 1, 1)
	End Function
	
	Function CutFixContent(ByVal str, ByVal start, ByVal last, ByVal n)
		Dim strTemp