VBA - Zelle mit Bild kopieren und einfügen (fortlaufend bis Zelle Leer sind)

[duAffentier]

Hallo,

ich hab ein Problem mit den Fotos, welche nur als MSOlinkedPicture eingefügt sind.

Ab Zelle D15 werden Fotos eingefügt. Diese sind genau so groß wie die Zelle! Aber als verlinkte Grafik!
Dies ist Ok, sofern die Datei nicht versendet wird. Andere Befehle zum Foto einfügen funktionieren nicht, aufgrund der Anpassung der Zellen.


Meine Lösung Vitamin B:

Nun benötige ich ein Makro, was ab Zelle D15 jeweils eine Zelle markiert, kopiert und als "Bild" einfügt.
Das fortlaufend, bis kein Foto mehr in einer Zelle ist.
Es kann 1 bis x Fotos sein. Beginnen immer bei D15.
Also D15 Kopieren, als Bild einfügen, dann zu D16 etc...bis zur ersten leeren Zelle.

Ist sowas machbar?

 

[Gameforce]

  Sub Range_To_Image()

  Dim objPict As Object

  Dim objChrt As Chart

  Dim rngImage As Range

  Dim strFile As String

  Dim Tabelle As String

  Dim Zelle As Range

  Dim Pic As Picture

  Dim BildName As String

  Dim Pfad As String

  Dim X As Long


  Pfad = "E:\"  'Ort wo das Bild zwischenndurch abgespeichert wird

  BildName = "TestBild.gif"

  Tabelle = "Tabelle1"



  On Error GoTo ErrExit


  With Sheets(Tabelle) 'Tabellenname - Anpassen!



      For X = 15 To Sheets(Tabelle).UsedRange.SpecialCells(xlCellTypeLastCell).Row


            Set rngImage = .Range("D" & X)

            rngImage.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

            .PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False

            Set objPict = .Shapes(.Shapes.Count)

          

            strFile = Pfad & BildName 'Pfad und Dateiname für das Bild

 

            objPict.Copy

            Set objChrt = .ChartObjects.Add(1, 1, objPict.Width, objPict.Height).Chart

            objChrt.Paste

            objChrt.Export strFile

            objChrt.Parent.Delete

            objPict.Delete

          

                  

            Set Zelle = Range("D" & X) 'hier wird das bild eingefügt

            Set Pic = .Pictures.Insert(Pfad & BildName)

            Pic.Top = Zelle.Top

            Pic.Left = Zelle.Left

            Pic.Name = "Bildname_Nr." & X

          

          

                                        

        Next X

          

 

  End With


ErrExit:

  Set objPict = Nothing

  Set objChrt = Nothing

  Set rngImage = Nothing

End Sub

 

[duAffentier]

Hallo!

ich hab dir mal mein Makro angehangen!
Im Reiter ESD kannst du das Makro starten und mal paar Fotos auswählen. Diese sind dann in der Datei.
Diese Fotos sollen 1:1 kopiert und ersetzt werden. Da die Fotos als verlinkte Grafik nur importiert werden.
Wenn du die Fotos von einem USB Stick oder Netzlaufwerk einfügst und dann den USB/Netzlaufwerk trennst, sind die Fotos nicht mehr da.
Dein Makro wollte bei mir nicht klappen.

 

[Gameforce]

Habe den Code modifiziert. Evtl. funktioniert das jetzt. Das Problem hatten andere auch schon. Mann muss eine andere Einfüge-Funktion nutzen. Schah Dir jetzt mal die Seite "Tabelle1" ein und klick auf die Taste. Bin mal gespannt.