Vídeo recomendado
https://youtu.be/diWPPPhW-9E

Criar Pastas, Recortar e Colar Imagens

Fórum para dúvidas gerais sobre programação Web
fcarlosc2023
Acabou de chegar
Acabou de chegar
Mensagens: 1
Registrado em: Ter Mar 28, 2023 7:01 pm

Criar Pastas, Recortar e Colar Imagens

Mensagem por fcarlosc2023 »

Boa-tarde,

Tenho um código para recortar imagens de uma pasta (Origem), criar pastas (Sequencialmente) e Colar nas pastas recém criadas (Destino) com uma quantidade determinada por um TextBox.
Porém não está criando as pastas, apenas criar a primeira pasta, recorta e cola as imagens.

Código: Selecionar todos

Private Sub btGerarPastas_Click()

    Dim sourceFolder As String
    Dim targetFolder As String
    Dim imageCount As Integer
    Dim currentCount As Integer
    Dim sourceFile As String
    Dim targetFile As String
    Dim folderNumber As Integer
    
    'Defina a pasta de origem das imagens'
    sourceFolder = "C:\SERVICO\Projetos VB\IMAGEM\ORIGEM\"
    
    'Defina a pasta de destino para salvar as imagens recortadas'
    targetFolder = "C:\SERVICO\Projetos VB\IMAGEM\DESTINO\"
    
    'Obtenha o valor digitado pelo usuário no TextBox'
    imageCount = Val(txtQuantidade.Text)
    
    'Verifique se o valor digitado é válido'
    If imageCount <= 0 Then
        MsgBox "Digite um valor válido.", vbExclamation, "Quantidade inválida"
        Exit Sub
    End If
    
    'Crie a nova pasta de destino, caso ela ainda não exista'
    If Dir(targetFolder, vbDirectory) = "" Then
        MkDir targetFolder
    End If
    
    'Corte as imagens da pasta de origem e cole na pasta de destino'
    currentCount = 0
    folderNumber = 1
    Do While True
        'Crie uma nova pasta para as próximas imagens'
        MkDir targetFolder & "Pasta" & folderNumber
        
        'Copie as imagens para a nova pasta'
        sourceFile = Dir(sourceFolder & "*.jpg")
        Do While sourceFile <> ""
            currentCount = currentCount + 1
            If currentCount > imageCount Then
                Exit Sub
            End If
            targetFile = targetFolder & "Pasta" & folderNumber & "\" & sourceFile
            Name sourceFolder & sourceFile As targetFile
            sourceFile = Dir()
        Loop
        
        'Verifique se ainda há mais imagens na pasta de origem'
        If Dir(sourceFolder & "*.jpg") = "" Then
            Exit Do
        End If
        
        folderNumber = folderNumber + 1
    Loop
    
    'Exiba uma mensagem de conclusão'
    MsgBox "Foram cortadas " & currentCount & " imagens em " & folderNumber - 1 & " pastas dentro de " & targetFolder, vbInformation, "Concluído"
    
End Sub
Preciso inserir mais um TextBox (txtCaixa) onde determino o número da Pasta que preciso que recorte as imagens, TextBox (txtQuantidade) onde determino a quantidade que será recortada e cole nas pastas recém criadas e assim sucessivamente até não ter mais imagens a serem recortadas na Pasta (txtCaixa).
Também terá um outro TextBox (txtLote) onde determino a sequência inicial de Lote/Pasta até o fim das imagens.

Ex.: txtCaixa = 001
txtLote = 00001
txtQuantidade = 5


Então irá na Pasta de Origem - Caixa/Pasta (CX001) irá recortar a primeiras 5 imagens e colar na Pasta recém criada da Pasta de Destino - Lote/Pasta (Lote00001) e assim por diante...Lote00002 colar as próximas 5 imagens...Lote00003 próximas 5,...!

Poderiam me auxiliar nesse código !?

Att,
Francisco


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Avatar do usuário
webmaster
Administrador
Mensagens: 3114
Registrado em: Sex Jul 24, 2009 2:44 pm
Contato:

Re: Criar Pastas, Recortar e Colar Imagens

Mensagem por webmaster »

Uma coisa por vez. Vamos à função que copia somente as imagens primeiro:

Código: Selecionar todos

Sub CopyImageFiles()
    Dim FSO As Object
    Dim SourceFolder As Object
    Dim DestinationFolder As Object
    Dim FileItem As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = FSO.GetFolder("C:\SERVICO\Projetos VB\IMAGEM\ORIGEM\")
    Set DestinationFolder = FSO.GetFolder("C:\SERVICO\Projetos VB\IMAGEM\DESTINO\")
    For Each FileItem In SourceFolder.Files
        If LCase(Right(FileItem.Name, 4)) = ".jpg" Or LCase(Right(FileItem.Name, 4)) = ".png" Then 'adicione mais extensões de imagem aqui
            FSO.CopyFile FileItem.Path, DestinationFolder.Path & "\" & FileItem.Name, True
        End If
    Next FileItem
End Sub
Tendo isto resolvido, pulamos para o próximo passo


Responder