结合FSO操作和Aspjpeg组件写的Class-巨人网络通讯

主页 > 知识库 > 结合FSO操作和Aspjpeg组件写的Class

结合FSO操作和Aspjpeg组件写的Class

《结合FSO操作写的一个Class》

尚在完善中,基本功能已具备.
也可作为初学者的教程

程序代码
%
'***************************** CDS系统 FSO操作类 Beta1 *****************************
'调用方法: Set Obj=New FSOControl
'所有路径必须为绝对路径,请采用Server.MapPath方法转换路径后再定义变量
'------ FileRun ---------------------------------------
'
'必选参数:
'FilePath ------ 处理文件路径
'
'可选参数:
'FileAllowType ------ 处理文件允许的类型,定义方法例: gif|jpg|png|txt
'FileNewDir ------ 文件处理后保存到的目录
'FileNewName ------ 新文件名前缀,请不要添加后缀, 例: sample.txt 则为 sample
'CoverPr ------ 是否覆盖已有的文件 0为否 1为是默认为1
'deletePr ------ 是否删除原文件 0为否 1为是默认为1
'---------------------------------------------------------

'------ UpDir(path) 取path的父目录
'path可为文件,也可为目录

'------ GetPrefixName(path) 取文件名前缀
'path必须为文件,可为完整路径,也可是单独文件名

'------ GetFileName(path) 取文件名
'path必须为文件,可为完整路径,也可是单独文件名

'------ GetExtensionName(path) 取文件名后缀,不包含"."
'path必须为文件,可为完整路径,也可是单独文件名

'------ FileIs(path) path是否为一文件
'如为,返回 true 否则返回 false
'------ FolderCreat(Path)
'------ Folderdelete(Path,FileIF)
'------ FileCopy(Path_From,Path_To,CoverIF)
'------ FileMove(Path_From,Path_To,CoverIF)
'------ Filedelete(Path)
'------ Filerename(OldName,NewName,CoverIf)

Class FSOControl

Dim FSO
Private File_Path,File_AllowType,File_NewFolder_Path,File_NewName,File_CoverIf,File_deleteIf
Public Property Let FilePath(StrType)
File_Path=StrType
End Property
Public Property Let FileAllowType(StrType)
File_AllowType=StrType
End Property
Public Property Let FileNewDir(StrType)
File_NewFolder_Path=StrType
End Property
Public Property Let FileNewName(StrType)
File_NewName=StrType
End Property
Public Property Let CoverPr(LngSize)
If isNumeric(LngSize) then
File_CoverIf=Clng(LngSize)
End If
End Property
Public Property Let deletePr(LngSize)
If isNumeric(LngSize) then
File_deleteIf=Clng(LngSize)
End If
End Property

Private Sub Class_Initialize()
Set FSO=createObject("Scripting.FileSystemObject")
File_Path=""
File_AllowType="gif|jpg|png|txt"
File_NewFolder_Path=""
File_NewName=""
File_CoverIf=1
File_deleteIf=0
End Sub
Private Sub Class_Terminate()
Err.Clear
Set FSO=Nothing
End Sub

Public Function UpDir(ByVal D)
If Len(D) = 0 then
UpDir=""
Else
UpDir=Left(D,InStrRev(D,"\")-1)
End If
End Function
Public Function GetPrefixName(ByVal D)
If Len(D) = 0 then
GetPrefixName=""
Else
FileName=GetFileName(D)
GetPrefixName=Left(FileName,InStrRev(FileName,".")-1)
End If
End Function
Public Function GetFileName(name)
FileName=Split(name,"\")
GetFileName=FileName(Ubound(FileName))
End Function
Public Function GetExtensionName(name)
FileName=Split(name,".")
GetExtensionName=FileName(Ubound(FileName))
End Function
Public Function FileIs(Path)
If fso.FileExists(Path) then
FileIs=true
Else
FileIs=false
End If
End Function

Public Function FileOpen(Path,NewFile,ReadAction,LineCount)
If FileIs(Path)=False then
If NewFile>1 then
FileOpen=False
ElseIf FolderIs(UpDir(Path))=False then
FileOpen=False
Exit Function
Else
fso.OpenTextFile Path,1,True
FileOpen=""
End If
Exit Function
End If
Set FileOption=fso.GetFile(Path)
If FileOption.size=0 then
Set FileOption=Nothing
FileOpen=""
Exit Function
End If
Set FileOption=Nothing
Set FileText=fso.OpenTextFile(Path,1)
If IsNumeric(ReadAction) then
FileOpen=FileText.Read(ReadAction)
ElseIf Ucase(ReadAction)="ALL" then
FileOpen=FileText.ReadAll()
ElseIf Ucase(ReadAction)="LINE" then
If Not(IsNumeric(LineCount)) or LineCount=0 then
FileOpen=False
Set FileText=Nothing
Exit Function
Else
i=0
Do While Not FileText.AtEndOfStream
FileOpen=FileOpenFileText.ReadLine
i=i+1
If i=LineCount then Exit Do
Loop
End If
End If
Set FileText=Nothing
End Function

Public Function FileWrite(Path,WriteStr,NewFile)
If FolderIs(UpDir(Path))=False then
FileWrite=False
Exit Function
ElseIf FileIs(Path)=False and NewFile>1 then
FileWrite=False
Exit Function
End If
Set FileText=fso.OpenTextFile(Path,2,True)
FileText.Write WriteStr
Set FileText=Nothing
FileWrite=True
End Function

Public Function FolderIs(Path)
If fso.FolderExists(Path) then
FolderIs=true
Else
FolderIs=false
End If
End Function
Public Function FolderCreat(Path)
If fso.FolderExists(Path) then
FolderCreat="指定要创建目录已存在"
Exit Function
ElseIf Not(fso.FolderExists(UpDir(Path))) then
FolderCreat="指定要创建的目录路径错误"
Exit Function
End If
fso.createFolder(Path)
FolderCreat=True
End Function
Public Function Folderdelete(Path,FileIF)
If Not(fso.FolderExists(Path)) then
Folderdelete="指定要删除的目录不存在"
Exit Function
End If
If FileIF=1 then
Set FsoFile = Fso.GetFolder(Path)
If(FsoFile.SubFolders.count>0 or FsoFile.Files.count>0) then
Set FsoFile=Nothing
Folderdelete="只要要删除的目录下含有文件或子目录,不允许删除"
Exit Function
End If
Set FsoFile=Nothing
End If
Fso.deleteFolder(Path)
Folderdelete=True
End Function
Public Function FileCopy(Path_From,Path_To,CoverIF)
If Not(fso.FileExists(Path_From)) then
FileCopy="指定要复制的文件不存在"
Exit Function
ElseIf Not(fso.FolderExists(UpDir(Path_To))) then
FileCopy="指定要复制到的目录不存在"
Exit Function
End If
If CoverIF=0 and fso.FileExists(Path_To) then
FileCopy="指定要复制到的目录下已存在相同名称文件,不允许覆盖"
Exit Function
End If
fso.CopyFile Path_From,Path_To
FileCopy=True
End Function
Public Function FileMove(Path_From,Path_To,CoverIF)
If Not(fso.FileExists(Path_From)) then
FileMove="指定要移动的文件不存在"
Exit Function
ElseIf Not(fso.FolderExists(UpDir(Path_To))) then
FileMove="指定要移动到的目录不存在"
Exit Function
End If
If fso.FileExists(Path_To) then
If CoverIF=0 then
FileMove="指定要移动到的目录下已存在相同名称文件,不允许覆盖"
Exit Function
Else
Call Filedelete(Path_To)
End If
End If
fso.MoveFile Path_From,Path_To
FileMove=True
End Function
Public Function Filedelete(Path)
If Not(fso.FileExists(Path)) then
Filedelete="指定要删除的文件不存在"
Exit Function
End If
Fso.deleteFile Path
Filedelete=True
End Function
Public Function Filerename(OldName,NewName,CoverIf)
NewName=NewName"."GetExtensionName(OldName)
If GetFileName(OldName)=NewName then
Filerename="更改前的文件与更改后的文件名称相同"
Exit Function
ElseIf Not(fso.FileExists(OldName)) then
Filerename="指定更改名称的文件不存在"
Exit Function
ElseIf fso.FileExists(UpDir(OldName)"\"NewName) then
If CoverIf=0 then
Filerename="目录下已存在与更改后的文件名称相同的文件,不允许覆盖"
Exit Function
Else
Call Filedelete(UpDir(OldName)"\"NewName)
End If
End If
Set FsoFile=fso.GetFile(OldName)
FsoFile.Name=NewName
Set FsoFile=Nothing
Filerename=True
End Function

Public Function FileRun()
If File_NewFolder_Path="" and File_NewName="" then
FileRun="此操作执行后并未对指定文件产生变动,系统自动中止"
Exit Function
ElseIf File_Path="" or Not(fso.FileExists(File_Path)) then
FileRun="要进行操作的文件不存在"
Exit Function
ElseIf Instr(File_AllowType,GetExtensionName(File_Path))=0 then
FileRun="要进行操作的文件被系统拒绝,允许的格式为: "Replace(File_AllowType,"|"," ")
Exit Function
End If

If File_NewFolder_Path="" then
File_NewFolder_Path=UpDir(File_Path)
ElseIf Not(fso.FolderExists(File_NewFolder_Path)) then
FileRun="指定要移动到的目录不存在"
Exit Function
End If
If Right(File_NewFolder_Path,1)>"\" then File_NewFolder_Path=File_NewFolder_Path"\"
If File_NewName="" then
File_NewPath=File_NewFolder_PathGetFileName(File_Path)
Else
File_NewPath=File_NewFolder_PathFile_NewName"."GetExtensionName(File_Path)
End If
If File_Path=File_NewPath then
FileRun="此操作执行后并未对指定文件产生变动,系统自动中止"
Exit Function
ElseIf UpDir(File_Path)>UpDir(File_NewPath) then
If File_deleteIf=1 then
Call FileMove(File_Path,File_NewPath,File_CoverIf)
Else
Call FileCopy(File_Path,File_NewPath,File_CoverIf)
End If
FileRun=True
Else
'If File_deleteIf=1 then
Call Filerename(File_Path,GetPrefixName(File_NewPath),File_CoverIf)
'Else
' Call FileCopy(File_Path,File_NewPath,File_CoverIf)
'End If
FileRun=True
End If
End Function
End Class
%>

《ASPJPEG综合操作CLASS》
>>>---------我想分页！--这么长的文章，在这里来个分页多好啊！哈哈----------
《ASPJPEG综合操作CLASS》
基本上能实现ASPJPEG的所有功能
代码有详细注释,还不懂的请提出

有建议及更多功能提议的请提出

谢谢

程序代码
%
'ASPJPEG综合操作CLASS
'Authour: tony 05/09/05
Class AspJpeg
Dim AspJpeg_Obj,obj
Private Img_MathPath_From,Img_MathPath_To,Img_Reduce_Size,CoverIf
Private Img_Frame_Size,Img_Frame_Color,Img_Frame_Solid,Img_Frame_Width,Img_Frame_Height
Private Img_Font_Content,Img_Font_Family,Img_Font_Color,Img_Font_Quality,Img_Font_Size,Img_Font_Bold,Img_Font_X,Img_Font_Y
Private Img_PicIn_Path,Img_PicIn_X,Img_PicIn_Y
'--------------取原文件路径
Public Property Let MathPathFrom(StrType)
Img_MathPath_From=StrType
End Property

'--------------取文件保存路径
Public Property Let MathPathTo(strType)
Img_MathPath_To=strType
End Property

'--------------保存文件时是否覆盖已有文件
Public Property Let CovePro(LngSize)
If LngSize=0 or LngSize=1 or LngSize=true or LngSize=false then
CoverIf=LngSize
End If
End Property

'---------------取缩略图/放大图缩略值
Public Property Let ReduceSize(LngSize)
If isNumeric(LngSize) then
Img_Reduce_Size=LngSize
End If
End Property

'---------------取描边属性
'边框粗细
Public Property Let FrameSize(LngSize)
If isNumeric(LngSize) then
Img_Frame_Size=Clng(LngSize)
End If
End Property
'边框宽度
Public Property Let FrameWidth(LngSize)
If isNumeric(LngSize) then
Img_Frame_Width=Clng(LngSize)
End If
End Property
'边框高度
Public Property Let FrameHeight(LngSize)
If isNumeric(LngSize) then
Img_Frame_Height=Clng(LngSize)
End If
End Property
'边框颜色
Public Property Let FrameColor(strType)
If strType>"" then
Img_Frame_Color=strType
End If
End Property
'边框是否加粗
Public Property Let FrameSolid(LngSize)
If LngSize=1 or LngSize=0 or LngSize=true or LngSize=false then
Img_Frame_Solid=LngSize
End If
End Property

'---------------取插入文字属性
'插入的文字
Public Property Let Content(strType)
If strType>"" then
Img_Font_Content=strType
End If
End Property
'文字字体
Public Property Let FontFamily(strType)
If strType>"" then
Img_Font_Family=strType
End If
End Property
'文字颜色
Public Property Let FontColor(strType)
If strType>"" then
Img_Font_Color=strType
End If
End Property
'文字品质
Public Property Let FontQuality(LngSize)
If isNumeric(LngSize) then
Img_Font_Quality=Clng(LngSize)
End If
End Property
'文字大小
Public Property Let FontSize(LngSize)
If isNumeric(LngSize) then
Img_Font_Size=Clng(LngSize)
End If
End Property
'文字是否加粗
Public Property Let FontBold(LngSize)
If LngSize=1 or LngSize=0 or LngSize=true or LngSize=false then
Img_Font_Bold=LngSize
End If
End Property
'输入文字的X坐标
Public Property Let FontX(LngSize)
If isNumeric(LngSize) then
Img_Font_X=Clng(LngSize)
End If
End Property
'输入文字的Y坐标
Public Property Let FontY(LngSize)
If isNumeric(LngSize) then
Img_Font_Y=Clng(LngSize)
End If
End Property

'---------------取插入图片属性
'插入图片的路径
Public Property Let PicInPath(strType)
Img_PicIn_Path=strType
End Property
'图片插入的X坐标
Public Property Let PicInX(LngSize)
If isNumeric(LngSize) then
Img_PicIn_X=Clng(LngSize)
End If
End Property
'图片插入的Y坐标
Public Property Let PicInY(LngSize)
If isNumeric(LngSize) then
Img_PicIn_Y=Clng(LngSize)
End If
End Property

Private Sub Class_Initialize()
Set AspJpeg_Obj=createObject("Persits.Jpeg")
Img_MathPath_From=""
Img_MathPath_To=""
Img_Reduce_Size=150
Img_Frame_Size=1
'Img_Frame_Width=0
'Img_Frame_Height=0
'Img_Frame_Color="H000000"
'Img_Frame_Bold=false
Img_Font_Content="GoldenLeaf"
'Img_Font_Family="Arial"
'Img_Font_Color="H000000"
Img_Font_Quality=3
Img_Font_Size=14
'Img_Font_Bold=False
Img_Font_X=10
Img_Font_Y=5
'Img_PicIn_X=0
'Img_PicIn_Y=0
CoverIf=1

End Sub
Private Sub Class_Terminate()
Err.Clear
Set AspJpeg_Obj=Nothing
End Sub
'判断文件是否存在
Private Function FileIs(path)
Set fsos=Server.createObject("Scripting.FileSystemObject")
FileIs=fsos.FileExists(path)
Set fsos=Nothing
End Function

'判断目录是否存在
Private Function FolderIs(path)
Set fsos=Server.createObject("Scripting.FileSystemObject")
FolderIs=fsos.FolderExists(path)
Set fsos=Nothing
End Function
'*******************************************
'函数作用：取得当前文件的上一级路径
'*******************************************
Private Function UpDir(ByVal D)
If Len(D) = 0 then
UpDir=""
Else
UpDir=Left(D,InStrRev(D,"\")-1)
End If
End Function

Private Function Errors(Errors_id)
select Case Errors_id
Case "0"
Errors="指定文件不存在"
Case 1
Errors="指定目录不存在"
Case 2
Errors="已存在相同名称文件"
Case 3
Errors="参数溢出"
End select
End Function

'取图片宽度
Public Function ImgInfo_Width(Img_MathPath)
If Not(FileIs(Img_MathPath)) then
'Exit Function
ImgInfo_Width=Errors(0)
Else
AspJpeg_Obj.Open Img_MathPath
ImgInfo_Width=AspJpeg_Obj.width
End If
End Function
'取图片高度
Public Function ImgInfo_Height(Img_MathPath)
If Not(FileIs(Img_MathPath)) then
'Exit Function
ImgInfo_Height=Errors(0)
Else
AspJpeg_Obj.Open Img_MathPath
ImgInfo_Height=AspJpeg_Obj.height
End If
End Function
'生成缩略图/放大图
Public Function Img_Reduce()
If Not(FileIs(Img_MathPath_From)) then
Img_Reduce=Errors(0)
Exit Function
End If
If Not(FolderIs(UpDir(Img_MathPath_To))) then
Img_Reduce=Errors(1)
Exit Function
End If
If CoverIf=0 or CoverIf=False then
If FileIs(Img_MathPath_To) then
Img_Reduce=Errors(2)
Exit Function
End If
End If
AspJpeg_Obj.Open Img_MathPath_From
AspJpeg_Obj.PreserveAspectRatio = True
If AspJpeg_Obj.OriginalWidth>AspJpeg_Obj.OriginalHeight Then
AspJpeg_Obj.Width=Img_Reduce_Size
Else
AspJpeg_Obj.Height=Img_Reduce_Size
End If
If AspJpeg_Obj.OriginalWidth>Img_Reduce_Size or AspJpeg_Obj.OriginalHeight>Img_Reduce_Size Then
If AspJpeg_Obj.WidthImg_Reduce_Size or AspJpeg_Obj.HeightImg_Reduce_Size then
Set AspJpeg_Obj_New=createObject("Persits.Jpeg")
AspJpeg_Obj_New.new Img_Reduce_Size,Img_Reduce_Size,HFFFFFF
AspJpeg_Obj_New.DrawImage (150-AspJpeg_Obj.width)/2,(150-AspJpeg_Obj.height)/2,AspJpeg_Obj
If Img_Frame_Size>0 then
Call Img_Pen(AspJpeg_Obj_New)
End If
If Img_Font_Content>"" then
Img_Font_X=AspJpeg_Obj_New.Width/2
Img_Font_Y=AspJpeg_Obj_New.Height-15
Call Img_Font(AspJpeg_Obj_New)
End If
AspJpeg_Obj_New.Sharpen 1, 130
AspJpeg_Obj_New.Save Img_MathPath_To
Set AspJpeg_Obj_New=Nothing
Else
If Img_Frame_Size>0 then
Call Img_Pen(AspJpeg_Obj)
End If
If Img_Font_Content>"" then
Img_Font_X=AspJpeg_Obj.Width/2
Img_Font_Y=AspJpeg_Obj.Height-15
Call Img_Font(AspJpeg_Obj)
End If
AspJpeg_Obj.Sharpen 1, 130
AspJpeg_Obj.Save Img_MathPath_To
End If
Else
If Img_Frame_Size>0 then
Call Img_Pen(AspJpeg_Obj)
End If
If Img_Font_Content>"" then
Img_Font_X=AspJpeg_Obj.Width/2
Img_Font_Y=AspJpeg_Obj.Height-15
Call Img_Font(AspJpeg_Obj)
End If
AspJpeg_Obj.Sharpen 1, 130
AspJpeg_Obj.Save Img_MathPath_To
End If
End Function
'生成水印
Public Function Img_WaterMark()
If Not(FileIs(Img_MathPath_From)) then
Img_WaterMark=Errors(0)
Exit Function
End If
If Img_MathPath_To="" then
Img_MathPath_To=Img_MathPath_From
ElseIf Not(FolderIs(UpDir(Img_MathPath_To))) then
Img_WaterMark=Errors(1)
Exit Function
End If
If CoverIf=0 or CoverIf=false then
If Img_MathPath_To>Img_MathPath_From and FileIs(Img_MathPath_To) then
Img_WaterMark=Errors(2)
Exit Function
End If
End If
AspJpeg_Obj.Open Img_MathPath_From
If Img_PicIn_Path>"" then
If Not(FileIs(Img_PicIn_Path)) then
Img_WaterMark=Errors(0)
Exit Function
End If
Set AspJpeg_Obj_New=createObject("Persits.Jpeg")
AspJpeg_Obj_New.Open Img_PicIn_Path
AspJpeg_Obj.PreserveAspectRatio = True
AspJpeg_Obj_New.PreserveAspectRatio = True
If AspJpeg_Obj.OriginalWidthImg_Reduce_Size or AspJpeg_Obj.OriginalHeightImg_Reduce_Size then
Img_WaterMark=Errors(3)
Exit Function
End If
If AspJpeg_Obj_New.OriginalWidth>AspJpeg_Obj_New.OriginalHeight Then
AspJpeg_Obj_New.Width=Img_Reduce_Size
Else
AspJpeg_Obj_New.Height=Img_Reduce_Size
End If
If Img_PicIn_X="" then Img_PicIn_X=AspJpeg_Obj.Width-AspJpeg_Obj_New.Width
If Img_PicIn_Y="" then Img_PicIn_Y=AspJpeg_Obj.Height-AspJpeg_Obj_New.Height
AspJpeg_Obj.DrawImage Img_PicIn_X,Img_PicIn_Y,AspJpeg_Obj_New
Set AspJpeg_Obj_New=Nothing
End If
If Img_Frame_Size>0 then
Call Img_Pen(AspJpeg_Obj)
End If
If Img_Font_Content>"" then
Call Img_Font(AspJpeg_Obj)
End If
'AspJpeg_Obj.Sharpen 1, 130
AspJpeg_Obj.Save Img_MathPath_To
End Function
'生成框架
Private Function Img_Pen(Obj)
If Img_Frame_Width=0 then Img_Frame_Width=Obj.Width
If Img_Frame_Height=0 then Img_Frame_Height=Obj.Height
Obj.Canvas.Pen.Color = Img_Frame_Color
Obj.Canvas.Pen.Width = Img_Frame_Size
Obj.Canvas.Brush.Solid = Img_Frame_Solid
Obj.Canvas.Bar 1,1,Img_Frame_Width,Img_Frame_Height
End Function
'生成水印字
Private Function Img_Font(Obj)
Obj.Canvas.Font.Color = Img_Font_Color
Obj.Canvas.Font.Family = Img_Font_Family
Obj.Canvas.Font.Quality=Img_Font_Quality
Obj.Canvas.Font.Size=Img_Font_Size
Obj.Canvas.Font.Bold = Img_Font_Bold
Obj.Canvas.Print Img_Font_X,Img_Font_Y,Img_Font_Content
End Function
End Class

%>

标签：家电维修昌都泰州咸阳丽江昆明温州铁岭

巨人网络通讯声明：本文标题《结合FSO操作和Aspjpeg组件写的Class》，本文关键词结合,FSO,操作,和,Aspjpeg,；如发现本文内容存在版权问题，烦请提供相关信息告之我们，我们将及时沟通与处理。本站内容系统采集于网络，涉及言论、版权与本站无关。