---

Hallo Forum,
ich habe ein Programm welches Grafikdateien in ein bestimmtes Verzeichnis unter dem Dateinamen als JPG-File schreibt. Dummerweise ohne Zähler, d.h. wenn die Datei schon vorhanden ist, wird sie überschrieben. Schön wäre es, wenn ein Zähler "_01, _02, _03 usw..." hinter den Dateinamen geschrieben würde.

Kann mir dabei Jemand helfen?

Hier der Code:

Code:

---

Sub Grafik_speichern()
'    If ThisApplication.ColorSchemes.BackgroundType = kGradientBackgroundType Then
        ThisApplication.ColorSchemes.Item("Präsentation").Activate
        ThisApplication.ColorSchemes.BackgroundType = kOneColorBackgroundType
       
    ThisApplication.GeneralOptions.Show3DIndicator = False
    Dim Dateiname As String
    Dim Var() As String
    Dim MitEndung As String
    Dateiname = ThisApplication.ActiveDocument.FullFileName
    Var = Split(Dateiname, "\")
    MitEndung = Var(UBound(Var))
    Dateiname = Left(MitEndung, Len(MitEndung) - 4)
    ThisApplication.ActiveView.SaveAsBitmap "u:\mhs\cad_grafik\" & Dateiname & ".jpg", 3000, 0
            ThisApplication.GeneralOptions.Show3DIndicator = True
   
        ThisApplication.ColorSchemes.Item("Millennium").Activate
        ThisApplication.ColorSchemes.BackgroundType = kGradientBackgroundType
    'End If
   
      If Err.Number = 0 Then
    MsgBox "Die Grafik wurde im Verzeichnis U:\MHS\CAD_Grafik gespeichert"
    Else
    MsgBox "Fehler: " & Err.Description
    End If
   
    End Sub

---

Vielen vielen Dank
Grüße
Martin

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo,

so sollte ab dem zweiten Bild die Endung " - 2" angehangen werden und bei dem dritten Bild " - 3" usw..

Code:

---

Sub Grafik_speichern()
    'If ThisApplication.ColorSchemes.BackgroundType = kGradientBackgroundType Then
    ThisApplication.ColorSchemes.Item("Präsentation").Activate
    ThisApplication.ColorSchemes.BackgroundType = kOneColorBackgroundType
    ThisApplication.GeneralOptions.Show3DIndicator = False
 
    Dim Dateiname As String
    Dim Var() As String
    Dim MitEndung As String
   
    Dateiname = ThisApplication.ActiveDocument.FullFileName
    Var = Split(Dateiname, "\")
    MitEndung = Var(UBound(Var))
    Dateiname = Left(MitEndung, Len(MitEndung) - 4)
   
    Dim i As Integer
    i = 2
   
    Dim TempDateiname As String
    TempDateiname = Dateiname

    Do Until Dir("u:\mhs\cad_grafik\" & TempDateiname & ".jpg", vbDirectory) = vbNullString
        TempDateiname = Dateiname & " - " & i
        i = i + 1
    Loop
   
    Dateiname = TempDateiname
   
    ThisApplication.ActiveView.SaveAsBitmap "u:\mhs\cad_grafik\" & Dateiname & ".jpg", 3000, 0
    ThisApplication.GeneralOptions.Show3DIndicator = True
    ThisApplication.ColorSchemes.Item("Millennium").Activate
    ThisApplication.ColorSchemes.BackgroundType = kGradientBackgroundType
    'End If
   
    If Err.Number = 0 Then
    MsgBox "Die Grafik wurde im Verzeichnis U:\MHS\CAD_Grafik gespeichert"
    Else
    MsgBox "Fehler: " & Err.Description
    End If
End Sub

---

Ist jedoch ungetestet, bei Problemen gerne nochmal melden.

------------------
Mit Besten Grüßen

Ruzy5624

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Ruzy,
danke Dir für die Hilfe - macht genau das, was es soll!
Gruß Martin

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP