Document opslaan via macro op basis van gegevens in koptekst

Status
Niet open voor verdere reacties.
R

rob83

Gebruiker
Lid geworden
18 jan 2016
Berichten
7
Ik heb een word-document dat ik via een macro wil laten opslaan, waarbij de naam wordt gevormd door en tekst in de koptekst.
Het document wordt gegenereerd vanuit een databaseprogramma en moet met een bepaalde bestandsnaam (=projectnummer) in een bepaalde map worden opgeslagen.

Zie voorbeeld, de tekst in de koptekst is "AB1234". Dit bestand moet de naam krijgen "AB1234_2019" en moet in de map "N/Projecten/Uitvoering" komen te staan.
In excel is het me laatst al gelukt om documenten op te slaan op basis van een waarde in een bepaalde cel, maar dit moet (lijkt me) ook kunnen vanuit de koptekst van Word?

Deze code had ik in excel, maar ik zoek nu dus de Word-versie voor opslaan met de naam zoals de waarde van de koptekst.
Code: 
Sub SlaOp()

Dim strFileName As String

strFileName = Range("B4").Value

    ActiveWorkbook.SaveAs Filename:="N:\Projecten\Begroting\" & strFileName & "_2019" & ".xlsx", _
    FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

End Sub

Als het vanuit de koptekst niet mogelijk is, zou het ook mogen dat het wordt opgeslagen op basis van de 1e regel in het document zelf; ik kan de parameters van het exportdocument zo aanpassen dat het projectnummer om het even waar in het document wordt gezet bij genereren.

Vervolgens (vraag 2) zou ik graag zien dat de koptekst (AB1234) wordt gewist met een apart macro. Als ik dat doe via Macro Opnemen komt er het volgende uit, maar het lijkt me dat daar veel overbodige ballast in zit (en je moet het aantal karakters dat je wilt wissen ingeven); is er een betere macro om de koptekst te wissen, liefst ongeacht wat erin staat?

Code: 
Sub WisKoptekst()
    If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
        ActiveWindow.Panes(2).Close
    End If
    If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
        ActivePane.View.Type = wdOutlineView Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.Delete Unit:=wdCharacter, Count:=6
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

ALvast bedankt voor het meedenken!

Rob
 

Bijlagen

  • testbestand.docx
    19,7 KB · Weergaven: 53
Laatst bewerkt:
Ik denk dat je hier wel een eind mee komt:
Code: 
Sub mcrOpslaanEnWissen()
Dim sFN As String
Dim rng As Range
Dim aDoc As Document
    Set aDoc = ActiveDocument
    With ActiveWindow.ActivePane.View
        .SeekView = wdSeekCurrentPageHeader
        sFN = aDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text & "_" & Year(Date)
        sFN = aDoc.Path & "\" & sFN & ".docx"
        With Selection
            .WholeStory
            .Delete Unit:=wdCharacter, Count:=1
        End With
        .SeekView = wdSeekMainDocument
    End With
    aDoc.SaveAs2 FileName:=sFN, FileFormat:=wdFormatXMLDocument, CompatibilityMode:=15
    
End Sub
 
Bedankt voor de snelle reactie!

Ik krijg echter een foutmelding:
Fout 5487 tijdens uitvoering: Word kan het opslaan niet voltooien vanwege en fout met de machtiging voor het bestand.
Als locatie wordt de map getoond waarin het document nu is opgeslagen.
Als ik dan naar de foutopsporing ga, wordt de gehele onderste regel geel gemarkeerd.
Ook als ik aDoc.Path vervang door een willekeurige locatie (o.a. getest met "D:\Documenten\Rob", maar ook met andere locaties) krijg ik deze fout.

Als ik vervolgens de eerder genoemde excel-variant in die map laat opslaan kan dit gewoon, dus ik heb daarin gewoon schrijfrechten vanuit een macro.


Daarna heb ik e.e.a. een beetje herschreven in de stijl van het slaOp macro voor excel, zie onderstaand, en dan krijg ik de fout Compileerfout: Kan het bovenstaande argument niet vinden en dan wordt CompatibilityMode:= blauw geselecteerd.
Laat ik deze weg, dan komt de eerste fout weer naar voren.

Code: 
Sub mcrOpslaanEnWissen2()
Dim sFN As String
Dim rng As Range
Dim aDoc As Document
    Set aDoc = ActiveDocument
    With ActiveWindow.ActivePane.View
        .SeekView = wdSeekCurrentPageHeader
        sFN = aDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text
            With Selection
            .WholeStory
            .Delete Unit:=wdCharacter, Count:=1
        End With
        .SeekView = wdSeekMainDocument
    End With
    aDoc.SaveAs FileName:="D:\Documenten\Rob\" & sFN & "_2019" & ".docx", FileFormat:=wdFormatXMLDocument, CompatibilityMode:=15
    
End Sub
 
Ik ben nog wat verder gaan zoeken en heb nu een code gevonden waarbij ik een invulveld krijg om (een deel van) de bestandsnaam in te vullen.
Na invullen komt er een melding dat het ok is en wordt het document afgesloten.
Deze macro heb ik toegewezen aan een knop in de werkbalk snelle toegang en dit werkt redelijk, maar heeft er iemand nog een idee of dit ook zo aangepast kan worden dat de info van de bestandsnaam uit de koptekst of eerste regel van het document gehaald wordt? Want nu moet ik alsnog steeds zelf het projectnummer invoeren (150+ stuks per jaar).
Bij de eerder gegeven code krijg ik namelijk nog steeds foutmeldingen.

Code: 
Sub OpslaanTextbox()

Dim Map As String
Dim Bestandsnaam As String
Dim Extentie As String
    
    Map = "N:\Projecten\Begroting\"                 'Vul hier tussen de aanhalingstekens de opslagmap in
    Bestandsnaam = InputBox("Typ de bestandsnaam", "Bestandsnaam invullen")
    Extentie = ".docx"                          'Vul hier tussen de aanhalingstekens de extentie in
    If Not Bestandsnaam = "" Then
        ActiveDocument.SaveAs FileName:=Map & Bestandsnaam & "_2020_def" & Extentie
        MsgBox "Uw document is met succes opgeslagen.", vbInformation, "Opslaan"
    End If
    ActiveDocument.Close
    Application.Quit

End Sub

Groet, Rob
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan