Inserimento immagini in un foglio excel 2003 - 2010

Question

Ciao a tutti

Ho la necessità di inserire un certo numero di immagini in un foglio, con determinate dimensioni, alternando le celle una si e una no. (es: A1 immagine e dimensionamento, A2 vuoto con dimensioni standard, A3 immagine e relativo dimensionamento ecc ecc).

Per farlo utilizzo con successo la seguente macro in Excel 2003:

---

Sub InsImg()

Dim strFile As String

Application.ScreenUpdating = False

'cancella immagini presenti sul foglio

ActiveSheet.Shapes.SelectAll

Selection.Delete

mPath = "C:\TuaCartella"

r = 1 ' riga inizio inserimento immagini

' cerca tutte le immagini jpg nella cartella

strFile = Dir(mPath & "\*.jpg")

Do While strFile <> ""

    'inserisce immagini in col A e adatta dimensioni

    With ActiveSheet.Pictures.Insert(mPath & "" & strFile)

        .Top = Range("A" & r).Top

        .Left = Range("A" & r).Left

        .Height = 89.2913385827

        .Width = 132.6614173228

    End With

    ' Adatta altezza-larghezza cella

    Cells(r, 1).RowHeight = 90

    Cells(r, 1).ColumnWidth = 24

    r = r + 2

    strFile = Dir

Loop

Application.ScreenUpdating = True

End Sub

---

Fatto sta che eseguendo il medesimo codice in Excel 2010, le immagini occupano 2 celle (es: A1 e A2 - A3 e A4), come si può rilevare dalla seguente immagine,

sulla sinistra il risultato con 2003, sulla destra con 2010.

Ho notato che eliminando: .Width = 132.6614173228, l'immagine ha l'altezza giusta, ma la larghezza naturalmente è quella originale.

Qualche suggerimento?

Grazie

domenico

Answer 1

Ciao dodo47,

la seguente routine l'ho testata con Excel 2003, 2013 e 2016. Forse va anche con Excel 2010.

Option Explicit

Public Sub aTest()

On Error GoTo ErrH

' --- PERSONALIZZARE ---------- >

'

Const cstrWshName As String = "Foglio1"

Const cstrPath    As String = "D:\Percorso"

Const cstrExt     As String = "jpg"

'

' --- PERSONALIZZARE ---------- <

Const clngBlock   As Long = 1000

Dim app   As Excel.Application

Dim wfn   As Excel.WorksheetFunction

Dim wbk   As Excel.Workbook

Dim wsh   As Excel.Worksheet

Dim shps  As Excel.Shapes

Dim rng   As Excel.Range

Dim ps          As String

Dim strPath     As String

Dim strFile     As String

Dim lngCount    As Long

Dim astrFiles() As String

Dim i           As Long

Dim r           As Long

      Set app = GetObject(Class:="Excel.Application")

      With app

        .ScreenUpdating = False

        ps = .PathSeparator

        Set wfn = .WorksheetFunction

        Set wbk = .ThisWorkbook

      End With

      Set wsh = wbk.Worksheets(cstrWshName)

      Set shps = wsh.Shapes

      strPath = cstrPath

      If Right$(strPath, 1) <> ps Then

        strPath = strPath & ps

      End If

      ReDim astrFiles(0 To 0)

      strFile = Dir(strPath & "*." & cstrExt, vbNormal)

      Do While LenB(strFile)

        lngCount = lngCount + 1

        If lngCount > UBound(astrFiles) Then

          ReDim Preserve astrFiles(LBound(astrFiles) _

                                   To _

                                   (1 + (UBound(astrFiles) \ clngBlock)) _

                                   * clngBlock)

        End If

        astrFiles(lngCount - 1) = strPath & strFile

        strFile = Dir

      Loop

      If lngCount Then

        ReDim Preserve astrFiles(LBound(astrFiles) To lngCount - 1)

      Else

        MsgBox "Nessun file trovato."

        GoTo ExtP

      End If

      ' Test contenuto di astrFiles

      '

      'With wsh

      '  .Cells.Clear

      '  .Range("A1").Resize(lngCount, 1) = wfn.Transpose(astrFiles)

      'End With

      'GoTo ExtP

      With wsh

        .Cells.Clear

        .DrawingObjects.Delete

      End With

      For i = LBound(astrFiles) To UBound(astrFiles)

        r = 1 + 2 * i

        Set rng = wsh.Cells(r, 1)

        With rng

          .RowHeight = 90

          .ColumnWidth = 24

          shps.AddPicture Filename:=astrFiles(i), _

                          LinkToFile:=msoFalse, _

                          SaveWithDocument:=msoTrue, _

                          Left:=.Left, _

                          Top:=.Top, _

                          Width:=.Width, _

                          Height:=.Height

        End With

      Next

ExtP: On Error Resume Next

      Excel.Application.ScreenUpdating = True

      Set shps = Nothing

      Set rng = Nothing

      Set wsh = Nothing

      Set wbk = Nothing

      Set wfn = Nothing

      Set app = Nothing

      On Error GoTo 0

      Exit Sub

ErrH: MsgBox Err.Description

      Resume ExtP

End Sub

Answer 2

Ciao dodo47,

grazie a te del cortese riscontro.

Answer 3

Ciao dodo47,

per far funzionare il tuo codice come vuoi tu inserisci l'istruzione che ho evidenziato in grassetto:

        With ActiveSheet.Pictures.Insert(mPath & "" & strFile)

.ShapeRange.LockAspectRatio = msoFalse

          .Top = Range("A" & r).Top

Credo, ma non sono sicurissimo, questo sia necessario a causa del fatto che da una versione all'altra è cambiato il default del blocco delle proporzioni.

Comunque non è più consigliabile usare l'oggetto Picture, da sostituire con Shape. Avrai notato che nel Visualizzatore oggetti sia la collezione Pictures che l'oggetto Picture risultano nascosti:

Answer 4

Ciao Maurizio e ancora grazie.

Mi rimane sempre da chiarire "il perché" le mie istruzioni generano nel 2010 quel "difetto".

Comunque...cosa fatta....

cari saluti

domenico

Answer 5

Ciao Maurizio e grazie della cortese risposta.

Per il momento non sono in grado di testarlo sul 2010 ma appena posso ti relazionerò sull'esito.

Come detto, dovrò sostituire:

Width:= 89.2913385827, _

Height:= 132.6614173228

Ma se funziona, mi rimarrà comunque il dubbio del perché la mia routine fa quello scherzo!

A presto

domenico