Início » Blog Guia do Excel » Redimensionar imagens automaticamente VBA Excel – Planilha redimensionar imagens Grátis

Redimensionar imagens automaticamente VBA Excel – Planilha redimensionar imagens Grátis

Neste artigo é disponibilizada a planilha Excel para redimensionar imagens automaticamente com VBA. Veja mais em https://guiadoexcel.com.br/vba

O código realiza o redimensionamento de imagens JPG de uma pasta com um máximo de largura ou altura definidos informados pelo usuário.

Este código que realiza a conversão do tamanho das imagens automaticamente foi disponibilizado por Felipe Tadeu Cezário Vieira.

Com base neste código fiz apenas algumas melhorias para poder selecionar a pasta aonde estão as imagens e fazer o ajuste das imagens para o tamanho máximo de largura e altura conforme o que for definido pelo usuário.

Para redimensionar as imagens basta habilitar as macros ao abrir a pasta de trabalho do Excel e clicar no botão Redimensionar Imagens.

Após isto basta selecionar a pasta aonde estão as imagens que deseja converter o tamanho e definir o tamanho máximo de altura e largura que deseja para as imagens.

As mesmas não serão alteradas diretamente para a imagem selecionada, mas sim para a dimensão máxima de largura ou altura, mas sem estourar as margens.

Abaixo o código fonte que realiza a seleção de pastas, o loop pelos arquivos da pasta e também o que faz o redimensionamento das imagens.

'Colocar esta parte do código no início do módulo
Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
    "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
    "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
    As Long
Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Public Function WIA_ResizeImage(sInitialImage As String, sResizedImage As String, _
                                           lMaximumWidth As Long, lMaximumHeight As Long) As Boolean
    On Error GoTo Error_Handler
    Dim oWIA                  As Object 'WIA.ImageFile
    Dim oIP                   As Object 'ImageProcess
 
    Set oWIA = CreateObject("WIA.ImageFile")
    Set oIP = CreateObject("WIA.ImageProcess")
 
    oIP.Filters.Add oIP.FilterInfos("Scale").FilterID
    oIP.Filters(1).Properties("MaximumWidth") = lMaximumWidth
    oIP.Filters(1).Properties("MaximumHeight") = lMaximumHeight
    
    oWIA.LoadFile sInitialImage
    Set oWIA = oIP.Apply(oWIA)
    oWIA.SaveFile sResizedImage
    WIA_ResizeImage = True
 
Error_Handler_Exit:
    On Error Resume Next
    If Not oIP Is Nothing Then Set oIP = Nothing
    If Not oWIA Is Nothing Then Set oWIA = Nothing
    Exit Function
 
Error_Handler:
       Resume Error_Handler_Exit
End Function

Public Sub lsRedimensionar(ByVal lPasta As String, ByVal lArquivo As String, ByVal lLargura As Long, ByVal lAltura As Long)
    Call WIA_ResizeImage(lPasta & lArquivo, _
                          lPasta & "_" & lArquivo, _
                         lLargura, lAltura)
End Sub


'Função que faz chamada da API
Public Function gfSelecionarPasta(ByVal vFolder As String, Optional Title As String, Optional hWnd) As String

    Dim bi As BROWSEINFO
    Dim pidl As Long
    Dim folder As String

    folder = String$(255, Chr$(0))

    With bi
        If IsNumeric(hWnd) Then .hOwner = hWnd
        .pidlRoot = 0
        If Title <> "" Then
            .lpszTitle = Title & Chr$(0)
        Else
            .lpszTitle = "Select a Folder" & Chr$(0)
        End If
    End With

    pidl = SHBrowseForFolder(bi)

    If SHGetPathFromIDList(ByVal pidl, ByVal folder) Then
        folder = Left(folder, InStr(folder, Chr$(0)) - 1)
    Else
        folder = ""
    End If

    If Right(folder, 1) <> "\" And Len(folder) > 0 Then folder = folder & "\"

    gfSelecionarPasta = folder

End Function

Sub lsAlterarArquivos()
    Dim FName As String
    'Cria um vetor de strings
    Dim arNames() As String
    Dim myCount As Integer
    Dim fPasta As String
    Dim lsExtensao As String

    'Seleciona a pasta
    fPasta = gfSelecionarPasta("C:", "Selecione o local aonde será gravado o arquivo:")
    
    'Determina o diretório e a extensão do arquivo
    FName = Dir(fPasta & "*.jpg")

    frmRedimensionar.Show

    'Enquanto FName for igual a vazio "", realiza a listagem dos arquivos
    Do Until FName = ""
        myCount = myCount + 1
        'Redimensiona o vetor, preservando os dados
        ReDim Preserve arNames(1 To myCount)
        arNames(myCount) = FName
        'Passa os dados para a planilha
        'Cells(myCount, 1).Value = arNames(myCount)
        lsRedimensionar fPasta, arNames(myCount), frmRedimensionar.txtLargura, frmRedimensionar.txtAltura
        'Atualiza a variável FName
        FName = Dir
    Loop
    
    MsgBox "Processamento concluído!"
End Sub

Baixe a planilha

Abraço

Marcos Rieper