图片批量切割VB源代码
一(
VScroll1 VScrollBar
PicScroll PictureBox Check1 CheckBox
CmdOpen CommandButton
PicBnp PictureBox
CmdSelect
CmdExit CommandButton HScroll1 HScrollBar TxtDir TextBox
Pic PictureBox CmdCut CommandButton
二(
PicBmp AotoRedraw属性 :True
AutoSize ::True
List1 Style属性:1
Pic Visible属性:Flase
三(
‘
模块Module1的代码
Option Explicit
'类型定义
Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
'选择文件夹
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal
lpString2 As _
String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA"
(lpBrowseInfo As BrowseInfo) _
As Long
Public tBrowseInfo As BrowseInfo
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA"
(ByVal pidl As Long, _
ByVal pszPath As String) As Long
Public szTitle As String
Public Const BIF_RETURNONLYFSDIRS = 1
Public Const BIF_DONTGOBELOWDOMAIN = 2
Public Const MAX_PATH = 1024
Public lpIDList As Long
Public Function SelectFolder(szTitle As String) As String
Dim SBuffer1 As String
'szTitle = "选择文件夹"
' Get folder from user
With tBrowseInfo
.hwndOwner = FrmCut.hWnd
.lpszTitle = lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
'CmdSearch.Enabled = True
SBuffer1 = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, SBuffer1
SBuffer1 = Left(SBuffer1, InStr(SBuffer1, vbNullChar) - 1)
If Right(SBuffer1, 1) <> "\" Then
SBuffer1 = SBuffer1 & "\"
End If
End If
SelectFolder = SBuffer1
End Function
‘标准模块MThansJpg的代码
'格式转换
Public Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Public Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Public Type EncoderParameter
GUID As GUID
NumberOfValues As Long
type As Long
Value As Long
End Type
Public Type EncoderParameters
Count As Long
Parameter As EncoderParameter
End Type
Public Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput,
ByVal outputbuf As Long) As Long
Public Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long Public Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hpal As Long, Bitmap As Long) As Long
Public Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long Public Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Public Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long Public Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, Bitmap As Long) As Long
Public Function PictureBoxSaveJPG(ByVal pict As StdPicture, ByVal filename As String, Optional ByVal
quality As Byte = 80) As Boolean
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
'初始化 GDI+
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI, 0)
If lRes = 0 Then
'从句柄创建 GDI+ 图像
lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
If lRes = 0 Then
Dim tJpgEncoder As GUID
Dim tParams As EncoderParameters
'初始化解码器的GUID标识
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
'设置解码器参数
tParams.Count = 1
With tParams.Parameter ' Quality
'得到Quality参数的GUID标识
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
.NumberOfValues = 1
.type = 4
.Value = VarPtr(quality)
End With
'保存图像
lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, tParams)
'销毁GDI+图像
GdipDisposeImage lBitmap
End If
'销毁 GDI+
GdiplusShutdown lGDIP
End If
If lRes Then
PictureBoxSaveJPG = False
Else
PictureBoxSaveJPG = True
End If
End Function
‘窗体FrmCut 代码
Option Explicit
Private PicOk As Boolean '装入图片标志
'画抓取矩形框
Private Old_X As Single Private Old_Y As Single Private isMouseDown As Boolean '判断第一还是第二次按下鼠标 Private Box_X0 As Single Private Box_Y0 As Single Private Box_X1 As Single Private Box_Y1 As Single Private PenColor As Long Private CrossColor As Long Private Xx As Single '矩形的第二个顶点坐标
Private Yy As Single
Private ReDraw As Boolean '重新选择标志
Private lineok As Boolean
'文件夹浏览
Private SBuffer As String '文件夹路径
'全选检查框
Private Sub Check1_Click()
Dim i As Long
If Check1 = 1 Then
For i = List1.ListCount - 1 To 0 Step -1
List1.Selected(i) = True
Next i
Else
For i = 0 To List1.ListCount - 1
List1.Selected(i) = False
Next i
End If
End Sub
'浏览按钮
Private Sub CmdOpen_Click() Dim i As Long
On Local Error Resume Next
'CmdSearch.Enabled = False
' Get folder from user
SBuffer = SelectFolder("选择源文件夹")
TxtDir.Text = SBuffer
List1.Clear
File1.Path = SBuffer
For i = 0 To File1.ListCount - 1
List1.AddItem File1.List(i)
Next i
CmdSelect.Enabled = True
Check1.Value = 0
HScroll1_Change
VScroll1_Change
End Sub
'退出按钮
Private Sub CmdExit_Click()
End
End Sub
'切割按钮
Private Sub CmdCut_Click()
Dim PicTop As Single
Dim PicLeft As Single
Dim PicRight As Single
Dim PicLow As Single
Dim PicH As Single, PicW As Single
Dim i As Long
Dim FName As String
Dim FloderName As String
'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("选择存放目标文件夹")
If Right(FloderName, 1) <> "\" Then FloderName = FloderName & "\"
CmdCut.Enabled = False
CmdSelect.Enabled = False
For i = 0 To File1.ListCount - 1
If List1.Selected(i) Then
FName = SBuffer & List1.List(i)
Me.PicBmp.Picture = LoadPicture(FName)
PicW = PicBmp.Width - PicRight - PicLeft
PicH = PicBmp.Height - PicLow - PicTop
If PicW > 0 And PicH > 0 Then
Pic.Height = PicH
Pic.Width = PicW
Pic.PaintPicture PicBmp.Image, 0, 0, PicW, PicH, Box_X0, Box_Y0, PicW,
PicH
Pic.Picture = Pic.Image
PicBmp.Picture = Pic.Picture
'SavePicture PicBmp.Image, FloderName & List1.List(i)
' c.CreateFromPicture PicBmp.Picture
If Not PictureBoxSaveJPG(PicBmp, FloderName & List1.List(i)) Then
MsgBox FName & "保存失败", vbExclamation
End If
Else
MsgBox FName & "无法切割"
End If
End If '" &
Next i
'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.PaintPicture PicBmp.Image, 0, 0, PicW, PicH, Box_X0, Box_Y0, PicW, PicH
'Pic.Picture = Pic.Image
'PicBmp.Picture = Pic.Picture
End Sub
Private Sub CmdSelect_Click() '选择按钮
PicBmp.Line (Box_X0, Box_Y0)-(Xx, Yy), PenColor, B ReDraw = True
lineok = True
CmdSelect.Enabled = False
CmdCut.Enabled = False
End Sub
Private Sub Form_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" End Sub
'水平滚动条
Private Sub HScroll1_Change()
PicBmp.Left = -HScroll1.Value * (PicBmp.Width - PicScroll.Width) \ 100
End Sub
'文件列表框
Private Sub List1_Click()
Dim FName As String
FName = SBuffer & List1.List(List1.ListIndex)
' MsgBox FName
TxtDir.Text = FName
Me.PicBmp.Picture = LoadPicture(FName)
PicOk = True
ReDraw = True
lineok = True
CmdCut.Enabled = False
CmdSelect.Enabled = True
End Sub
'确定选择矩形
Private Sub PicBmp_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If PicOk And ReDraw And Button = 1 Then
If isMouseDown And Button = 1 Then
'定义第二个点,先前已经用鼠标定义了一个点
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
End If
End If
End Sub
Private Sub PicBmp_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If PicOk And ReDraw Then
If isMouseDown = True Then
'拖动鼠标来定义矩形的另外一个顶点,此时擦除前一个矩形,绘制新的矩形
PicBmp.Line (Box_X0, Box_Y0)-(Old_X, Old_Y), PenColor, B
PicBmp.Line (Box_X0, Box_Y0)-(x, y), PenColor, B
Else
If lineok Then
'画新的光标线
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
End If
End If
Old_X = x
Old_Y = y
End If
End Sub
'垂直滚动条
Private Sub VScroll1_Change()
PicBmp.Top = -VScroll1.Value * (PicBmp.Height - PicScroll.Height) \ 100 End Sub