Resize Image di Folder

  1. 3 tahun lalu

    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

    Mbak @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.

  2. Caton

    4 Jun 2021 Terverifikasi Jawaban Terpilih Indonesia + 20.101 Poin

    Mbak @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.

  3. Terima kasih banyak om @Caton
    berhasil :)

 

atau Mendaftar untuk ikut berdiskusi!