PDA

Vollständige Version anzeigen : Bild in Zelle ohne Verknüpfung und dabei ursprüngliche Bildproportion beibehalten


XDuckX-Fan
25.06.2015, 18:25
Hallo Forengemeinde,
ich habe große Probleme ein Bild in eine Zelle einzufügen/anzupassen und dabei 2 Bedingungen zu erfüllen ...1. ohne Datei-Verknüpfung einzufügen und 2. dabei noch die ursprüngliche Bildproportion beizubehalten, da das Bild beim draufklicken noch "gezoomt" werden soll ...

Als weitere Erklärung dazu anbei eine Datei als Anhang...

Ich hoffe, hier weiß (wie immer :D ) Jemand Rat....

Gruß
Thomas

xlph
26.06.2015, 05:55
Hallo Thomas,

über Shell lassen sich die Datei-Eigenschaften auslesen,
somit auch die Abmessungen bei Bildern.

Aus den Abmessungen lässt sich das Höhen-Breiten-Verhältnis berechnen.

Option Explicit

Public Const StPfad As String = "C:\" '"E:\DCIM\100OLYMP\"

Public Sub FotoInZelleDauerhaft()

Dim vPictureFullName As Variant
Dim sPicturePath As String
Dim sPictureFileName As String

Dim sngPictureWidth As Single
Dim sngPictureHeight As Single

Dim sngPicRatio As Single

Dim picBild As Shape

'...prüfen, ob Ordnerpfad der Kamera vorhanden ist...
If Dir(StPfad) = "" Then
MsgBox "...bitte erst die Kamera an den PC anschließen..."
Exit Sub
End If

'Laufwerk und Ordnerpfad zum Öffnen vorgeben
'ChDrive "C:\" '"E:\DCIM\100OLYMP\"
'ChDir "C:\" '"E:\DCIM\100OLYMP\"

'...Dateiendung bestimmen (welche Datei soll geöffnet werden...hier nur Bilddateien...)
vPictureFullName = Application.GetOpenFilename _
("Bilddatei (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
, "Bild für Import auswählen...")

'...wenn keine Bilddatei ausgewählt wurde dann Makro beenden
If vPictureFullName = False Then Exit Sub

sPictureFileName = Dir(vPictureFullName)
sPicturePath = Replace(vPictureFullName, sPictureFileName, "")

Call getPictureDimensions(sPicturePath, sPictureFileName, sngPictureWidth, sngPictureHeight)


sngPicRatio = sngPictureHeight / sngPictureWidth

sngPictureHeight = sngPicRatio * ActiveCell.Width

If sngPictureHeight > ActiveCell.Height Then
sngPictureHeight = ActiveCell.Height
End If

sngPictureWidth = sngPictureHeight / sngPicRatio


Set picBild = ActiveSheet.Shapes.AddPicture(vPictureFullName, _
LinkToFile:=False, SaveWithDocument:=True, _
Left:=ActiveCell.Left, _
Top:=ActiveCell.Top, _
Width:=sngPictureWidth, _
Height:=sngPictureHeight)

picBild.LockAspectRatio = msoTrue
picBild.Placement = xlMove

picBild.OnAction = "BildZoomen"

Set picBild = Nothing

End Sub


Public Sub BildZoomen()

Const conZoomHeight As Single = 250

With ActiveSheet.Shapes(Application.Caller)
If .Height <> conZoomHeight Then
.Height = conZoomHeight
Else
.Height = .TopLeftCell.Height
End If
End With

End Sub


Public Sub getPictureDimensions(ByVal strPath As String, ByVal strFilename As String, _
ByRef sngPicWidth As Single, ByRef sngPicHeight As Single)

Dim objShell As Object
Dim objFolder As Object
Dim objFolderItem As Object

Dim strDimensions As String
Dim astrDimensions() As String

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(CVar(strPath))
Set objFolderItem = objFolder.ParseName(strFilename)

strDimensions = objFolder.GetDetailsOf(objFolderItem, 31)

strDimensions = Replace(strDimensions, " ", "")

strDimensions = Mid$(strDimensions, 2, Len(strDimensions) - 2)

astrDimensions() = Split(strDimensions, "x", , vbTextCompare)

sngPicWidth = CSng(astrDimensions(0))
sngPicHeight = CSng(astrDimensions(1))

Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing

End Sub

Nepumuk
26.06.2015, 07:11
Hallo xlph.

wenn du bei Width und Height -1 als Wert angibst, dann wird das Bild in der Originalgröße eingefügt.

xlph
26.06.2015, 07:41
Verdammt, das sagst du mir jetzt erst...

In der Hilfe steht nix. Wie kommst du darauf?

Ich kann mich erinnern dass du eine API geschrieben hast um
Bilder ohne Verknüpfung einzufügen, da dachte ich wohl dass es
mit reinen Excelmitteln nicht gehen würde.

Danke dennoch.

Hier der vereinfachte Code:
Public Sub FotoInZelleDauerhaft()

Dim vPictureFullName As Variant
Dim picBild As Shape

'...prüfen, ob Ordnerpfad der Kamera vorhanden ist...
If Dir(StPfad) = "" Then
MsgBox "...bitte erst die Kamera an den PC anschließen..."
Exit Sub
End If

'Laufwerk und Ordnerpfad zum Öffnen vorgeben
'ChDrive "C:\" '"E:\DCIM\100OLYMP\"
'ChDir "C:\" '"E:\DCIM\100OLYMP\"

'...Dateiendung bestimmen (welche Datei soll geöffnet werden...hier nur Bilddateien...)
vPictureFullName = Application.GetOpenFilename _
("Bilddatei (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
, "Bild für Import auswählen...")

'...wenn keine Bilddatei ausgewählt wurde dann Makro beenden
If vPictureFullName = False Then Exit Sub


Set picBild = ActiveSheet.Shapes.AddPicture(vPictureFullName, _
LinkToFile:=False, SaveWithDocument:=True, _
Left:=ActiveCell.Left, _
Top:=ActiveCell.Top, _
Width:=-1, _
Height:=-1)


With picBild

.LockAspectRatio = msoTrue
.Placement = xlMove

.Height = ActiveCell.Height

If .Width > ActiveCell.Width Then
.Width = ActiveCell.Width
End If

.OnAction = "BildZoomen"

End With

Set picBild = Nothing

End Sub

Nepumuk
26.06.2015, 07:51
Hallo,

sorry, aber damals wusste ich das auch nicht und aus der Hilfe geht es nicht hervor.

P.S. kennst du schon AddPicture2 ? Damit lassen sich Bilder beim Einfügen komprimieren.

XDuckX-Fan
26.06.2015, 07:54
Hallo xlph, Nepumuk...vielen vielen Dank.
Wie immer Verlass hier im Forum...:grins:

Wünsche ein schönes Wochenende...

Gruß
Thomas

xlph
26.06.2015, 08:44
Gut zu wissen...gibts aber erst ab XL2013, hab noch XL2010.

Shapes.AddPicture2-Methode (Excel) (https://msdn.microsoft.com/de-de/library/office/dn448392.aspx)

Das mit -1 muss man sich merken.

Wie bist du drauf gestoßen?

XDuckX-Fan
26.06.2015, 08:55
Hallo xlph, Nepumuk...
muß mich leider nochmal melden.
@ xlph...der Code funktioniert (habe Deinen 2. Code benutzt, im 1. Codebeispiel funktioniert das mit der ursprünglichen Bildproportion beibehalten auch nicht bzw. ist beim "zoomen" ebenfalls unscharf...) soweit einwandfrei...jedoch speicher und schließe ich die Exeldatei, rufe sie erneut auf, hat das eingefügte Bild seine ursprüngliche Bildproportion verloren und ist beim "zoomen" entsprechend unscharf...woher kommt das??

Gruß
Thomas

xlph
26.06.2015, 09:04
Hallo,

das kann ich nicht bestätigen.

Lad die Datei hoch.

XDuckX-Fan
26.06.2015, 12:14
Hallo xlph,

anbei nochmal die Datei....sorry, aber ich habe es gerade nochmal ausprobiert.

FotoInZelleDauerhaft1 = dein 1. Codebeispiel....hier habe ich nach dem Einfügen beim "zoomen" sofort ein unscharfes Bild...
FotoInZelleDauerhaft2 = dein 2. Codebeispiel funktioniert einwandfrei, jedoch, wie schon erwähnt...Datei gespeichert-->geschlossen-->wieder geöffnet-->erneut "zoomen" ausgeführt--> Bild ist unscharf...ist schon komisch...

Gruß
Thomas

xlph
26.06.2015, 13:01
Oh ja, du hast recht.

Sobald gespeichert wird, wird die aktuelle Größe die neue Normalgröße (100%).

Es muss also verhindert werden, dass die Bilder in Normalgröße gespeichert werden.

Mir fällt da nur ein Workaround ein:
Im Workbook_BeforeSave-Ereignis alle Bilder auf die Zoom-Höhe bringen,
dann speichern und wieder auf Normalhöhe setzen.

XDuckX-Fan
26.06.2015, 13:17
....danke, werde ich mal testen und melde mich dann wieder...

Gruß
Thomas

xlph
26.06.2015, 14:11
Hier mal ein Entwurf....

XDuckX-Fan
26.06.2015, 16:36
Hallo xlph,
...was soll ich sagen...Du bist der Beste :top: ...

Dann werde ich mir den Code mal "einverleiben" um was zu lernen :idee: .

Vielen Dank.

Gruß
Thomas

xlph
26.06.2015, 20:07
Hallo,

der Workaround ist nicht nötig.

Excel komprimiert die Bilder, falls nicht unter Optionen abgewählt.

Leider weiß ich nicht wie die Eigenschaft per VBA gesetzt wird.

Die Aufzeichnung bringt kein Ergebnis.

XDuckX-Fan
29.06.2015, 23:31
Hallo xlph,
kein Problem mit der Komprimierung...es wird zwar manches mal so einiges an Datensätzen und somit auch an Bildern vorhanden sein, diese Daten (-Zeilen) werden aber auch nach abarbeitung wieder gelöscht werden, sodass sich die Datei (hoffe ich :rolleyes: ) nicht zu sehr "aufbläht"...
Sollte ich etwas bezüglich Komprimierung finden, melde ich mich nochmal....setze den Beitrag erstmal auf "erledigt".

Hab erst einmal vielen Dank für Deine Mühe...(leider kann ich Deine Mühe nicht bewerten...ich soll erst einmal andere bewerten, bevor ich Dich wieder bewerten kann...)...dann mach ich das mal so...suuuper klasse Arbeit :top:... und hole das andere dann nach...:grins:

Wünsche eine :sun:ige Woche...

Gruß
Thomas

PS:...habe gerade festgestellt, wenn ich die voreingestellte "220 ppi" auf "96 ppi" ändere, habe ich bei 4 Bildern (Größe jeweils knapp 1 MB) einen Dateigrößenzuwachs von 250 KB...das ist annehmbar...bei der Einstellung von "220 ppi" hätte die Datei mittlerweile eine Größe von 3,2 MB.....hast Du vielleicht eine Idde, wie ich die Bilder beim Einfügen in den "Vordergrund" bringe, damit beim Vergrößern die anderen "kleinen" Bilder nicht zu sehen sind??

xlph
30.06.2015, 00:10
Public Sub BildZoomen()

With ActiveSheet.Shapes(Application.Caller)
If .Height <> gconZoomHeight Then
.Height = gconZoomHeight
.ZOrder msoBringToFront
Else
.Height = .TopLeftCell.Height
End If
End With

End Sub

XDuckX-Fan
30.06.2015, 10:59
....thanks.....

XDuckX-Fan
03.07.2015, 13:57
Hallo xlph,
im Zuge meiner Tabellenfertigstellung bin ich noch auf ein Problem beim speichern gestossen...das eingefügte wird "gezoomt" und bleibt dann so...als wird nicht wieder "zurück gezoomt"...Hintergrund ist, dass ich den Bildnamen, den du vorgegeben hast, gerne anders haben wollte...nämlich zusätzlich den Wert aus der aktiven Zeile Spalte A (dort steht eine Nummer drin)...du hattest hier ja die Zelladresse, in der das Bild eingefügt wird, angegeben.
Geändert hatte ich den Code in "Public Sub FotoInZelleDauerhaft2()" wie folgt:
Set picBild = ActiveSheet.Shapes.AddPicture(vPictureFullName, _
LinkToFile:=False, SaveWithDocument:=True, _
Left:=ActiveCell.Left, _
Top:=ActiveCell.Top, _
Width:=-1, _
Height:=-1)

With picBild

.Name = "picBild_" & Cells(ActiveCell.Row, 1).Value 'ActiveCell.Address(0, 0)

.Placement = xlMove
.LockAspectRatio = msoTrue

.Height = ActiveCell.Height

If .Width > ActiveCell.Width Then
.Width = ActiveCell.Width
End If

.OnAction = "BildZoomen"

End With

Set picBild = Nothing
...nun habe ich, wie gesagt, das Problem, das das Bild beim speichern entweder gezoomt bleibt oder die Proportion nicht beibehalten wird (Bildgröße in Zelle hat dann 100%)
Was muss ich in den anderen Codes ändern, damit ich "meinen" Bildnamen verwenden kann?....oder geht das so nicht?....irgendwie bekomme ich das nicht hin...:stupid: :depressed

Gruß
Thomas

xlph
03.07.2015, 19:32
Hallo,

die ZellAdresse im Namen dient nicht Dekorations-Zwecken.

Ich habe es umgestellt.

Änderungen wurden in folgenden Prozeduren gemacht:
- FotoInZelleDauerhaft2
- BilderZoomen

Deine Bilder musst du nochmal alle löschen.

Option Explicit

Public Const StPfad As String = "C:\" '"E:\DCIM\100OLYMP\"

Public Const gconZoomHeight As Single = 250

Public Sub FotoInZelleDauerhaft2()

Dim vPictureFullName As Variant
Dim picBild As Shape

'...prüfen, ob Ordnerpfad der Kamera vorhanden ist...
If Dir(StPfad) = "" Then
MsgBox "...bitte erst die Kamera an den PC anschließen..."
Exit Sub
End If

'Laufwerk und Ordnerpfad zum Öffnen vorgeben
'ChDrive "C:\" '"E:\DCIM\100OLYMP\"
'ChDir "C:\" '"E:\DCIM\100OLYMP\"

'...Dateiendung bestimmen (welche Datei soll geöffnet werden...hier nur Bilddateien...)
vPictureFullName = Application.GetOpenFilename _
("Bilddatei (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
, "Bild für Import auswählen...")

'...wenn keine Bilddatei ausgewählt wurde dann Makro beenden
If vPictureFullName = False Then Exit Sub


Set picBild = ActiveSheet.Shapes.AddPicture(vPictureFullName, _
LinkToFile:=False, SaveWithDocument:=True, _
Left:=ActiveCell.Left, _
Top:=ActiveCell.Top, _
Width:=-1, _
Height:=-1)


With picBild

.Name = "picBild_" & ActiveSheet.Cells(ActiveCell.Row, 1).Value

.AlternativeText = "BildZelle: " & ActiveCell.Address(0, 0)

.LockAspectRatio = msoTrue
.Placement = xlMove

.Height = ActiveCell.Height

If .Width > ActiveCell.Width Then
.Width = ActiveCell.Width
End If

.OnAction = "BildZoomen"

End With

Set picBild = Nothing

End Sub


Public Sub BildZoomen()

With ActiveSheet.Shapes(Application.Caller)
If .Height <> gconZoomHeight Then
.Height = gconZoomHeight
.ZOrder msoBringToFront
Else
.Height = .TopLeftCell.Height
End If
End With

End Sub

Public Sub BilderZoomen(Optional ByVal blnZoomSet As Boolean, Optional ByVal blnZoomReset As Boolean)
Dim shpBild As Shape
Dim strZellAdresse As String


With Tabelle1

If blnZoomSet Then

For Each shpBild In .Shapes
If shpBild.Type = msoPicture Then
If shpBild.AlternativeText Like "BildZelle: *" Then
shpBild.LockAspectRatio = msoTrue
shpBild.Height = gconZoomHeight
End If
End If
Next

ElseIf blnZoomReset Then

For Each shpBild In .Shapes
If shpBild.Type = msoPicture Then
If shpBild.AlternativeText Like "BildZelle: *" Then
strZellAdresse = Split(shpBild.AlternativeText, ": ")(1)
If IsRange(shpBild.Parent, strZellAdresse) Then
shpBild.Left = .Range(strZellAdresse).Left
shpBild.Top = .Range(strZellAdresse).Top
shpBild.Height = .Range(strZellAdresse).Height
End If
End If
End If
Next

End If

End With

Set shpBild = Nothing
End Sub

Private Function IsRange(ByRef wksBlatt As Worksheet, ByVal strAdresse) As Boolean
On Error Resume Next
IsRange = Not wksBlatt.Range(strAdresse) Is Nothing
On Error GoTo 0
End Function

XDuckX-Fan
03.07.2015, 22:04
Hallo xlph,
vielen Dank für Deine Hilfe...
ich habe mir schon gedacht, dass die ZellAdresse im Namen nicht nur zur Zierde dient...und ich hoffe, ich liege damit richtig...das dieses etwas mit der Code-Zeile strZellAdresse = Split(shpBild.AlternativeText, ": ")(1) bzw, vor Deiner jetzigen Änderung strZellAdresse = Split(shpBild.Name, "_")(1) zu tun hat...ich zermartere mir schon die ganze Zeit den Kopf diese Zeile zu verstehen...was bedeutet Split ? (...rein übersetzt heißt das ja teilen oder geteilt...) obwohl...mir fällt gerade ein...wird hier beim Auslesen der Bildname bis zum "_" abgeschnitten, womit man dann die Zelladresse hat in der sich das Bild befindet??...fällt mir jetzt gerade erst auf, was es bedeuten könnte, wo ich Deinen neuen Code mit dem ": " sehe....und ärgere ich mich gerade darüber, dass mir das nicht schon eher eingefallen ist... ohhh ich Depp :stupid: ...und was bedeutet ganz am Schluß das (1) ?

Also nochmals...vielen Dank für Deine Mühe und wünsche ein schönes Wochenende...

Gruß
Thomas

xlph
04.07.2015, 07:46
Hallo,

wenn du Fragen zu einzelnen Objekten, Methoden , Funktionen oder Eigenschaften hast, dann setze den Cursor drauf und Drücke F1.
Zu diesem Ausdruck öffnet sich die VBA-Hilfe.

Split() zerlegt eine Zeichenkette in ein Array anhand eines Trennzeichens bzw.
-zeichenkette ("_" bzw. ": "). Das entstandene Array ist nullbasiert, heißt, das
1. Element des Arrays beginnt mit dem Index 0. Da sich aber die Zelladresse
im 2. Element befindet wird eine 1 gesetzt.

ZellAdresse = Split([Zeichenkette], [Trennzeichen<-kette>])(Array-Element-Index)

XDuckX-Fan
06.07.2015, 11:24
Hallo xlph,
...danke für die ausführliche Auskunft...und das mit "F1" werde ich mir zukünftig mal zu Herzen nehmen...;)

Grfuß
Thomas