VBA, Word 2007, automatisch gearchiveerd opslaan

[jackfish]

Ik heb het opslaan van een document geautomatiseerd. Dat werkt perfect. Alleen wordt het verslag wel eens gemaakt op de dag na de dienst. En dan staat de rapportage voor het secretariaat niet meer op de juiste plek.
Onderstaande code wil ik zo aanpassen dat het de ingevoerde datum (datum van de dienst) op het userform (in tekstbox) gebruikt voor het opslaan. Alleen zie ik niet hoe dat het beste te doen. Wie kan mij verder op weg helpen?

Sub Opslaan1()
    Dim answer As Integer
    Dim text1 As String
    Dim text2 As String
 
    geslacht = tekst0.Text
    achternaam = tekst1.Text
    geboren = tekst3.Text
   
    'answer = MsgBox("Is in het Klik op JA en vindt deze rapportage terug in:" & vbCrLf & vbCrLf & "M:\A-team\Registratie" & "\" & "Rapportage" & " - " & geslacht & " " & achternaam & " - " & geboren & ".docm", vbYesNo + vbQuestion, "A-teams")
   
    'If answer = vbYes Then
        'Maak zo nodig map A-team
            If Len(Dir("M:\A-team", vbDirectory)) = 0 Then
                MkDir "M:\A-team"
            End If
        ''Maak zo nodig map Registratie in M:\A-team
            If Len(Dir("M:\A-team" & "\" & "Registratie", vbDirectory)) = 0 Then
                MkDir "M:\A-team" & "\" & "Registratie"
            End If
        ''Maak zo nodig submap Jaar, in map Registratie
            If Len(Dir("M:\A-team" & "\" & "Registratie" & "\" & Year(Date), vbDirectory)) = 0 Then
                MkDir "M:\A-team" & "\" & "Registratie" & "\" & Year(Date)
            End If
        ''Maak zo nodig Submap maand, in submap Jaar, in map Registratie
            If Len(Dir("M:\A-team" & "\" & "Registratie" & "\" & Year(Date) & "\" & Month(Date), vbDirectory)) = 0 Then
                MkDir "M:\A-team" & "\" & "Registratie" & "\" & Year(Date) & "\" & Month(Date)
            End If
        ''Maak zo nodig  Submap dag, in submap maand, in submap Jaar, in map Registratie
            If Len(Dir("M:\A-team" & "\" & "Registratie" & "\" & Year(Date) & "\" & Month(Date) & "\" & Day(Date), vbDirectory)) = 0 Then
                MkDir "M:\A-team" & "\" & "Registratie" & "\" & Year(Date) & "\" & Month(Date) & "\" & Day(Date)
            End If
        ' Registratieopslaan
       
           ActiveDocument.SaveAs ("M:\A-team" & "\" & "Registratie" & "\" & Year(Date) & "\" & Month(Date) & "\" & Day(Date) & "\" & "Rapportage" & " - " & geslacht & " " & achternaam & " - " & geboren & ".docm")
    'End If

 

[OctaFish]

Ik snap je opzet niet helemaal, en volgens mij is het ook niet goed. Je declareert een aantal variabelen:

Dim text1 As String
Dim text2 As String

En die vul je dan zo:

    Geslacht = tekst0.Text
    Achternaam = tekst1.Text

Een variabele heeft geen Text eigenschap, hooguit een Value. Maar dan nog: eerst variabelen declareren en ze dan toewijzen aan een andere (niet-gedeclareerde) variable? Dan zijn ze beiden leeg. Gaat het om je tekstvakken, dan zijn de declaraties overbodig (en kun je nog steeds de Value uitlezen). Ik neem aan dat je datum ook op het formulier staat in een tekstvak. Dan krijg je zoiets:

Oh ja, ik gebruik veel liever een aparte functie om een pad te maken. Die staat er dus ook bij.
Niet getest natuurlijk, want ik heb je formulier niet .

Sub Opslaan1()
Dim answer As Integer
Dim sFile As String, sMap As String
    
    sMap = "M:\A-team" & "\" & "Registratie" & "\" & Format(Me.text3, "yyyymmdd")
    CreateFolder (sMap)
    sFile = sMap & "\" & "Rapportage" & " - " & Me.Tekst0 & " " & Me.Tekst1 & " - " & Me.Tekst2 & ".docm"
    ActiveDocument.SaveAs sFile
End Sub

Function CreateFolder(ByVal sPath As String) As Boolean
'by Patrick Honorez - www.idevlop.com
'updated 20130422 to handle UNC paths correctly ("\\MyServer\MyShare\MyFolder")

Dim fs As Object
Dim FolderArray
Dim Folder As String, i As Integer, sShare As String

    If Right(sPath, 1) = "\" Then sPath = Left(sPath, Len(sPath) - 1)
    Set fs = CreateObject("Scripting.FileSystemObject")
    'UNC pad ? Dan 3 "\" veranderen in 3 "@" tekens
    If sPath Like "\\*\*" Then
        sPath = Replace(sPath, "\", "@", 1, 3)
    End If
    FolderArray = Split(sPath, "\")
    'Na het splitsen de "@" tekens weer vervangen door "\" in item 0 van de array.
    FolderArray(0) = Replace(FolderArray(0), "@", "\", 1, 3)
    On Error GoTo Hell
    'Door alle posities in de array lopen en de mapstring controleren en/of aanmaken.
    For i = 0 To UBound(FolderArray)
        Folder = Folder & FolderArray(i) & "\"
        If Not fs.FolderExists(Folder) Then
            fs.CreateFolder (Folder)
        End If
    Next
    'Het aanmaken van de map is gelukt; CreateFolder instellen op WAAR.
    CreateFolder = True

Hell:
End Function

 

[jackfish]

Ik wil het bestandje wel laten zien maar het is 117kb groot, het forum staat bijlagen tot maar 100kb toe. alternatief?