VBA-Beispiel 044
mail schreiben
mail schreiben

Bild von einem Zellbereich in Photoshop erstellen
Dieses Makro kopiert einen Zellbereich aus Tabelle1, erstellt davon in Photoshop eine neue PSD-Datei und speichert die PSD-Datei im Ordner der Exceldatei.

Getestet hab ich das nur auf einem relativ flotten Rechner mit Photoshop CS.
Sub Zellen_kopieren_Bild_erstellen()
' unter Extras - Verweis Verweis auf
' Adobe Photoshop 8.0 Object Library
Dim PS_exe As Photoshop.Application
Dim PS_Datei As Photoshop.Document
Dim PS_Ebene As Photoshop.ArtLayer
Dim PS_Optionen As Photoshop.PhotoshopSaveOptions

On Error GoTo Hell
'Zellen kopieren
ThisWorkbook.Worksheets("Tabelle1").Range("B5:D13").Copy

'Photoshop starten
Set PS_exe = CreateObject("Photoshop.Application")

'Maßeinheiten in Pixel
PS_exe.Preferences.RulerUnits = psPixels

'neues Bild anlegen        Breite, Höhe, Auflösung, Dateiname
Set PS_Datei = PS_exe.Documents.Add(400, 400, 72, "per VBA")

'neue Ebene einfügen und Zwischenablage reinkopieren
Set PS_Ebene = PS_Datei.Paste

'neuer Name für Ebene
PS_Ebene.Name = ("Hugo")
'PS_Ebene.Name = (ThisWorkbook.ActiveSheet.Name)

'PS-Dokument als *.psd speichern
Set PS_Optionen = New Photoshop.PhotoshopSaveOptions
PS_Optionen.AlphaChannels = True
PS_Optionen.Annotations = True
PS_Optionen.Layers = True
PS_Optionen.SpotColors = True
PS_Datei.SaveAs ThisWorkbook.Path, Options:=PS_Optionen, asCopy:=False

Application.CutCopyMode = False   'Kopiermodus in Excel beenden
PS_exe.Quit 'PS schließen

Set PS_exe = Nothing
Set PS_Datei = Nothing
Set PS_Ebene = Nothing
Set PS_Optionen = Nothing
Exit Sub

'Fehlerbehandlung
Hell:
Set PS_exe = Nothing
Set PS_Datei = Nothing
Set PS_Ebene = Nothing
Set PS_Optionen = Nothing

MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
        & "Beschreibung: " & Err.Description _
       , vbCritical, "da ist leider ein Fehler aufgetreten"

End Sub
Download:   vba044.zip
relevante Links:

top