verknüpfte Bilder entknüpfen

Hallo zusammen,
ich habe mit einem VBA Code Bilder in Excel eingfügt. Das funktioniert einwandfrei:


Sub insertPictures()
Dim objPic As Object
Dim lngRow As Long, lngLast As Long
Dim dblOHeight As Double, dblOWidth As Double
Dim strFile As String
Const cstrPath As String = "C:\Users\Maria\Desktop\LC_HW12_Legebilder\5" 'Pfad
Const cstrExtention As String = ".tif"
With Sheets(2) 'Tabellenname anpassen!
lngLast = Application.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row)
For lngRow = 2 To lngLast
If .Cells(lngRow, 1)  "" Then
strFile = Dir(cstrPath & IIf(Right(cstrPath, 1) = "\", "", "\") & .Cells(lngRow, 1) & cstrExtention, vbNormal)
If strFile  "" Then
Set objPic = .Pictures.Insert(cstrPath & IIf(Right(cstrPath, 1) = "\", "", "\") & strFile)
objPic.Top = .Cells(lngRow, 1).Top
objPic.Left = .Cells(lngRow, 7).Left
dblOHeight = objPic.Height
dblOWidth = objPic.Width
objPic.ShapeRange.LockAspectRatio = False
objPic.Height = .Cells(lngRow, 1).Height
objPic.Width = dblOWidth * (objPic.Height / dblOHeight)
End If
End If
Next
End With
Set objPic = Nothing
End Sub

Leider werden die Bilder in der Excel nicht mehr angezeigt, wenn man sie auf einem anderen PC öffnet, da die Verknüpfungen weg sind.
Nun meine Fragen:
1. Kann man den Code so umschreiben, dass die Bilder nicht verküpft eingefügt werden?
2. Gibt es eine Möglichkeit, die bereits eingefügten Bilder unverküpft abzuspeichern? Ich habe schon unter Optionen Erweitert unter "Bildgröße und Qualität" die Hälchen gesetzt bei "Bearbeitungsdaten verwerfen" und "Bilder nicht komprimieren". Das hat aber leider nicht den gewünschten Effekt.
Ich bin über jede Hilfe dankbar!
VG
Martin

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Code: [Cc][+][-] Public Sub insertPictures() Const cstrPath As String = "C:\Users\Maria\Desktop\LC_HW12_Legebilder\5\" ' Pfad Const cstrExtention As String = "*.tif" Dim objPic As Shape Dim lngRow As Long Dim sngOHeight As Single, sngOWidth As Single Dim strFile As String With Worksheets(2) ' Tabellenname anpassen! For lngRow = 2 To Application.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row) If Not IsEmpty(.Cells(lngRow, 1).Value) Then strFile = Dir(cstrPath & .Cells(lngRow, 1).Text & cstrExtention, vbNormal) If strFile <> vbNullString Then Set objPic = .Shape.AddPicture(Filename:=cstrPath & strFile, _ LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _ Left:=.Cells(lngRow, 7).Left, Top:=.Cells(lngRow, 1).Top, Width:=-1, Height:=.Cells( _ lngRow, 1).Height) With objPic sngOHeight = .Height sngOWidth = .Width .LockAspectRatio = False .Width = sngOWidth * (.Height / sngOHeight) End With End If End If Next End With Set objPic = Nothing End Sub

Code: [Cc][+][-] Public Sub insertPictures() Const cstrPath As String = "C:\Users\Maria\Desktop\LC_HW12_Legebilder\5\" ' Pfad Const cstrExtention As String = ".tif" Dim objPic As Shape Dim lngRow As Long Dim sngOHeight As Single, sngOWidth As Single Dim strFile As String With Worksheets(2) ' Tabellenname anpassen! For lngRow = 2 To Application.Max(3, .Cells(.Rows.Count, 1).End(xlUp).Row) If Not IsEmpty(.Cells(lngRow, 1).Value) Then strFile = Dir$(cstrPath & .Cells(lngRow, 1).Text & cstrExtention, vbNormal) If strFile <> vbNullString Then Set objPic = .Shapes.AddPicture(Filename:=cstrPath & strFile, _ LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _ Left:=.Cells(lngRow, 7).Left, Top:=.Cells(lngRow, 1).Top, Width:=-1, Height:=-1) With objPic sngOHeight = .Height sngOWidth = .Width .LockAspectRatio = False End With objPic.Height = .Cells(lngRow, 1).Height objPic.Width = sngOWidth * (objPic.Height / sngOHeight) End If End If Next End With Set objPic = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread