Code:
Option Explicit
' === GDI+ Declarations ===
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As Any, ByVal outputbuf As Long) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (ByVal filename As Long, bitmap As Long) As Long
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, bitmap As Long) As Long
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long, graphics As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As Long
Private Declare Function GdipDrawImageRectRect Lib "gdiplus.dll" Alias "GdipDrawImageRectRect" ( _
ByVal graphics As Long, _
ByVal image As Long, _
ByVal dstX As Single, _
ByVal dstY As Single, _
ByVal dstWidth As Single, _
ByVal dstHeight As Single, _
ByVal srcX As Single, _
ByVal srcY As Single, _
ByVal srcWidth As Single, _
ByVal srcHeight As Single, _
ByVal srcUnit As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Long, pclsid As GUID) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
' === Constants ===
Private Const PixelFormat32bppARGB = &H26200A
Private Const UnitPixel = 2
' === Types ===
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
' === GDI+ Startup Input Type ===
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
' === Public Crop Function ===
Public Sub CropAndSaveImage(sSource As String, sDest As String, x As Long, y As Long, w As Long, h As Long)
Dim status As Long
Dim srcBmp As Long
Dim croppedBmp As Long
Dim hGraphics As Long
Dim token As Long
Dim input As GdiplusStartupInput
input.GdiplusVersion = 1
' Initialize GDI+
status = GdiplusStartup(token, input, 0)
If status <> 0 Then
MsgBox "GDI+ failed to start"
Exit Sub
End If
' Load the source image
status = GdipCreateBitmapFromFile(StrPtr(sSource), srcBmp)
If status <> 0 Then
MsgBox "Failed to load image."
GdiplusShutdown token
Exit Sub
End If
' Create a new bitmap for the cropped image
status = GdipCreateBitmapFromScan0(w, h, 0, PixelFormat32bppARGB, ByVal 0&, croppedBmp)
If status <> 0 Then
MsgBox "Failed to create cropped image."
GdipDisposeImage srcBmp
GdiplusShutdown token
Exit Sub
End If
' Get the graphics context for the cropped bitmap
status = GdipGetImageGraphicsContext(croppedBmp, hGraphics)
If status <> 0 Then
MsgBox "Failed to get graphics context."
GdipDisposeImage srcBmp
GdipDisposeImage croppedBmp
GdiplusShutdown token
Exit Sub
End If
' Draw the image onto the new bitmap (cropped region)
status = GdipDrawImageRectRect(hGraphics, srcBmp, _
CSng(0), CSng(0), CSng(w), CSng(h), _
CSng(x), CSng(y), CSng(w), CSng(h), _
UnitPixel)
If status <> 0 Then
MsgBox "Failed to draw image."
GdipDisposeImage srcBmp
GdipDisposeImage croppedBmp
GdiplusShutdown token
Exit Sub
End If
' Save the cropped image as a new file
Dim pngClsid As GUID
Dim sCLSID As String
sCLSID = "{557CF406-1A04-11D3-9A73-0000F81EF32E}" ' PNG encoder CLSID
If CLSIDFromString(StrPtr(sCLSID), pngClsid) <> 0 Then
MsgBox "Failed to get PNG encoder CLSID."
GdipDisposeImage srcBmp
GdipDisposeImage croppedBmp
GdiplusShutdown token
Exit Sub
End If
status = GdipSaveImageToFile(croppedBmp, StrPtr(sDest), pngClsid, ByVal 0&)
If status <> 0 Then
MsgBox "Failed to save cropped image."
GdipDisposeImage srcBmp
GdipDisposeImage croppedBmp
GdiplusShutdown token
Exit Sub
End If
' Success
MsgBox "Image cropped and saved successfully!"
' Cleanup
GdipDisposeImage srcBmp
GdipDisposeImage croppedBmp
GdiplusShutdown token
End Sub