Sfogliare e salvare file immagine

Question

Ciao a tutti, dovrei eseguire la seguente operazione.

In un foglio Excel ho una lista utenti, tramite una form popolo questa lista a cui per ogni utente vorrei caricare la sua rispettiva foto. Per poter scegliere la foto dell'utente utilizzo il codice che leggete sotto abbinato ad un pulsante:

Private Sub CommandButton12_Click()

Dim fd As FileDialog

Set fd = Application.FileDialog(msoFileDialogFilePicker)

Dim FileSelezionato As Variant

With fd

If .Show = -1 Then

For Each FileSelezionato In .SelectedItems

Dim iRow, icol As Integer

iRow = 2

icol = 1

While Cells(iRow, icol).Value <> ""

iRow = iRow + 1

Wend

TextBox15 = FileSelezionato

Next FileSelezionato

Else

End If

End With

Set fd = Nothing

End Sub

Eseguo la ricerca del file, trovato il file mi riporta la stringa del link nella casella di testo TextBox11. 

Non interessandomi di salvare il link, vorrei invece salvare il file selezionato in una specfica cartella con l'istruzione "ThisWorkbook.Path", per memorizzarla in una sottocartella dalla path da cui sto lavorando, atribuendogli il nome prelevandola dalla casella di testo "idtext" che mi viene popolata tramite un'altra istruzione. 

Il codice funziona molto bene, ma mi areno quando cerco di sfruttare la variabile "FileSelezionato". 

Nell'attesa di ricevere aiuto dalla comunity vi ringrazio tuttim, aticimpandovi i miei agurui di Buone Feste.

Answer 1

La tua macro funziona benissimo. Solo che non copre perfettamente le mie esigenze.

Io ho bisogno di aggiornare periodicamente la lista dei membri con l'inserimento di un nuovo utente, e vorrei quindi caricare l'immagine di questo ultimo utente. E avere la possibilità di aggiornare l'immagine di un vecchio utente. Avrei quindi bisogno che la macro facesse riferimento all'utente selezionato nella listbox che a sua volta popola una serie di textBox, e che prendesse il nome da assegnare al nome del file immagine dalla TextBox14 che assegna un numero ID progressivo.

Mi potresti aiutare a modificare la tua macro tenendo in considerazione queste mie esigenze?

Grazie

Answer 2

Ciao Giuseppe,

Ricontrollando il codice, posso confirmare la presenza di un bug in quanto posso replicare la tua esperienza in un particolare scenario.

Quindi, ho adattato il codice per renderlo più robusto e resistente. Allo stesso tempo, ho approfittato al fine di estendere il codice e aumentare la sua funzionalità.

Pertanto, prova a sostituire il codice precedente con qualcosa del genere:

'=========>>

Option Explicit

'--------->>

Private Sub CommandButton12_Click()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim rngUtenti As Range, rCell As Range

    Dim fd As FileDialog

    Dim LRow As Long

    Dim iCtr As Long

    Dim FileSelezionato As Variant

    Dim sPath As String, sPercorso As String

    Dim sStr As String, aStr As String, bStr As String

    Dim sMsg As String, sReport As String

    Dim Res As Variant

    Dim bTerminata As Boolean

    Dim Res2 As VbMsgBoxResult, Res3 As VbMsgBoxResult

    Dim arrFoto() As Variant

    Const sFoglio As String = "Foglio1"                   '<<=== Modifica

    Const sFolder As String = "FotoUtenti"              '<<=== Modifica

    sStr = Application.PathSeparator

    sPath = ThisWorkbook.Path

    sPercorso = sPath & sStr & sFolder

    Res = Dir(sPercorso, vbDirectory)

    If Res = vbNullString Then

        MkDir sPercorso

    End If

    Set WB = ThisWorkbook

    Set SH = WB.Sheets("Foglio1")

    With SH

        LRow = .Cells(Rows.Count, "A").End(xlUp).Row

        Set rngUtenti = .Range("A2:A" & LRow)

        ReDim arrFoto(1 To LRow)

    End With

    For Each rCell In rngUtenti.Cells

        With rCell

            aStr = .Value

SelezionaFotografia:

            Res3 = MsgBox(Prompt:= _

                          "Ora si sta selezionando una fotografia per " _

                        & aStr & vbNewLine _

                        & "nella cella " & .Address(0, 0) _

                        & vbNewLine & vbNewLine _

                        & "Vuoi Continuare?", _

                          Buttons:=vbYesNo, Title:="CONTINUARE?")

            If Res3 = vbNo Then

                sMsg = "La Macro è stata terminata!"

                GoTo XIT

            End If

            Set fd = Application.FileDialog(msoFileDialogFilePicker)

            With fd

                .AllowMultiSelect = False

                If .Show = -1 Then

                    FileSelezionato = .SelectedItems.Item(1)

                    FileCopy FileSelezionato, sPercorso _

                                            & sStr _

                                            & aStr & ".jpg"

                    iCtr = iCtr + 1

                    arrFoto(iCtr) = aStr

                    Me.TextBox15.Text = FileSelezionato

                Else

                    Res2 = MsgBox(Prompt:= _

                                  "Non hai selezionato una fotografia per " _

                                & vbNewLine _

                                & aStr, _

                                  Buttons:=vbRetryCancel, _

                                  Title:="AVVISO!")

                    If Res2 = vbRetry Then

                        GoTo SelezionaFotografia

                    End If

                End If

            End With

        End With

    Next rCell

    sMsg = "Finita!"

XIT:

    Me.TextBox15.Text = vbNullString

    Select Case iCtr

    Case 0

        sMsg = sMsg _

             & vbNewLine & vbNewLine _

             & "Nessuna fotografia è stata copiata"

    Case 1

        bStr = "La seguente fotografia è stata copiata "

    Case Else

        bStr = "Le seguente " _

             & iCtr _

             & " fotografie sono state copiate "

    End Select

    If CBool(iCtr) Then

        ReDim Preserve arrFoto(1 To iCtr)

        sReport = Join(arrFoto, vbNewLine)

        sMsg = sMsg _

             & vbNewLine & vbNewLine _

             & bStr _

             & " nella directory: " _

             & sPercorso _

             & vbNewLine & vbNewLine _

             & sReport

    End If

    Call MsgBox(Prompt:=sMsg, _

                Buttons:=vbInformation, _

                Title:="REPORT")

    Set fd = Nothing

End Sub

'--------->>

Private Sub UserForm_Initialize()

    With Me

        .CommandButton1.Caption = "Esci"

        .CommandButton12.Caption = "Scegli Fotografie"

    End With

End Sub

'--------->>

Private Sub CommandButton1_Click()

    Unload Me

End Sub

'<<=========

Eseguendo il codice e selezionando una fotografia per ognuno dei nove utenti nell'elenco sul Foglio1 del mio file di prova, i nove file corrispondenti vengono copiati nella directory precisata da me, cioè la cartella FotoUtenti:


Potresti scaricare il mio file di prova Giuseppe#2_20151211.xlsm a:

                                **http://1drv.ms/1Z4k69S**

===

Regards,

Norman

Answer 3

Ciao Giuseppe,

Da me il codice funziona nel modo previsto, senza problema.

Forse, anziché un ciclo infinito, ciò che stai osservando, è una nuova richiesta in relazione al successivo utente, cioè alla cella successiva nella lista. A questo proposito, vorrei ricordarti del mio suggerimento che consideri l'aggiunta di controlo Label.

Al fine di stabilire meglio il problema, nel mio codice, prova a sostituire

    For Each rCell In rngUtenti.Cells

        With rCell

con:

For Each rCell In rngUtenti.Cells

With rCell

MsgBox "Ora si sta selezionando una foto per " _

& rCell.Value & vbNewLine _

& "nella cella " & rCell.Address(0, 0)

Set fd = Application.FileDialog(msoFileDialogFilePicker)

Poi facci il messaggio risultante al punto in cui il problema si manifesta,

===

Regards,

Norman

Answer 4

Grazie per la risposta, ho provato il codice da te proposto. Pur selezionando la foto il ciclo continua chidendomi sempre di selezionare una foto... dandomi per risposta, se tento di annullare, che non ho selezionato nessuna foto.

Per chiudere il ciclo devo brutalmente interromperlo con Ctrl+Break

Answer 5

Ciao Giuseppe,

Per quanto riguarda il ciclo nel tuo codice, non ho capito la tua intenzione, ma è sempre possibile che l'abbia letto male io!

Tornando, però, alla tua domanda sostantiva, cioè il salvataggio dei foto, in una designata sottodirectory, in rispetto di ognuno degli utenti elencati in colonna A, forse, prova qualcosa del genere:

'=========>>

Option Explicit

'--------->>

Private Sub CommandButton12_Click()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim rngUtenti As Range, rCell As Range

    Dim fd As FileDialog

    Dim LRow As Long

    Dim FileSelezionato As Variant

    Dim sPath As String, sPercorso As String, sStr As String

    Dim Res As Variant

    Dim Res2 As VbMsgBoxResult

    Const sFoglio As String = "Foglio1"                    '<<=== Modifica

    Const sFolder As String = "FotoUtenti"               '<<=== Modifica

    sStr = Application.PathSeparator

    sPath = ThisWorkbook.Path

    sPercorso = sPath & sStr & sFolder

    Res = Dir(sPercorso, vbDirectory)

    If Res = vbNullString Then

        MkDir sPercorso

    End If

    Set WB = ThisWorkbook

    Set SH = WB.Sheets("Foglio1")

    With SH

        LRow = .Cells(Rows.Count, "A").End(xlUp).Row

        Set rngUtenti = .Range("A2:A" & LRow)

    End With

    For Each rCell In rngUtenti.Cells

        With rCell

            Set fd = Application.FileDialog(msoFileDialogFilePicker)

SelezionaFoto:

            With fd

                .AllowMultiSelect = False

                If .Show = -1 Then

                    FileSelezionato = .SelectedItems.Item(1)

                    FileCopy FileSelezionato, sPercorso _

                                            & sStr _

                                            & rCell.Value & ".jpg"

                    Me.TextBox15.Text = FileSelezionato    

                Else

                    Res2 = MsgBox(Prompt:="Non hai selezionato un foto", _

                                  Buttons:=vbRetryCancel, _

                                  Title:="Avviso!")

                End If

                If Res2 = vbRetry Then

                    GoTo SelezionaFoto

                End If

            End With

        End With

    Next rCell

    Set fd = Nothing

End Sub

'<<=========

Per gli scopi di questo codice nota che:

• Ho limitato il numero di foto a uno per utente
• Ho rinominato i file copiati con il nome dell\utente
• Se la sottodirectory non esiste già, il codice la creerà

Come suggerimento aggiuntivo, forse si potrebbe prendere in considerazione l'aggiunta di un controllo Label o altro per avvertire l'utente del nome dell'utente per cui si dovrebbe selezionare una foto.

===

Regards,

Norman