Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender

Forumthread: Foto an Zelle anpassen

Foto an Zelle anpassen
27.03.2007 16:34:52
Stefan
hallo Vba Profis
Ich habe das folgende Programm hier aus dem Archiv (vielen Dank - ich glaube Sepp hat es geschrieben vielen dank Sepp ) es fungkioniert auch soweit
Es sucht in Spalte A eine Foto Adresse und fügt das Bild ein.
Leider in zu großer Größe und immer übereinander.
Gibt es eine Möglichkeit das Foto auch in die Zelle neben der AdressZelle (zB A2) an Zellgrösse b2 einzufügen
gibt es hierzug eine Lösung ?
vielen Dank im voraus
Stefan
Dim rng As Range
Dim lngR As Long
Dim i As Integer
Dim wks As Worksheet
Set wks = ActiveSheet
On Error Resume Next
Application.ScreenUpdating = False
If blnChk = False Then
lngR = wks.Range("A65536").End(xlUp).Row
blnChk = True
For Each rng In wks.Range("A2:A" & lngR)
If rng "" And rng.Rows.Hidden = False Then
rng.Select
wks.Pictures.Insert(rng.Value).Name = "Bild_" & intC
rng.RowHeight = wks.Pictures("Bild_" & intC).Height
intC = intC + 1
End If
Next
Else
For i = 0 To intC - 1
wks.Pictures("Bild_" & i).Delete
Next
wks.Range("A:A").Rows.AutoFit
blnChk = False
intC = 0
End If
Application.ScreenUpdating = True
Anzeige

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Foto an Zelle anpassen
27.03.2007 21:13:00
fcs
Hallo Stefan,
mit folgenden Anpassungen wird das Bild in die Spalte B eingefügt.
Zusätzlich kannst du das geladenen Bild auf eine gewünschte Größe einstellen (hier z.B. 40 pt)
Gruß
Franz
  Dim rng As Range
Dim lngR As Long
Dim i As Integer
Dim wks As Worksheet
Dim Bild As Shape
Set wks = ActiveSheet
On Error Resume Next
Application.ScreenUpdating = False
'  blnChk = True
If blnChk = False Then
lngR = wks.Range("A65536").End(xlUp).Row
blnChk = True
For Each rng In wks.Range("A2:A" & lngR)
If rng  "" And rng.Rows.Hidden = False Then
rng.Offset(0, 1).Select
wks.Pictures.Insert(rng.Value).Name = "Bild_" & intC
Set Bild = wks.Shapes("Bild_" & intC)
rng.RowHeight = 40
Bild.ShapeRange.LockAspectRatio = msoTrue
Bild.Height = rng.RowHeight
intC = intC + 1
End If
Next
Else
For i = 0 To intC - 1
wks.Pictures("Bild_" & i).Delete
Next
wks.Range("A:A").Rows.AutoFit
blnChk = False
intC = 0
End If
Application.ScreenUpdating = True

Anzeige
AW:danke Franz , es funktioniert
28.03.2007 17:48:25
Stefan
super, danke
;

Forumthreads zu verwandten Themen

Anzeige
Anzeige
Entdecke relevante Threads

Schau dir verwandte Threads basierend auf dem aktuellen Thema an

Alle relevanten Threads mit Inhaltsvorschau entdecken
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Entdecke mehr
Finde genau, was du suchst

Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden

Suche nach den besten Antworten
Unsere beliebtesten Threads

Entdecke unsere meistgeklickten Beiträge in der Google Suche

Top 100 Threads jetzt ansehen
Anzeige