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 '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
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
