---

Hallo Zusammen,

hab mir ein Makro gebastelt, dass bei Knopfdruck ein Ordner (DWG) erstellt und anschliessend die Zeichnung im DWG format in den Ordner DWG abspeichert. Leider bekomme ich die Fehlermeldung ("Fehler beim Schreiben der Datei"). Kann mir jemand helfen den fehler auszumärzen?
Hier noch der Code:

Code:

---

Public Sub DWG()
    On Error Resume Next
    If ThisApplication.ActiveDocument.DocumentType <> kDrawingDocumentObject Then
        Exit Sub
    End If
 
  Dim Pfad As String
    Pfad = CurDir & "\"

    If Dir(Pfad & "DWG", vbDirectory) = "DWG" Then
        'MsgBox "Ordner ''DWG'' ist vorhanden!"
        GoTo Sprung
    Else
        MkDir "DWG"
        'MsgBox "Ordner ''DWG'' wurde in folgendem Pfad angelegt:  " & Pfad
    End If

Sprung:
 
    Dim oDoc As Inventor.DrawingDocument
    Set oDoc = ThisApplication.ActiveDocument
    Dim oFileName As String
    oFileName = oDoc.FullDocumentName
   
    Dim oArray() As String
    oArray = Split(oFileName, "\")
 
    If oDoc.FullFileName = "" Then
        MsgBox "Bitte zuerst die Zeichnung speichern...  "
        Exit Sub
    End If
 
    Dim sName As String
    Dim i As Integer
    sName = oArray(LBound(oArray))
    For i = 1 To UBound(oArray) - 1
    sName = sName & "\" & oArray(i)

Next
    sName = sName & "\DWG\" & (oArray(UBound(oArray)))
   
    oDoc.SaveAs Replace(sName, Right(sName, 3), "DWG"), True
   
    If Err.Number = 0 Then
        MsgBox "Die Datei:" & vbCrLf & vbCrLf & Replace(sName, Right(sName, 3), "DWG") & vbCrLf & vbCrLf & "wurde erfolgreich gespeichert"
        FileSystemObject.CopyFile "oDoc.FullFileName", Pfad & "DWG"
    Else
        MsgBox "Fehler: " & Err.Description
    End If
   
End Sub

---

Gruss Xaigon

------------------
Greets

Xaigon

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

---

Hi

Das hier wird immer True zurückgeben, egal ob das Verzeichnis existiert oder nicht. Daher kommt auch deine Fehlermeldung, wenn du in ein nicht vorhandenes Verzeichnis speichern willst.

Code:

---

If Dir(Pfad & "DWG", vbDirectory) = "DWG" Then

---

Bei meinem Test war CurDir übrigens C:\Windows\System32. Ich denke auch das ist nicht die beabsichtigte Funktionsweise.

------------------
MfG
Ralf

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

---

Hallo Ralf,

ich hab das Makro ja so ausgelegt das es ein Unterordner erstellen muss, wenn es noch keinen gibt. Muss ich deiner Meinung nach diesen code

Code:

---

oDoc.SaveAs Replace(sName, Right(sName, 3), "DWG"), True

---

in diesen Umwandeln:

Code:

---

If Dir(Pfad & "DWG", vbDirectory) = "DWG" Then
  oDoc.SaveAs Replace(sName, Right(sName, 3), "DWG"), True

---

------------------
Greets

Xaigon

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

---

Hallo

Hier eine Version die funktioniert. Wozu eigentlich das CopyFile am Ende?

Code:

---

Public Sub DWG()
    On Error Resume Next
    If ThisApplication.ActiveDocument.DocumentType <> kDrawingDocumentObject Then
        Exit Sub
    End If

    Dim oDoc As Inventor.DrawingDocument
    Set oDoc = ThisApplication.ActiveDocument
    Dim oFileName As String
    oFileName = oDoc.FullDocumentName
 
    Dim oArray() As String
    oArray = Split(oFileName, "\")

    If oDoc.FullFileName = "" Then
        MsgBox "Bitte zuerst die Zeichnung speichern...  "
        Exit Sub
    End If

    Dim sName As String
    Dim i As Integer
    sName = oArray(LBound(oArray))
    For i = 1 To UBound(oArray) - 1
    sName = sName & "\" & oArray(i)

Next
   
    If Dir(sName, vbDirectory) <> "DWG" Then
        MkDir sName & "\DWG"
        'MsgBox "Ordner ''DWG'' wurde in folgendem Pfad angelegt:  " & Pfad
    End If
   
   
    sName = sName & "\DWG\" & (oArray(UBound(oArray)))
 
    oDoc.SaveAs Replace(sName, Right(sName, 3), "DWG"), True
 
    If Err.Number = 0 Then
        MsgBox "Die Datei:" & vbCrLf & vbCrLf & Replace(sName, Right(sName, 3), "DWG") & vbCrLf & vbCrLf & "wurde erfolgreich gespeichert"
        FileSystemObject.CopyFile "oDoc.FullFileName", Pfad & "DWG"
    Else
        MsgBox "Fehler: " & Err.Description
    End If
 
End Sub

---

------------------
MfG
Ralf

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