为了正常的体验网站,请在浏览器设置里面开启Javascript功能!

图片批量切割VB源代码

2017-09-30 15页 doc 53KB 17阅读

用户头像

is_337177

暂无简介

举报
图片批量切割VB源代码图片批量切割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 :...
图片批量切割VB源代码
图片批量切割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
/
本文档为【图片批量切割VB源代码】,请使用软件OFFICE或WPS软件打开。作品中的文字与图均可以修改和编辑, 图片更改请在作品中右键图片并更换,文字修改请直接点击文字进行修改,也可以新增和删除文档中的内容。
[版权声明] 本站所有资料为用户分享产生,若发现您的权利被侵害,请联系客服邮件isharekefu@iask.cn,我们尽快处理。 本作品所展示的图片、画像、字体、音乐的版权可能需版权方额外授权,请谨慎使用。 网站提供的党政主题相关内容(国旗、国徽、党徽..)目的在于配合国家政策宣传,仅限个人学习分享使用,禁止用于任何广告和商用目的。

历史搜索

    清空历史搜索