Pagi kak ...
Misal saya ada Folder foto di Direktori "C:\Foto\tes"
apakah bisa jika ingin Resize semua foto di folder tersebut ,, misal saya resize menjadi 600 x 600
uda muter Googling tapi belum nemu cara untuk meresize seperti yg saya mau :)
sebelumnya saya ucapkan terima kasih atas bantuannya
Terjawab oleh Caton
Lihat Jawaban terkaitMbak @anggun123 ...
Berikut contoh script VBA yang bisa digunakan untuk meresize ukuran sebuah gambar. Salin script berikut ke dalam modul standar.
Option Explicit Private Const RESIZE_MAX_WIDTH = 300 Private Const RESIZE_MAX_HEIGHT = 300 Private mxWIAImageFile As Object Public Sub ResizeImageTest() Dim sPathIn As String, sPathOut As String Dim sFN As String, sExt As String Dim xFSO As Object '+-- Ubah variabel lokasi folder sumber gambar dan '+-- lokasi target penyimpanan hasil. sPathIn = ThisWorkbook.Path & "\Source\" sPathOut = ThisWorkbook.Path & "\Result\" Call InitializeWIAImageFile Set xFSO = CreateObject("Scripting.FileSystemObject") sFN = Dir(sPathIn & "*.*") Do While (sFN <> vbNullString) sExt = UCase(Right(sFN, 4)) If InStr(1, ".JPG.PNG.BMP.GIF", sExt) Then If xFSO.FileExists(sPathOut & sFN) Then Call xFSO.DeleteFile(sPathOut & sFN, True) End If Call WIA_ResizeImage(sPathIn & sFN, sPathOut & sFN, 500, 500, True) End If sFN = Dir() Loop Set xFSO = Nothing Call TerminateWIAImageFile MsgBox "Resize Image Done!" End Sub Private Sub InitializeWIAImageFile() If mxWIAImageFile Is Nothing Then Set mxWIAImageFile = CreateObject("WIA.ImageFile") End If End Sub Private Sub TerminateWIAImageFile() On Error Resume Next Set mxWIAImageFile = Nothing Err.Clear: On Error GoTo 0 End Sub Private Sub WIA_ResizeImage(SourceFile As String, ResultFile As String, Optional MaxWidth As Long, Optional MaxHeight As Long, Optional KeepAspect As Boolean = True) Dim xImageProcess As Object Err.Clear: On Error GoTo errHandler Set xImageProcess = CreateObject("WIA.ImageProcess") Call mxWIAImageFile.LoadFile(SourceFile) xImageProcess.Filters.Add xImageProcess.FilterInfos("Scale").FilterId If MaxWidth = 0 Then MaxWidth = RESIZE_MAX_WIDTH If MaxHeight = 0 Then MaxHeight = RESIZE_MAX_HEIGHT If MaxWidth > 0 Then xImageProcess.Filters(1).Properties("MaximumWidth") = MaxWidth End If If MaxHeight > 0 Then xImageProcess.Filters(1).Properties("MaximumHeight") = MaxHeight End If xImageProcess.Filters(1).Properties("PreserveAspectRatio") = KeepAspect Set mxWIAImageFile = xImageProcess.Apply(mxWIAImageFile) mxWIAImageFile.SaveFile ResultFile errHandler: If Err Then Debug.Print "Error #" & Err.Number & vbCrLf & Err.Description Err.Clear: On Error GoTo 0 End If End Sub
Demikian, semoga berhasil.