Redimensionar imagens automaticamente VBA Excel

Comemoração 500 posts
2 de junho de 2018
[Excel] Mudar células ao passar o mouse. MouseHover capa
[Excel] Mudar células ao passar o mouse. MouseHover
9 de junho de 2018
Redimensionar imagens VBA

Redimensionar imagens automaticamente VBA Excel

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.

Redimensionar imagens

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

Abraço

Marcos Rieper


Clique aqui e leia mais sobre Excel VBA. https://www.guiadoexcel.com.br/vba/ O Guia do Excel foi criado por Marcos Rieper e oferece artigos, dicas, tutoriais e modelos de planilhas prontas. Aqui você encontra tudo sobre Excel, seja de nível básico, intermediário,  avançado e VBA. O Guia do Excel oferece diversos materiais completamente gratuitos para download. Navegue em nosso site e confira! Conheça também a nossa Loja do Excel https://loja.guiadoexcel.com.br/
Cursos

Curso Excel Completo – Curso Excel Básico + Curso Excel Avançado – Acesso Vitalício

R$218,00 R$179,00

COMPRAR
Cursos

Curso Excel Master – Curso Excel Básico + Curso Excel Avançado + Curso VBA Excel + LP – Acesso Vitalício

R$357,00 R$249,00

COMPRAR
Cursos

Curso Excel PRO – Curso Excel Avançado + Curso VBA Excel + Lógica de programação – Acesso Vitalício

R$258,00 R$199,00

COMPRAR
Cursos

Curso Excel Web – Curso VBA Excel + Lógica de programação + Curso Web Scraping VBA- Acesso Vitalício

R$388,90 R$309,00

COMPRAR

Deixe uma resposta

O seu endereço de e-mail não será publicado. Campos obrigatórios são marcados com *

Esse site utiliza o Akismet para reduzir spam. Aprenda como seus dados de comentários são processados.

Inscreva-se no nosso canal do Youtube!


Junte-se ao nosso canal do Youtube. Começamos em abril de 2016, mas já temos mais de 06:00 h de treinamentos gratuitos e este número irá aumentar. Vídeos novos todos os sábados.