inserimento immagini

[nicola_na78]

Ciao Ricky53, ecco il codice definitivo e che mi funziona perfettamente alle mie esigenze...

Codice: Seleziona tutto

Private Sub Inserisci_Immagini()
Dim MyPath, MioFile, UR As Long, I As Long, Percorso As String

Sheets("Foglio1").Range("A1").Select
MyPath = ActiveSheet.Cells(1, 1)
MioFile = "C:\Users\utente\Desktop\Zoom" & "\" & "*.*"
MyName = Dir(MioFile, vbDirectory)
rg = 1
Do While MyName <> ""
If MyName = ".." Then GoTo lab1
rg = rg + 1
lab1: MyName = Dir
ActiveSheet.Cells(rg, 1) = MyName
Application.ScreenUpdating = False
    Sheets("Foglio1").Select
    Percorso = C:\Users\utente\Desktop\Zoom"
    UR = Range("A" & Rows.Count).End(xlUp).Row
    For I = 2 To UR
       Cells(I,2).Select
       ActiveSheet.Pictures.Insert "C:\Users\Desktop\Zoom\ " & Cells(I, 1)
       ActiveSheet.Shapes(cells(I,1)).Select
       Selection.ShapeRange.ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft
       Selection.ShapeRange.ScaleHeight 0.5, msoFalse, msoScaleFromTopLeft
    Next I
    Application.ScreenUpdating = True
Loop

End Sub


Grazie a tutti, alla prossima... Nicola

[ricky53]

Ciao,
Uhm, Uhm ...
Sicuro che tutto venga fatto nel modo dovuto?

C’è qualche “sfrido” nel codice che hai allegato e si ottengo errori.
Ho rimosso questi errori e ho provato il codice.

Allora: ecco cosa fa il tuo codice:
1. scorre tutti i nomi dei file presenti nella tua cartella e li scrive in colonna "A"

2. nel ciclo For/Next scorre la colonna "A" per prendere i nomi delle immagini scritti nel punto "1" ed inserisce le immagini nella colonna "B" ma a causa del ciclo le ... inserisce TANTE volte (probabilmente quante sono le immagini presenti nella tua cartella).


A verifica di quanto ti ho scritto nel punto "2":
prova a cancellare la prima immagine presente in "B2" e .... cosa ottieni?


Va sistemato il ridimensionamento delle immagini a meno che tu non l'abbia fatto per tutte le immagini manualmente ... come mi sembra di aver capito

[nicola_na78]

Ciao Ricky, ecco il codice definitivo Riadattato e snellito funzionante al 100% riadattando le immagini:

Codice: Seleziona tutto

Private Sub Inserisci_Immagini()
UR = Range("A" & Rows.Count).End(xlUp).Row
 Set Immagini = Nothing
  For I = 2 To UR

 On Error Resume Next ' <<=== delle volte la macro nell'importare molte immagini va in errore inserendo questa istruzione non succede
        Cells(I, 2).Select ' <<=== nelle colonna "B" vengono inserite le immagini
       Set Immagini = ActiveSheet.Pictures.Insert("C:\Users\Desktop\ZOOM\" & Cells(I, 1))
            Immagini.Top = Cells(I, 2).Offset(0, 1).Top
            Immagini.Left = Cells(I, 2).Offset(0, 0).Left
            Immagini.LockAspectRatio = msoTrue
            Immagini.Width = 100
            Immagini.Height = 100
  Next I
End Sub


Grazie ancora a tutti

alla Prossima

RISOLTO

[ricky53]

Ciao Nicola,
l'istruzione

Codice: Seleziona tutto

Immagini.LockAspectRatio = msoTrue

va in errore run-time 438

va modificata in

Codice: Seleziona tutto

Immagini.ShapeRange.LockAspectRatio = msoTrue

Sicuro che l'immagine non viene deformata?
Con il 2003 sicuramente viene deformata.
Tu che versione utilizzi? Probabilmente NON la 2003.


Una della due istruzioni

Codice: Seleziona tutto

        Immagini.Width = 100
        Immagini.Height = 100


con il 2010 NON è necessaria !

In base alle tue esigenze di altezza/larghezza cella vedi quale utilizzare:
a) la prima adatta in larghezza e rispetta le proporzioni con l'altezza
b) la seconda adatta in altezza e rispetta le proporzioni con la larghezza

[nicola_na78]

Ciao Ricky53,
la macro la sto utilizando su excel 2007 e funziona correttamente (su altre versioni di excel non saprei dirti se va in errore). ho importato oltre 5000 immagini senza alcun problema e adattati perfettamente.....
l'istruzione:

Codice: Seleziona tutto

Immagini.LockAspectRatio = msoTrue

non va in errore

Grazie
Nicola

[ricky53]

Ciao
strano. Non ho il 2007 ma, come già scritto sul 2003, sul 2010 ed anche sul 2013 va in errore.




. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
EDIT
Capito il motivo: tu utilizzi "On Error Resume Next "
che io aborro e cancello subito quando lo vedo !!!

Commenta il codice ed anche tu avrai l'errore.
. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .

[nicola_na78]

Ricky, ho appena provato la macro su un pc con office 2003. Funziona tutto regolare...

Sicuro che l'immagine non viene deformata?
Con il 2003 sicuramente viene deformata.
Tu che versione utilizzi? Probabilmente NON la 2003.


Una della due istruzioni
CODICE: SELEZIONA TUTTO
Immagini.Width = 100
Immagini.Height = 100
con il 2010 NON è necessaria !

In base alle tue esigenze di altezza/larghezza cella vedi quale utilizzare:
a) la prima adatta in larghezza e rispetta le proporzioni con l'altezza

se non utilizzo tutte e due istruzioni

Codice: Seleziona tutto

 Immagini.Width = 100
        Immagini.Height = 100

le immagini sono distorte

Nicola

[ricky53]

Ciao,
hai commentato "On Error Resume Next" ?
L'errore si ha?


Deformazione: Infatti ti avevo critto che l'istruzione non era necessaria con il 2010.

Attenzione con il 2003, le immagini vengono deformate se utilizzi le due istruzioni perché imposti altezza e larghezza a 100 pixel. Se le immagini sono rettangolari tu le fai diventare quadrate e le deformi !!!

Si deve adottare un altro sistema. Anthony lo aveva proposto ... non ricordo in quale discussione.
Se ti occorre lo cerco.

Con le versioni successive è sufficiente una sola istruzione.

[nicola_na78]

Ciao,
Si hai ragione se le immagini sono rettangolari le deforma, non ci avevo fatto caso perchè le immagini che dovevo inserire erano tutte quadrate....
commentando "On Error Resume Next" mi funziona ugualmente...

Nicola

[ricky53]

Ciao,
strano che commentando l'istruzione tu non ottenga un errore.
Per commentando intendevo mettere un "apice semplice" (è quello sul sul tasto con il "?") davanti all'istruzione.
Tu hai fatto così?

[ricky53]

Ciao,
prima leggi quanto ti o scritto nel mio precedente intervento.

Adesso ecco del codice che ridimensiona le immagini senza deformarle.
E' valido dal 2007 in avanti, per il 2003 NON garantisco per tutte le immagini e le dimensioni delle celle.

Codice: Seleziona tutto

Sub Inserisci_Immagini()
    Dim UR As Long, I As Long, Immagini As Object
   
    UR = Range("A" & Rows.Count).End(xlUp).Row
    For I = 2 To UR
        Set Immagini = ActiveSheet.Pictures.Insert("C:\Users\Desktop\ZOOM\" & Cells(I, 1))
        Immagini.Top = Cells(I, 2).Top + 5
        Immagini.Left = Cells(I, 2).Left + 5
        Immagini.ShapeRange.LockAspectRatio = msoTrue
        Immagini.Height = Cells(I, 2).Height - 10
        If Immagini.Width >= Cells(I, 2).Width - 10 Then
            Immagini.Width = Cells(I, 2).Width - 10
        End If
    Next I
    Set Immagini = Nothing
End Sub


Prova e ... sono QUI

[nicola_na78]

Ciao Ricky,
ho commentato l'istruzione cosi:

Codice: Seleziona tutto

' On Error Resume Next

e funziona lo stesso.... forse perchè sto inserendo immagini che sono tutte quadrate, è possibile che se fossero capitate immagini rettangolari l'istruzione si bloccava.

Ho provato il tuo codice e funziona allo stesso modo, presumo che nel tuo se ci dovessero essere immagini rettangolari li adatta senza rovinarle giusto?.

non ho capito il + 5 dell'istruzione sotto:

Codice: Seleziona tutto

Immagini.Top = Cells(I, 2).Top + 5

Cmq Grazie per la tua pazienza.....

Nicola

[ricky53]

Ciao,
il "+5" serve a spostare di "5" pixel l'immagine dal bordo della cella sopra e di lato a sinistra ... devo dedurre che non lo hai notato?

Ho riscritto il codice in modo che funzioni con tutte le versioni di Office
ecco la versione aggiornata

Codice: Seleziona tutto

Sub Inserisci_Immagini_2()
    Dim UR As Long, I As Long, Immagini As Object
   
'....................................................................................................
' Le istruzioni seguenti cancellano tutte le immagini presenti nel foglio !!!
'    For Each Immagini In ActiveSheet.Shapes
'            Immagini.Delete
'    Next Immagini
'....................................................................................................
   
    UR = Range("A" & Rows.Count).End(xlUp).Row
    For I = 2 To UR
        Set Immagini = ActiveSheet.Pictures.Insert("C:\Users\Desktop\ZOOM\" & Cells(I, 1))
        With Immagini
            .Top = Cells(I, 2).Top + 5
            .Left = Cells(I, 2).Left + 5
            .ShapeRange.LockAspectRatio = True
            .ShapeRange.Height = Cells(I, 2).Height - 10
            If .ShapeRange.Width >= Cells(I, 2).Width - 5 Then
                .ShapeRange.Width = Cells(I, 2).Width - 10
            End If
        End With
    Next I
    Set Immagini = Nothing
End Sub

NON ho inserito la gestione degli errori: per esempio se l'immagine non esiste il codice va in errore ... in caso lo aggiungiamo dopo.


Prova con delle immagini rettangolari ... se hai un'immagine con un cerchio o qualcosa che faccia vedere subito la deformazione avrai la prova del corretto funzionamento del codice

Per esempio come questa

Salvala nel percorso ove hai le altre immagini ed inseriscila nel file, dimensiona le celle in modo che siano rettangolari (una più larcga che alta ed un'altra più alta che larga) inserisci due volte il nome "Cerchio_2.jpg" e ... aggiornaci sul risultato

[nicola_na78]

Salvala nel percorso ove hai le altre immagini ed inseriscila nel file, dimensiona le celle in modo che siano rettangolari (una più larcga che alta ed un'altra più alta che larga) inserisci due volte il nome "Cerchio_2.jpg" e ... aggiornaci sul risultato

Ricky, l'immagine si adatta alla grandezza della cella..... non ci avevo fatto caso prima perchè le celle erano dimensionae tutte alla stessa grandezza.... sei un grande

[ricky53]

Ciao,
adesso non resta che far centrare l'immagine nella cella in orizzontale ed in verticale ... che ne dici?

[nicola_na78]

Ok, procediamo....

[ricky53]

Ciao,

Ok, procediamo....

che tradotto significa: vai avanti tu che io ...

Ecco il codice che adatta automaticamente l'altezza della riga e centra, nella cella, l'immagine.

Codice: Seleziona tutto

Option Explicit

Sub Inserisci_Immagini_3()
    Dim UR As Long, I As Long, Immagini As Object

'....................................................................................................
' Le istruzioni seguenti cancellano tutte le immagini presenti nel foglio !!!
'    For Each Immagini In ActiveSheet.Shapes
'        Immagini.Delete
'    Next Immagini
'....................................................................................................
   
    UR = Range("A" & Rows.Count).End(xlUp).Row
    For I = 2 To UR
        Set Immagini = ActiveSheet.Pictures.Insert("C:\Users\Desktop\ZOOM\" & Cells(I, 1))
        With Immagini
            .Top = Cells(I, 2).Top + 5 ' <<===== Posiziona l'immagine
            .Left = Cells(I, 2).Left + 5 ' <<===== Posiziona l'immagine
            .ShapeRange.LockAspectRatio = True
            .ShapeRange.Height = Cells(I, 2).Height - 10 ' <<===== Adatta in altezza l'immagine
            If .ShapeRange.Width >= Cells(I, 2).Width - 5 Then
                .ShapeRange.Width = Cells(I, 2).Width - 10 ' <<===== Adatta, se necessario, in larghezza l'immagine
            End If

'...............................................................................
' Adatta "altezza" cella
            Cells(I, 2).RowHeight = .Height + 10

' Centra l'immagine nella cella in "orizzontale" ed in "verticale"
            .Top = Cells(I, 2).Top + (Cells(I, 2).RowHeight - .Height) / 2
            .Left = Cells(I, 2).Left + (Cells(I, 2).Width - .Width) / 2
'...............................................................................
        End With
    Next I
    Set Immagini = Nothing
End Sub

Altra proposta:
si può fare in modo che al cambiamento del nome scritto in colonna "A", l'immagine venga inserita senza far eseguire nessuna macro !!!

[nicola_na78]

Ricky scusa ancora, nella colonna A, si puo' fare in modo che premendo sulla descrizione mi vada ad aprire l'immagine in anteprima fuori da excel???

[ricky53]

Ciao,
cosa intendi?
Forse aprire l'immagine con un altro prodotto software? Esempio il Visualizzatore di Immagini di Windows ?

[nicola_na78]

esatto proprio cosi, io clicco sulla cella e mi apre con un anteprima di windows l'immagine...
Grazie