Importare una immagine in excel ed esportarla in una cartella

Question

Buongiorno, 

ho già fatto una domanda simile in passato ma senza risposta.

Questa macro è stata creata su excel 2013 ed ora sul 365 non funziona.

La cosa strana è che se eseguo i passaggi con il debug, la macro funziona, ma se la eseguo in automatico si blocca a:

shp.CopyPicture xlScreen, xlPicture

oppure se a volte passa questo codice mi ritrovo una foto nella catella bianca come se il codice avesse salvato solo la shape senza la foto.

Il codice in questione è il seguente, spero mi possiate aiutare.

Dim shp As Shape

Dim cht As ChartObject

Dim strPath As String

Dim strfile As String

Dim DestD As String

Dim n As Integer, X As String

Dim img As String

Dim messaggio As String

Dim peppe As String

DestD = ActiveWorkbook.Path & "\Matrix Pictures" & "GiuseppeTest" & ".jpg"

  With Application.FileDialog(msoFileDialogFilePicker)

   .Show

  If .SelectedItems.Count = 0 Then Exit Sub

 strfile = .SelectedItems(1)

    End With

Range("A1").Select

ActiveSheet.Pictures.insert (strfile)

  X = ActiveSheet.Shapes.Count

  For n = 1 To X

    peppe = ActiveSheet.Shapes(n).Name

Next

        Set shp = ActiveSheet.Shapes(peppe)

        shp.Width = 200

        shp.Height = 200

        shp.Select

        shp.CopyPicture xlScreen, xlPicture

        Set cht = ActiveSheet.ChartObjects.Add(300, 100, shp.Width, shp.Height)

        cht.Activate

        ActiveChart.Paste

        cht.Border.LineStyle = 0

        cht.Chart.Export DestD

        cht.Delete

        shp.Delete

Set shp = Nothing

Set cht = Nothing

Answer 1

Ciao Giuseppe,

innanzitutto grazie, come sempre, del vostro aiuto e supporto.

Purtroppo mi da sempre lo stesso errore e non riesco a capire perchè.

Nonostante le tue modifiche al codice il risultato è il medesimo.

Se la routine viene eseguita (1 volta su 100) nella cartella di destinazione trovo una immagine bianca.

Tutte le altre volte che non viene eseguita va in debug a:

.CopyPicture xlScreen, xlPicture

la cosa strana è che se premo su debug e pooi continuo manualmente il debug, la routine arriva al termine dell'esecuzione e mi restituisce la foto importata nella cartella di destinazione.

Nel mio primo messaggio ho omesso una parte di codice perchè altrimenti si dovrebbe creare una userform con una listbox ma non penso sia questo il problema in quanto la prima parte serve solo per nominare la foto, comunque allego l'intero codice sperando tu possa individuare l'errore che io non riesco a vedere.

Grazie e buona giornata

Giuseppe

Dim shp As Shape

Dim cht As ChartObject

Dim strPath As String

Dim strfile As String

Dim DestD As String

Dim n As Integer, X As String

Dim img As String

Dim messaggio As String

Dim peppe As String

If Me.LB_Crew.ListIndex = -1 Then

messaggio = MsgBox("Crew member shall be selected to add a new photo", vbInformation, "READ INFORMATION")

Exit Sub

Else

Windows(ThisWorkbook.Name).Visible = True

DestD = ActiveWorkbook.Path & "\Matrix Pictures" & ActiveCell.Offset(0, 1) & ".jpg"

    With Application.FileDialog(msoFileDialogFilePicker)

     .Filters.Clear

        .Filters.Add "File JPG", "*.jpg"

        .Show

    If .SelectedItems.Count = 0 Then Exit Sub

    strfile = .SelectedItems(1)

    End With

With ActiveSheet

        .Range("A1").Select

        .Pictures.insert (strfile)

        X = .Shapes.Count

        For n = 1 To X

            peppe = .Shapes(n).Name

        Next n

    End With

        Set shp = ActiveSheet.Shapes(peppe)

        With shp

        .Width = 200

        .Height = 200

        .Select

        .CopyPicture xlScreen, xlPicture

        Set cht = ActiveSheet.ChartObjects.Add(300, 100, .Width, shp.Height)

    End With

    With cht

        .Activate

        ActiveChart.Paste

        .Border.LineStyle = 0

        .Chart.Export DestD

         .Delete

        shp.Delete

    End With

    Me.foto.Picture = LoadPicture(img)

        Me.Label54.Visible = False

    Set shp = Nothing

    Set cht = Nothing

Prova a sostituire il tuo codice con qualcosa del genere:

'========>>

Option Explicit

'-------->>

Private Sub CommandButton1_Click()

    Dim shp As Shape

    Dim cht As ChartObject

    Dim strPath As String

    Dim strfile As String

    Dim DestD As String

    Dim messaggio As String

    Dim peppe As String

    If Me.LB_Crew.ListIndex <> -1 Then

        messaggio = MsgBox("Crew member shall be selected to add a new photo", _

                                         vbInformation, "READ INFORMATION")

        Exit Sub

    Else

        Windows(ThisWorkbook.Name).Visible = True

        DestD = ActiveWorkbook.Path & "\Matrix Pictures" & ActiveCell.Offset(0, 1) & ".jpg"

        With Application.FileDialog(msoFileDialogFilePicker)

            .Filters.Clear

            .Filters.Add "File JPG", "*.jpg"

            .Show

            If .SelectedItems.Count = 0 Then Exit Sub

            strfile = .SelectedItems(1)

        End With

        With ActiveSheet

            .Range("A1").Select

            .Pictures.Insert (strfile)

          peppe = .Shapes(.Shapes.Count).Name

        End With

        Set shp = ActiveSheet.Shapes(peppe)

        With shp

            .Width = 200

            .Height = 200

            .Select

            DoEvents

            .CopyPicture xlScreen, xlPicture

            DoEvents

            Set cht = ActiveSheet.ChartObjects.Add(300, 100, .Width, shp.Height)

        End With

        With cht

            .Activate

            ActiveChart.Paste

            .Border.LineStyle = 0

            .Chart.Export DestD

            .Delete

            shp.Delete

        End With

        Me.Foto.Picture = LoadPicture(strfile)

        DoEvents

        Me.Label54.Visible = False

    End If

    Set shp = Nothing

    Set cht = Nothing

End Sub

'<<========

Ho recreato la tua Userform e, a me, il file jpg viene salvato e il foto viene caricato nel controllo LB_Crew e non riscontro alcun problema.

===

Regards,

Norman

Answer 2

Ciao Giuseppe,

Grazie Norman,

adesso funziona benissimo.

Grazie per aver risolto il problema anche se non so come mai eseguendo il debug riga riga andava ed in automatico si bloccava.

Comunque mi togli sempre le castagne dal fuoco.

Grazie ancora e buona giornata

Mi fa piacere che tu abbia risolto il problema.

Alla prossima.

===

Regards,

Norman

Answer 3

Grazie Norman,

adesso funziona benissimo.

Grazie per aver risolto il problema anche se non so come mai eseguendo il debug riga riga andava ed in automatico si bloccava.

Comunque mi togli sempre le castagne dal fuoco.

Grazie ancora e buona giornata

Giuseppe

Answer 4

Buongiorno Norman,

come va?

innanzitutto grazie, come sempre, del vostro aiuto e supporto.

Purtroppo mi da sempre lo stesso errore e non riesco a capire perchè.

Nonostante le tue modifiche al codice il risultato è il medesimo.

Se la routine viene eseguita (1 volta su 100) nella cartella di destinazione trovo una immagine bianca.

Tutte le altre volte che non viene eseguita va in debug a:

.CopyPicture xlScreen, xlPicture

la cosa strana è che se premo su debug e pooi continuo manualmente il debug, la routine arriva al termine dell'esecuzione e mi restituisce la foto importata nella cartella di destinazione.

Nel mio primo messaggio ho omesso una parte di codice perchè altrimenti si dovrebbe creare una userform con una listbox ma non penso sia questo il problema in quanto la prima parte serve solo per nominare la foto, comunque allego l'intero codice sperando tu possa individuare l'errore che io non riesco a vedere.

Grazie e buona giornata

Giuseppe

Dim shp As Shape

Dim cht As ChartObject

Dim strPath As String

Dim strfile As String

Dim DestD As String

Dim n As Integer, X As String

Dim img As String

Dim messaggio As String

Dim peppe As String

If Me.LB_Crew.ListIndex = -1 Then

messaggio = MsgBox("Crew member shall be selected to add a new photo", vbInformation, "READ INFORMATION")

Exit Sub

Else

Windows(ThisWorkbook.Name).Visible = True

DestD = ActiveWorkbook.Path & "\Matrix Pictures" & ActiveCell.Offset(0, 1) & ".jpg"

    With Application.FileDialog(msoFileDialogFilePicker)

     .Filters.Clear

        .Filters.Add "File JPG", "*.jpg"

        .Show

    If .SelectedItems.Count = 0 Then Exit Sub

    strfile = .SelectedItems(1)

    End With

With ActiveSheet

        .Range("A1").Select

        .Pictures.insert (strfile)

        X = .Shapes.Count

        For n = 1 To X

            peppe = .Shapes(n).Name

        Next n

    End With

        Set shp = ActiveSheet.Shapes(peppe)

        With shp

        .Width = 200

        .Height = 200

        .Select

        .CopyPicture xlScreen, xlPicture

        Set cht = ActiveSheet.ChartObjects.Add(300, 100, .Width, shp.Height)

    End With

    With cht

        .Activate

        ActiveChart.Paste

        .Border.LineStyle = 0

        .Chart.Export DestD

         .Delete

        shp.Delete

    End With

    Me.foto.Picture = LoadPicture(img)

        Me.Label54.Visible = False

    Set shp = Nothing

    Set cht = Nothing

Answer 5

Ciao Giuseppe,

ho già fatto una domanda simile in passato ma senza risposta.

Questa macro è stata creata su excel 2013 ed ora sul 365 non funziona.

La cosa strana è che se eseguo i passaggi con il debug, la macro funziona, ma se la eseguo in automatico si blocca a:

shp.CopyPicture xlScreen, xlPicture

oppure se a volte passa questo codice mi ritrovo una foto nella catella bianca come se il codice avesse salvato solo la shape senza la foto.

Il codice in questione è il seguente, spero mi possiate aiutare.

Dim shp As Shape

Dim cht As ChartObject

Dim strPath As String

Dim strfile As String

Dim DestD As String

Dim n As Integer, X As String

Dim img As String

Dim messaggio As String

Dim peppe As String

DestD = ActiveWorkbook.Path & "\Matrix Pictures" & "GiuseppeTest" & ".jpg"

  With Application.FileDialog(msoFileDialogFilePicker)

   .Show

  If .SelectedItems.Count = 0 Then Exit Sub

 strfile = .SelectedItems(1)

    End With

Range("A1").Select

ActiveSheet.Pictures.insert (strfile)

  X = ActiveSheet.Shapes.Count

  For n = 1 To X

    peppe = ActiveSheet.Shapes(n).Name

Next

        Set shp = ActiveSheet.Shapes(peppe)

        shp.Width = 200

        shp.Height = 200

        shp.Select

        shp.CopyPicture xlScreen, xlPicture

        Set cht = ActiveSheet.ChartObjects.Add(300, 100, shp.Width, shp.Height)

        cht.Activate

        ActiveChart.Paste

        cht.Border.LineStyle = 0

        cht.Chart.Export DestD

        cht.Delete

        shp.Delete

Set shp = Nothing

Set cht = Nothing

In accordo con le mie personali predelezioni, ho modificato il tuo codice come segue e, a me, funziona senza problemi con Excel 365:

'========>>

Option Explicit

'-------->>

Public Sub Tester()

    Dim shp As Shape

    Dim cht As ChartObject

    Dim strPath As String

    Dim strfile As String

    Dim DestD As String

    Dim n As Integer, X As String

    Dim img As String

    Dim messaggio As String

    Dim peppe As String

    DestD = ActiveWorkbook.Path & "\Matrix Pictures" & "GiuseppeTest" & ".jpg"

    With Application.FileDialog(msoFileDialogFilePicker)

        .Filters.Clear

        .Filters.Add "File JPG", "*.jpg"

        .Show

        If .SelectedItems.Count = 0 Then Exit Sub

        strfile = .SelectedItems(1)

    End With

   With ActiveSheet

        .Range("A1").Select

        .Pictures.Insert (strfile)

        X = .Shapes.Count

        For n = 1 To X

            peppe = .Shapes(n).Name

        Next n

   End With

    Set shp = ActiveSheet.Shapes(peppe)

    With shp

        .Width = 200

        .Height = 200

        .Select

        .CopyPicture xlScreen, xlPicture

        Set cht = ActiveSheet.ChartObjects.Add(300, 100, .Width, shp.Height)

    End With

    With cht

        .Activate

        ActiveChart.Paste

        .Border.LineStyle = 0

        .Chart.Export DestD

        .Delete

        shp.Delete

    End With

    Set shp = Nothing

    Set cht = Nothing

End Sub

'<<========

===

Regards,

Norman