Jpg. aus Excel automatisch speichern

Hallo,
Frage:
ist es möglich beim Speichern eines Excel Blattes das Foto das da drin ist, automatisch extra als jpg. zu speichern?
Hintergrund: für die Dokumentation des Bestandes wird für alle Güter ein Datenblatt angelegt mit div. Infos plus ein Foto (das machen viele verschiedene MA).
Das Datenblatt wird mit einer laufenden Nummer (zb. 80000) angelegt und auch automatisch mit dieser gespeichert.
Da die Fotos für eine Bilddatenbank benötigt werden, müssen wir aktuell immer alle Fotos extra nochmal speichern (zb. 80000_Foto).
Daher die Frage ob es möglich wäre es beim speichern des Blattes einfach über Makro mitzumachen.
ich hoffe ich hab mich verständlich ausgedrückt :)
lg Bianca

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Michael,
ok es läuft so:
Mitarbeiter füllt ein Datenblatt aus, fügt div. Daten und 1 Foto ein (immer nur ein Foto).
Dann wird über Makro dieser Speicherbefehl ausgelöst. Der macht eigentlich nur Datenblatt kopieren und mit Nummer aus Zelle AS5 abspeichern. Dann geht das Makro wieder in die Startdatei...Fertig.
Was ich mir nun wünschen würde ist eben das er auch das Foto extra als jpg. speichert (im gleichen Ordner wie das Datenblatt).
ist es jetzt verständlicher?
lg Bianca
Private Declare Function SetCurrentDirectoryA Lib "kernel32" (ByVal lpPathName As String) As Long

Private Sub SetUNCPath(sPath As String)
Dim lReturn As Long
lReturn = SetCurrentDirectoryA(sPath)
If lReturn = 0 Then _
MsgBox "Error setting path"
End Sub

'Bianca 2016
Sub Speichern()
Sheets("ANLBLATT").Select
Sheets("ANLBLATT").Copy
On Error GoTo Fehler
Call SetUNCPath("\\server\xx\Allgemein\3_Inventar_xx\ZVAM xx") 'Umgehen von Laufwerkbuchstaben
ActiveWorkbook.SaveAs Range("AS5").Value & ".xlsx"
ActiveWindow.Close
'geht zurück auf Grunddaten im Original
Sheets("1").Select
Exit Sub
Fehler:
ActiveWorkbook.Close SaveChanges:=False
MsgBox "Datei wurde nicht gespeichert"
Sheets("1").Select
End Sub

Sub Speichern() Dim Wb As Workbook, Ws As Worksheet Dim s As Shape, dia As ChartObject Sheets("ANLBLATT").Select Sheets("ANLBLATT").Copy On Error GoTo Fehler Call SetUNCPath("\\server\xx\Allgemein\3_Inventar_xx\ZVAM xx") 'Umgehen von _ Laufwerkbuchstaben ActiveWorkbook.SaveAs Range("AS5").Value & ".xlsx" Set Wb = ActiveWorkbook Set Ws = Wb.ActiveSheet Set s = Ws.Shapes(1) Set dia = Ws.ChartObjects.Add(s.Left, s.Top, s.Width, s.Height) s.CopyPicture With dia .Activate .Chart.Paste .Chart.Export Wb.Path & "\" & Left(Wb.Name, Len(Wb.Name) - 5), "jpg" .Delete End With ActiveWindow.Close 'geht zurück auf Grunddaten im Original Sheets("1").Select Exit Sub Fehler: ActiveWorkbook.Close SaveChanges:=False MsgBox "Datei wurde nicht gespeichert" Sheets("1").Select End Sub

Beliebteste Forumthreads (12 Monate)

Jpg. aus Excel automatisch speichern

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread