Hallo barbara,
ich bin nun nicht dr Wordfachmann. Ich lasse meine Probleme in dem von mir geposteteten Forum lösen. die Codeteile die ich hier poste wurden dort erstellt. Ich hoffe mal Dein Wissen in Word VBA ist besser als Excel VBA.
Folgende Ansätze
die Rechnungsnummer mußt Du über eine Textmarke mache, so jedenfalls meine Erfahrung. Die kann man leicht wieder auslesen. Mit folgenden Code werden alle Textmarken ausgelesen und Textboxen mit dem gleichen namen zugeordnet. Das bekommt man bestimmt umgestellt, das es Variablen zugeordnet wird.
For Each MyContr In Me.Controls ' TextBox-Elemente herausfiltern
On Error Resume Next
If TypeOf MyContr Is MSForms.TextBox Then
Me.Controls(MyContr.Name).Text = ActiveDocument.Bookmarks(MyContr.Name).Range.Text
End If
Next
für das abspeichern hat Christian mir mal folgenden Code erstellt, was nartürlich nur ein Teil des Gesamtcode ist.
in einem Modul
' Prüfen ob Netzwerkzugriff
If Dir("\\Ntserver2\vertrieb\ANGEBOTE\Angebote ab 2003\") <> "" Then
Select Case UCase(Left(StOrt, 1))
Case "A", "B"
StPfad = "\\Ntserver2\vertrieb\ANGEBOTE\Angebote ab 2003\A - B\"
Case "C", "D"
StPfad = "\\Ntserver2\vertrieb\ANGEBOTE\Angebote ab 2003\C - D\"
Case "E", "F"
StPfad = "\\Ntserver2\vertrieb\ANGEBOTE\Angebote ab 2003\E - F\"
Case "G", "H"
StPfad = "\\Ntserver2\vertrieb\ANGEBOTE\Angebote ab 2003\G - H\"
Case "I", "J"
StPfad = "\\Ntserver2\vertrieb\ANGEBOTE\Angebote ab 2003\I - J\"
Case "K", "L"
StPfad = "\\Ntserver2\vertrieb\ANGEBOTE\Angebote ab 2003\K - L\"
Case "M", "N"
StPfad = "\\Ntserver2\vertrieb\ANGEBOTE\Angebote ab 2003\M - N\"
Case "O", "P"
StPfad = "\\Ntserver2\vertrieb\ANGEBOTE\Angebote ab 2003\O - P\"
Case "Q", "R", "S"
StPfad = "\\Ntserver2\vertrieb\ANGEBOTE\Angebote ab 2003\Q - R - S\"
Case "T", "U"
StPfad = "\\Ntserver2\vertrieb\ANGEBOTE\Angebote ab 2003\T - U\"
Case "V", "W"
StPfad = "\\Ntserver2\vertrieb\ANGEBOTE\Angebote ab 2003\V - W\"
Case "X", "Y", "Z"
StPfad = "\\Ntserver2\vertrieb\ANGEBOTE\Angebote ab 2003\X - Y - Z\"
Case Else
' verzeichnis auswählen
StPfad = GetDirectory(StPfad)
GoTo Fehler1
End Select
StPfad2 = StPfad
' erster Durchlauf feststellen des Ablage Phades und Nachfrage
' feststellen ob der Ort vorhanden ist
StUnterpfad = Dir(StPfad & StOrt & "*", vbDirectory)
If StUnterpfad <> "" Then
StPfad = StPfad & StUnterpfad & "\" ' vorhandener Ordner
Else
StPfad = StPfad & StOrt & "\" ' neuer Ordner
End If
' Angebotsnummer überprüfen
StUnterpfad = Dir(StPfad & StAngebotsnummer & "*", vbDirectory)
If StUnterpfad <> "" Then
StPfad = StPfad & StUnterpfad ' Vorhandener Ordner
Else
StPfad = StPfad & StAngebotsnummer & " " & StKunde1
End If
' Abfrage wegen Speicherort
FRM_Speichern.Lbl_Meldung.Caption = "Wollen Sie das Angebot hier " & Chr(13) & Chr(13) & _
StPfad & Chr(13) & "\Angebot_Text\" & StDateiname & ".DOC" & Chr(13) & Chr(13) & " speichern?"
FRM_Speichern.Lbl_Meldung.Tag = "1"
FRM_Speichern.Show 'Abfrage Ordner anlegen
StPfad = StPfad & "\Angebot_Text\"
Folgender Code ist in de Userform FRM_Speichern mit zwei CommandButton. Es wird geprüft ob der Odner vorhanden ist und falls nicht wird er angelegt und ein Musterordner einschl. Struktur kopiert und benannt.
Option Explicit
Option Compare Text
' von Christian MS-Office Forum
' für anlegen Ordner
' API FileCopy
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" _
(ByVal lpExistingFileName As String, ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" _
(ByVal dwFlags As Long, lpSource As Any, _
ByVal dwMessageId As Long, ByVal dwLanguageId As Long, _
ByVal lpBuffer As String, ByVal nSize As Long, _
Arguments As Long) As Long
Private Sub Cmd_Ja_Click()
If Lbl_Meldung.Tag = "1" Then
' Ordner zurücksetzen und erneute Prüfung und anlegen
StPfad = StPfad2
' Prüfen ob Ort vorhanden
StUnterpfad = Dir(StPfad & StOrt & "*", vbDirectory)
If StUnterpfad <> "" Then
StPfad = StPfad & StUnterpfad & "\" ' Ort vorhanden
Else
' von Christian MS-Office Forum
fkt_MakeFolder StPfad & StOrt
StPfad = StPfad & StOrt & "\"
End If
' Angebotsnummer überprüfen
StUnterpfad = Dir(StPfad & StAngebotsnummer & "*", vbDirectory)
If StUnterpfad <> "" Then
StPfad = StPfad & StUnterpfad & "\Angebot_Text\" ' vorhandener Ordner
Else
' von Christian MS-Office Forum
fkt_MakeFolder StPfad & StAngebotsnummer & " " & StKunde1
' Zielordner
StPfad = StPfad & StAngebotsnummer & " " & StKunde1 ' neu: kein & "\"
' Quellordner mit Unterordner und Dateien
StPfad2 = "\\Ntserver2\vertrieb\ANGEBOTE\Angebote ab 2003\05-30xxx Kunde"
' neu: Kopieren mittels FSO
' von Christian MS-Office Forum
Dim oFS As Object, ret As Variant
Set oFS = CreateObject("Scripting.FileSystemObject")
ret = oFS.CopyFolder(StPfad2, StPfad)
Set oFS = Nothing
StPfad = StPfad & "\Angebot_Text\"
End If
ActiveDocument.SaveAs (StPfad & StDateiname & ".doc")
Lbl_Meldung.Tag = ""
ElseIf Lbl_Meldung.Tag = "2" Then
ActiveDocument.SaveAs (StPfad & StDateiname & ".doc")
Lbl_Meldung.Tag = ""
End If
Me.Hide
End Sub
Private Sub Cmd_Nein_Click()
If Lbl_Meldung.Tag = "1" Then
' Neuen Ordner wählen
StPfad = GetDirectory(StPfad)
Lbl_Meldung.Tag = ""
If StPfad <> "" Then ActiveDocument.SaveAs (StPfad & "\" & StDateiname)
ElseIf Lbl_Meldung.Tag = "2" Then
With Dialogs(wdDialogFileSaveAs)
.Name = StDateiname
.Show
End With
Lbl_Meldung.Tag = ""
End If
Me.Hide
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
' Damit mit X nicht geschloßen werden kann
If CloseMode = 0 Then
MsgBox "Bitte schließen Sie die Anwendung mit der -Ende- Schaltfläche.", vbCritical
Cancel = 1
End If
End Sub
Function fkt_MakeFolder(ByVal sPath As String) As Boolean
' erstellen eines Ordner
' von Christian MS-Office Forum
' dieser Code läuft
Dim Msg As String
If Dir(sPath, vbDirectory) = "" Then
MkDir (sPath)
If Err.Number > 0 Then
Msg = "Es ist ein Fehler beim Erstellen des Ordners aufgetreten!" & vbCrLf & sPath
MsgBox Msg & vbCrLf & Err.Description, vbCritical, "Ordner erstellen"
Err.Clear
fkt_MakeFolder = False
Exit Function
End If
End If
fkt_MakeFolder = True
On Error GoTo 0
End Function
Function fkt_FileCopy(strSource As String, strTarget As String) As String
' Kopieren eines Ordner
' von Christian MS-Office Forum
' dieser Code läuft nicht
Dim Buffer As String
Dim ret As Long
Buffer = String(200, Chr(0))
' Copy the selected file to our new directory
ret = CopyFile(strSource, strTarget, 0)
If ret = 0 Then
FormatMessage &H1000, ByVal 0&, GetLastError, &H0, Buffer, 200, ByVal 0&
fkt_FileCopy = Left(Buffer, InStr(1, Buffer, Chr(0)))
Else
fkt_FileCopy = "Kopieren erfolgreich"
End If
End Function
Das war mal jetzt ein wenig viel Code aber vieleicht findest Du Ansätze. Aber Fragen zu dem Code kann ich nur im geringen Umfang beantworten da ja Word.
Gruß Hajo
Das Forum lebt auch von den Rückmeldungen.