Bilder ohne Detailverlust verkleinern
06.03.2017 15:55:24
Christian
ich habe mir folgenden Code geschrieben, um in einer Excel-Tabelle diverse Informationen zusammen zu tragen (inklusive Bildern). Diese Bilder werden später dann je nach Nutzerauswahl in einer PowerPoint-Präsentation mit eingebunden.
Private Sub Bild_Einfügen(ByVal rng As Excel.Range, ByVal Name As String)
'Variablendeklaration
Dim wks As Worksheet
Dim Links As Double
Dim Breite As Double
Dim Oben As Double
Dim Höhe As Double
Dim Link As String
'Datei über Explorer auswählen
Set wks = ActiveWorkbook.Sheets(1)
wks.Unprotect
'Positionsdaten auslesen
Links = rng.Left
Breite = rng.Width
Oben = rng.Top
Höhe = rng.Height
'Bild Link einlesen
Link = Application.GetOpenFilename("Bild-Dateien (*.jpg;*.png;*.bmp;*.gif;.*emf),*.jpg;*. _
png;*.bmp;*.gif;.*emf", title:="Bilddatei Auswählen")
If Link = "Falsch" Then 'Klick auf Abbrechen beendet Prozedur
Exit Sub
End If
'Altes Bild löschen
On Error Resume Next
wks.Shapes.Range(Array(Name)).Delete
'Bild an entsprechende Stelle einfügen/ersetzen
' With wks.Pictures.Insert(Link)
With wks.Shapes.AddPicture(Link, False, msoTrue, Links, Oben, -1, -1)
.LockAspectRatio = msoTrue
.Name = Name
.Width = Breite * 0.97
If .Height > Höhe * 0.97 Then .Height = Höhe * 0.97
.Left = Links + 0.5 * (Breite - .Width)
.Top = Oben + 0.5 * (Höhe - .Height)
End With
wks.Protect
End Sub
Die Bilder werden in den richtigen Bereich hinein verkleinert. Leider verlieren hochauflösende Bilder beim Verkleinern ihre Details. Gibt es eine Möglichkeit, Bilder optisch zu komprimieren aber in voller Auflösung zu behalten?
Danke und Gruß,
Christian
Anzeige