图片批量切割VB源代码.docx
- 文档编号:10280778
- 上传时间:2023-02-09
- 格式:DOCX
- 页数:16
- 大小:53.01KB
图片批量切割VB源代码.docx
《图片批量切割VB源代码.docx》由会员分享,可在线阅读,更多相关《图片批量切割VB源代码.docx(16页珍藏版)》请在冰豆网上搜索。
图片批量切割VB源代码
一.
二.
PicBmpAotoRedraw属性:
True
AutoSize:
:
True
List1Style属性:
1
PicVisible属性:
Flase
三.
‘标准模块Module1的代码
OptionExplicit
'类型定义
TypeBrowseInfo
hwndOwnerAsLong
pIDLRootAsLong
pszDisplayNameAsLong
lpszTitleAsLong
ulFlagsAsLong
lpfnCallbackAsLong
lParamAsLong
iImageAsLong
EndType
'选择文件夹
PublicDeclareFunctionlstrcatLib"kernel32"Alias"lstrcatA"(ByVallpString1AsString,ByVallpString2As_
String)AsLong
PublicDeclareFunctionSHBrowseForFolderLib"shell32.dll"Alias"SHBrowseForFolderA"(lpBrowseInfoAsBrowseInfo)_
AsLong
PublictBrowseInfoAsBrowseInfo
PublicDeclareFunctionSHGetPathFromIDListLib"shell32.dll"Alias"SHGetPathFromIDListA"(ByValpidlAsLong,_
ByValpszPathAsString)AsLong
PublicszTitleAsString
PublicConstBIF_RETURNONLYFSDIRS=1
PublicConstBIF_DONTGOBELOWDOMAIN=2
PublicConstMAX_PATH=1024
PubliclpIDListAsLong
PublicFunctionSelectFolder(szTitleAsString)AsString
DimSBuffer1AsString
'szTitle="选择文件夹"
'Getfolderfromuser
WithtBrowseInfo
.hwndOwner=FrmCut.hWnd
.lpszTitle=lstrcat(szTitle,"")
.ulFlags=BIF_RETURNONLYFSDIRS+BIF_DONTGOBELOWDOMAIN
EndWith
lpIDList=SHBrowseForFolder(tBrowseInfo)
If(lpIDList)Then
'CmdSearch.Enabled=True
SBuffer1=Space(MAX_PATH)
SHGetPathFromIDListlpIDList,SBuffer1
SBuffer1=Left(SBuffer1,InStr(SBuffer1,vbNullChar)-1)
IfRight(SBuffer1,1)<>"\"Then
SBuffer1=SBuffer1&"\"
EndIf
EndIf
SelectFolder=SBuffer1
EndFunction
‘标准模块MThansJpg的代码
'格式转换
PublicTypeGUID
Data1AsLong
Data2AsInteger
Data3AsInteger
Data4(0To7)AsByte
EndType
PublicTypeGdiplusStartupInput
GdiplusVersionAsLong
DebugEventCallbackAsLong
SuppressBackgroundThreadAsLong
SuppressExternalCodecsAsLong
EndType
PublicTypeEncoderParameter
GUIDAsGUID
NumberOfValuesAsLong
typeAsLong
ValueAsLong
EndType
PublicTypeEncoderParameters
CountAsLong
ParameterAsEncoderParameter
EndType
PublicDeclareFunctionGdiplusStartupLib"GDIPlus"(tokenAsLong,inputbufAsGdiplusStartupInput,ByValoutputbufAsLong)AsLong
PublicDeclareFunctionGdiplusShutdownLib"GDIPlus"(ByValtokenAsLong)AsLong
PublicDeclareFunctionGdipCreateBitmapFromHBITMAPLib"GDIPlus"(ByValhbmAsLong,ByValhpalAsLong,BitmapAsLong)AsLong
PublicDeclareFunctionGdipDisposeImageLib"GDIPlus"(ByValImageAsLong)AsLong
PublicDeclareFunctionGdipSaveImageToFileLib"GDIPlus"(ByValImageAsLong,ByValfilenameAsLong,clsidEncoderAsGUID,encoderParamsAsAny)AsLong
PublicDeclareFunctionCLSIDFromStringLib"ole32"(ByValstrAsLong,idAsGUID)AsLong
PublicDeclareFunctionGdipCreateBitmapFromFileLib"GDIPlus"(ByValfilenameAsLong,BitmapAsLong)AsLong
PublicFunctionPictureBoxSaveJPG(ByValpictAsStdPicture,ByValfilenameAsString,OptionalByValqualityAsByte=80)AsBoolean
DimtSIAsGdiplusStartupInput
DimlResAsLong
DimlGDIPAsLong
DimlBitmapAsLong
'初始化GDI+
tSI.GdiplusVersion=1
lRes=GdiplusStartup(lGDIP,tSI,0)
IflRes=0Then
'从句柄创建GDI+图像
lRes=GdipCreateBitmapFromHBITMAP(pict.Handle,0,lBitmap)
IflRes=0Then
DimtJpgEncoderAsGUID
DimtParamsAsEncoderParameters
'初始化解码器的GUID标识
CLSIDFromStringStrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"),tJpgEncoder
'设置解码器参数
tParams.Count=1
WithtParams.Parameter'Quality
'得到Quality参数的GUID标识
CLSIDFromStringStrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"),.GUID
.NumberOfValues=1
.type=4
.Value=VarPtr(quality)
EndWith
'保存图像
lRes=GdipSaveImageToFile(lBitmap,StrPtr(filename),tJpgEncoder,tParams)
'销毁GDI+图像
GdipDisposeImagelBitmap
EndIf
'销毁GDI+
GdiplusShutdownlGDIP
EndIf
IflResThen
PictureBoxSaveJPG=False
Else
PictureBoxSaveJPG=True
EndIf
EndFunction
‘窗体FrmCut代码
OptionExplicit
PrivatePicOkAsBoolean'装入图片标志
'画抓取矩形框
PrivateOld_XAsSingle
PrivateOld_YAsSingle
PrivateisMouseDownAsBoolean'判断第一还是第二次按下鼠标
PrivateBox_X0AsSingle
PrivateBox_Y0AsSingle
PrivateBox_X1AsSingle
PrivateBox_Y1AsSingle
PrivatePenColorAsLong
PrivateCrossColorAsLong
PrivateXxAsSingle'矩形的第二个顶点坐标
PrivateYyAsSingle
PrivateReDrawAsBoolean'重新选择标志
PrivatelineokAsBoolean
'文件夹浏览
PrivateSBufferAsString'文件夹路径
'全选检查框
PrivateSubCheck1_Click()
DimiAsLong
IfCheck1=1Then
Fori=List1.ListCount-1To0Step-1
List1.Selected(i)=True
Nexti
Else
Fori=0ToList1.ListCount-1
List1.Selected(i)=False
Nexti
EndIf
EndSub
'浏览按钮
PrivateSubCmdOpen_Click()
DimiAsLong
OnLocalErrorResumeNext
'CmdSearch.Enabled=False
'Getfolderfromuser
SBuffer=SelectFolder("选择源文件夹")
TxtDir.Text=SBuffer
List1.Clear
File1.Path=SBuffer
Fori=0ToFile1.ListCount-1
List1.AddItemFile1.List(i)
Nexti
CmdSelect.Enabled=True
Check1.Value=0
HScroll1_Change
VScroll1_Change
EndSub
'退出按钮
PrivateSubCmdExit_Click()
End
EndSub
'切割按钮
PrivateSubCmdCut_Click()
DimPicTopAsSingle
DimPicLeftAsSingle
DimPicRightAsSingle
DimPicLowAsSingle
DimPicHAsSingle,PicWAsSingle
DimiAsLong
DimFNameAsString
DimFloderNameAsString
'PicBmp.Line(Box_X0,Box_Y0)-(Xx,Yy),PenColor,B
PicTop=Box_Y0
PicLeft=Box_X0
PicLow=PicBmp.Height-Yy
PicRight=PicBmp.Width-Xx
FloderName=SelectFolder("选择存放目标文件夹")
IfRight(FloderName,1)<>"\"ThenFloderName=FloderName&"\"
CmdCut.Enabled=False
CmdSelect.Enabled=False
Fori=0ToFile1.ListCount-1
IfList1.Selected(i)Then
FName=SBuffer&List1.List(i)
Me.PicBmp.Picture=LoadPicture(FName)
PicW=PicBmp.Width-PicRight-PicLeft
PicH=PicBmp.Height-PicLow-PicTop
IfPicW>0AndPicH>0Then
Pic.Height=PicH
Pic.Width=PicW
Pic.PaintPicturePicBmp.Image,0,0,PicW,PicH,Box_X0,Box_Y0,PicW,PicH
Pic.Picture=Pic.Image
PicBmp.Picture=Pic.Picture
'SavePicturePicBmp.Image,FloderName&List1.List(i)
'c.CreateFromPicturePicBmp.Picture
IfNotPictureBoxSaveJPG(PicBmp,FloderName&List1.List(i))Then
MsgBoxFName&"保存失败",vbExclamation
EndIf
Else
MsgBoxFName&"无法切割"
EndIf
EndIf'"&
Nexti
'PicTop=Box_Y0
'PicLeft=Box_Y0
'PicRight=PicBmp.Width-Xx
'PicLow=PicBmp.Height-Yy
'PicW=Xx-Box_X0
'PicH=Yy-Box_Y0
'Pic.Height=PicH
'Pic.Width=PicW
'Pic.PaintPicturePicBmp.Image,0,0,PicW,PicH,Box_X0,Box_Y0,PicW,PicH
'Pic.Picture=Pic.Image
'PicBmp.Picture=Pic.Picture
EndSub
PrivateSubCmdSelect_Click()'选择按钮
PicBmp.Line(Box_X0,Box_Y0)-(Xx,Yy),PenColor,B
ReDraw=True
lineok=True
CmdSelect.Enabled=False
CmdCut.Enabled=False
EndSub
PrivateSubForm_Load()
CrossColor=QBColor(8)
PenColor=QBColor(15)
PicBmp.DrawMode=vbXorPen
'
PicBmp.MousePointer=vbCustom
isMouseDown=False
Box_X0=Box_X1=Box_Y0=Box_Y1=0
PicOk=False
CmdCut.Enabled=False
CmdSelect.Enabled=False
File1.Pattern="*.jpg;*.bmp"
EndSub
'水平滚动条
PrivateSubHScroll1_Change()
PicBmp.Left=-HScroll1.Value*(PicBmp.Width-PicScroll.Width)\100
EndSub
'文件列表框
PrivateSubList1_Click()
DimFNameAsString
FName=SBuffer&List1.List(List1.ListIndex)
'MsgBoxFName
TxtDir.Text=FName
Me.PicBmp.Picture=LoadPicture(FName)
PicOk=True
ReDraw=True
lineok=True
CmdCut.Enabled=False
CmdSelect.Enabled=True
EndSub
'确定选择矩形
PrivateSubPicBmp_MouseDown(ButtonAsInteger,ShiftAsInteger,xAsSingle,yAsSingle)
IfPicOkAndReDrawAndButton=1Then
IfisMouseDownAndButton=1Then
'定义第二个点,先前已经用鼠标定义了一个点
Box_X1=x
Box_Y1=y
isMouseDown=False
'PicBmp.DrawMode=vbCopyPen
PicBmp.Line(Box_X0,Box_Y0)-(Box_X1,Box_Y1),PenColor,B
PicBmp.Line(Box_X0,Box_Y0)-(x,y),PenColor,B
Old_X=x
Old_Y=y
Xx=Box_X1
Yy=Box_Y1
isMouseDown=False
ReDraw=False
CmdSelect.Enabled=True
CmdCut.Enabled=True
Else
'定义矩形的第一个顶点,则擦除光标
PicBmp.Line(0,y)-(PicBmp.ScaleWidth,y),CrossColor'画一个光标
PicBmp.Line(x,0)-(x,PicBmp.ScaleHeight),CrossColor
Box_X0=x
Box_Y0=y
isMouseDown=True
EndIf
EndIf
EndSub
PrivateSubPicBmp_MouseMove(ButtonAsInteger,ShiftAsInteger,xAsSingle,yAsSingle)
IfPicOkAndReDrawThen
IfisMouseDown=TrueThen
'拖动鼠标来定义矩形的另外一个顶点,此时擦除前一个矩形,绘制新的矩形
PicBmp.Line(Box_X0,Box_Y0)-(Old_X,Old_Y),PenColor,B
PicBmp.Line(Box_X0,Box_Y0)-(x,y),PenColor,B
Else
IflineokThen
'画新的光标线
PicBmp.Line(0,y)-(PicBmp.ScaleWidth,y),CrossColor
PicBmp.Line(x,0)-(x,PicBmp.ScaleHeight),CrossColor
lineok=False
Else
'消除旧光标线
PicBmp.Line(0,Old_Y)-(PicBmp.ScaleWidth,Old_Y),CrossColor
PicBmp.Line(Old_X,0)-(Old_X,PicBmp.ScaleHeight),CrossColor
'画新的光标线
PicBmp.Line(0,y)-(PicBmp.ScaleWidth,y),CrossColor
PicBmp.Line(x,0)-(x,PicBmp.ScaleHeight),CrossColor
lineok=False
EndIf
EndIf
Old_X=x
Old_Y=y
EndIf
EndSub
'垂直滚动条
PrivateSubVScroll1_Change()
PicBmp.Top=-VScroll1.Value*(PicBmp.Height-PicScroll.Height)\100
EndSub
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- 图片 批量 切割 VB 源代码
![提示](https://static.bdocx.com/images/bang_tan.gif)