[VBA] ActiveDocument in Word 2007

[kamerplant]

Hey,

Ik heb een probleem met een VB Macro. Deze macro werkt prima in Word 2003, maar niet in Word 2007. De macro maakt een nieuw document aan, opent dit document en activeert zichzelf hierna weer. Dit doet hij op de volgende manier:

Visual Basic:

sBrondocument = ActiveDocument.Name 'Defineer het brondocument
MsgBox ActiveDocument.Name

In de bovenstaande string slaat hij de titel op van het document. De MsgBox geeft weer: "Brief.doc".

Vervolgens wordt het nieuwe document aangemaakt en moet het oorspronkelijke document weer worden geactiveerd, dit gebeurd met de volgende regel.

Visual Basic:

Windows(sBrondocument).Activate

In Word 2003 gaat dit OK, in Word 2007 niet omdat in Word 2007 hij de naam "Brief (Compatibiliteitsmodes)" verwacht. Dit werkt dus wel, maar dat dit werkt natuurlijk niet in Word 2003.

Visual Basic:

Windows("Brief (Compatibiliteitsmodus)").Activate

Heel concreet is dus mijn vraag: Hoe haal ik de titel van het venster op zodat ik deze later weer kan gebruiken om het venster te activeren.

Alvast bedankt!

[hamburger]

Wat je volgens mij beter kan doen, is gewoon het document bewaren in een variabele:

Visual Basic:

  Dim BronDocument As Document
  
  Set BronDocument = ActiveDocument
  
  ' Nieuw document aanmaken zodat een ander document de focus krijgt
  Documents.Add

  ' Het document wat bewaard is in BronDocument weer de focus geven
  BronDocument.Activate

[kamerplant]

Helaas, dit gaat niet goed. Hij knalt eruit met de melding "Object vereist".

[Verwijderd]

post eens iets meer code, zodat de context duidelijk wordt, want de oplossing van hamburger is de goede.
het object activedocument moet natuurlijk toegewezen worden aan de objectvariabele brondocument op de moment wanneer het gewenste document actief is.
en waarom moet terug naar het oorspronkelijke document gewisseld worden? het kan namelijk zijn dat dit niet nodig is als het puur gaat om het codeverloop van de macro.

[kamerplant]

Okee. Dit is de gehele macro. Ik heb hem eventjes in stukjes opgedeeld zodat ik er iets over kan zeggen.

Visual Basic:

Public Sub Document_Open() 'Acties bij het openen van het document
    
'-------- STARTEN VAN DE MACRO ------------------------------------------------------------------------------
  
    Application.ScreenUpdating = False
    
'------ KOPPELING MAKEN MET ACTIVE DIRECTORY -----------------------------------------------------------------------------

    On Error Resume Next

   'Defineer de velden tbv Active Directory
    Dim strGivenName As String
    Dim strMiddleName As String
    Dim strLastName As String
    Dim strInitials As String
    Dim strTelephoneNumber As String
    Dim strHomePhone As String
    Dim strMobileNumber As String
    Dim strFaxNumber As String
    Dim strEmail As String

   'Maak de koppeling met Active Directory
    Set objSysInfo = CreateObject("ADSystemInfo")
    strUserDN = objSysInfo.UserName
    Set objUser = GetObject("LDAP://" & strUserDN)

   'Vul de velden vanuit Active Directory
    strGivenName = objUser.Get("givenName") 'voornaam
    strLastName = objUser.Get("sn") 'achternaam
    strMiddleName = objUser.Get("middlename") 'tussenvoegsel
    strInitials = objUser.Get("initials") 'initialen
    strTelephoneNumber = objUser.Get("telephoneNumber") 'telefoonnummer werk
    strHomePhone = objUser.Get("homePhone") 'telefoonnummer thuis
    strMobileNumber = objUser.Get("mobile") 'mobiel nummer
    strFaxNumber = objUser.Get("facsimileTelephoneNumber") 'fax nummer werk
    strEmail = objUser.Get("mail") 'emailadres
    
'------ USERFORM / invulscherm --------------------------------------------------------------------------------------------------
 
   'Open de Userform
    Load Userform1
   
   'Vul het Userform met de velden van Active Direcory
     
       'Zet puntjes tussen de initialen als er nog geen puntjes staan
        If InStr(strInitials, ".") = 0 Then   'Als er nog geen puntjes in de Initialen staan dan
        strInitials = Replace(strInitials, "A", "A.")
        strInitials = Replace(strInitials, "B", "B.")
        strInitials = Replace(strInitials, "C", "C.")
        strInitials = Replace(strInitials, "D", "D.")
        strInitials = Replace(strInitials, "E", "E.")
        strInitials = Replace(strInitials, "F", "F.")
        strInitials = Replace(strInitials, "G", "G.")
        strInitials = Replace(strInitials, "H", "H.")
        strInitials = Replace(strInitials, "I", "I.")
        strInitials = Replace(strInitials, "J", "J.")
        strInitials = Replace(strInitials, "K", "K.")
        strInitials = Replace(strInitials, "L", "L.")
        strInitials = Replace(strInitials, "M", "M.")
        strInitials = Replace(strInitials, "O", "O.")
        strInitials = Replace(strInitials, "N", "N.")
        strInitials = Replace(strInitials, "P", "P.")
        strInitials = Replace(strInitials, "Q", "Q.")
        strInitials = Replace(strInitials, "R", "R.")
        strInitials = Replace(strInitials, "S", "S.")
        strInitials = Replace(strInitials, "T", "T.")
        strInitials = Replace(strInitials, "U", "U.")
        strInitials = Replace(strInitials, "V", "V.")
        strInitials = Replace(strInitials, "W", "W.")
        strInitials = Replace(strInitials, "X", "X.")
        strInitials = Replace(strInitials, "Y", "Y.")
        strInitials = Replace(strInitials, "Z", "Z.")
        End If
  
      'Vul het Userform met de velden vanuit Active Directory
       If strMiddleName = "" Then Userform1.txtBehandeldDoor.Value = strInitials + " " + strLastName
       If strMiddleName <> "" Then Userform1.txtBehandeldDoor.Value = strInitials + " " + strMiddleName + " " + strLastName
       Userform1.txtTelefoonnummer.Value = strTelephoneNumber
       Userform1.txtNaamTekenbevoegde.Value = Userform1.txtBehandeldDoor.Value
      
      'Vul de Userform met vaste waarden
       Userform1.txt1Slotzin.Value = "Wij vertrouwen erop u voldoende te hebben geïnformeerd."
       Userform1.txt2Slotzin.Value = "Mocht u hierover vragen of opmerkingen hebben, dan kunt u contact opnemen met " + Userform1.txtBehandeldDoor.Value + ", telefoonnummer " + Userform1.txtTelefoonnummer.Value + "."
       Userform1.txt1Afsluiting.Value = "Met vriendelijke groet"
       Userform1.txt2Afsluiting.Value = "Hoogachtend"
       Userform1.txtBijlagenAantal = "0"
       Userform1.txtCc = "-"
       Userform1.txtDatumVandaag = Format(Date, "D MMMM YYYY") 'Datum vandaag (dag maand jaar)
       Userform1.txtOnzeReferentie = Format(Date, "YYYYMMDD") & " " & Format(Time, "hhmmss") 'Onze referentie (jaar maand dag uur minuut seconde)
     
   'Laat het userform zien
    Userform1.Show

   'klik op de knop "OK" bij formulieren \ userform1 \ op de code bij het userform te zien.
        
    'Windows(sBrondocument).Activate 'Activeer het brondocument zodat de macro na 'Application.OnTime' weer opgestart kan worden
    Windows("Brief (Compatibiliteitsmodus)").Activate
    Application.OnTime when:=Now + TimeValue("00:00:01"), Name:="BouwpartnerToevoegen" 'ga naar sub BouwpartnerToevoegen
    
End Sub


'------ KOPPELING MAKEN MET MAILMERGE (Bouwpartner sheet) -------------------------------------------------------------------
     
Public Sub BouwpartnerToevoegen()
    
   'Vul de velden in
    strActivePad = ActiveDocument.Path 'pad naar de Betreffende Project / standaarddoc
    sFolder = "\Algemeen" 'tbv pad naar de bouwpartnersheet
    sNewPath = CreateNewPath(strActivePad, sFolder) 'pad naar de bouwpartnersheet
    sBrondocument = ActiveDocument
    
    
   'Maak een Mailmerge met het bouwpartner bestand(Werkbalk afdruk samenvoegen)
    Dim oMM As Word.Mailmerge
    Set oMM = ActiveDocument.Mailmerge
    oMM.MainDocumentType = wdFormLetters
    oMM.OpenDataSource Name:=sNewPath & "\bouwpartners.xls", Connection:="TABLE", Format:=wdOpenFormatAuto, SQLStatement:="SELECT * FROM `bouwpartners$`"
    
        oMM.OpenDataSource Name:= _
        sNewPath & "\bouwpartners.xls", ConfirmConversions:=False, _
        ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
        PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
        WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, _
        Connection:= _
        "Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User ID=Admin;Data Source=sNewpath\Bouwpartners.xls;Mode=Read;Extended Properties=""HDR=YES;IMEX=1;"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:Database Password="""";Jet OLEDB:" _
        , SQLStatement:="SELECT * FROM `Bouwpartners$`", SQLStatement1:="", _
        SubType:=wdMergeSubTypeAccess
    
   'Geef een melding aan de gebruiker dat hij meerdere bouwpartners kan selecteren
    MsgBox ("Uw kunt 1 of meerdere bouwpartners selecteren. Wanneer u meerdere bouwpartners selecteert, dan zullen er meerdere documenten worden aangemaakt.")
     
   'Open het venster met geadresseerden
    Application.Dialogs(wdDialogMailMergeRecipients).Show (1)
    ActiveDocument.Mailmerge.DataSource.SetAllIncludedFlags (False)
    Application.Dialogs(wdDialogMailMergeRecipients).Show
    
    Application.ScreenUpdating = False
    

'------ MAAK HET PRINT DOCUMENT / DOCUMENT MET ALLE BRIEVEN ONDER ELKAAR -----------------------------------------------------------------------------
       
   'Zet de gekozen bouwpartners als 1 pagina per record in 1 document
    With ActiveDocument.Mailmerge
       .Destination = wdSendToNewDocument
       .SuppressBlankLines = True
       
        With .DataSource
            .FirstRecord = wdDefaultFirstRecord
            .LastRecord = wdDefaultLastRecord
        End With
        
       .Execute Pause:=True
    End With
    
    Selection.WholeStory                'selecteer alles
    Selection.Font.Name = "Univers"     'maakt opmaak univers
    
    'Maak opmaak volgens 2003
    ActiveDocument.ApplyQuickStyleSet ("Word 2003")
    
   'Bepaal de documentinstellingen (LET OP - DIT IS BIJ ELK SJABLOON ANDERS)
    With ActiveDocument.Styles(wdStyleNormal).Font
         If .NameFarEast = .NameAscii Then
            .NameAscii = ""
         End If
               .NameFarEast = ""
    End With
       
   'Bepaal de printersintellingen
    With ActiveDocument.PageSetup
         .FirstPageTray = wdPrinterMiddleBin 'tray 2
         .OtherPagesTray = wdPrinterLowerBin 'tray 3
    End With
           
   'Verander het te openen pad naar "standaard_doc" zodat deze daar opgeslagen kan worden
    ChangeFileOpenDirectory strActivePad
    
   'Sla het bestand met per pagina een record op als Printen.doc op    betreffende project / standaarddoc
    ActiveDocument.SaveAs FileName:="Printen.doc", FileFormat:=wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:=False
        
   'Sluit het Printen document tbv de paginatelling
    ActiveDocument.Close savechanges:=wdDoNotSaveChanges
      
   'Open het Printen document
    Documents.Open FileName:=strActivePad & "\Printen.doc", ReadOnly:=False 'met alleen lezen beperking
    
    
    
    Application.ScreenUpdating = True
    
    

Hieronder wordt het document geactiveerd. Je ziet de orginele regel (is nu disabled) en daaronder de regel die nu alleen in Word 2007 werkt omdat hier hard het woord Compatibiliteitsmodus in staat.

Het lijkt raar, dat eerst het document wordt opgehaald en dan gedefinieerd. Maar dat heeft met de opbouw van de macro te maken. Natuurlijk voert hij eerst de code uit die de de string definieerd en daarna activeerd hij hem pas.

' Windows(sBrondocument).Activate 'Activeer het bronbestand om zometeen de ontime te kunnen activeren
Windows("Brief (Compatibiliteitsmodus)").Activate

code:

'------ CCONTROLEER HET AANTAL BOUWPARTNERS ------------------------------------------------------------------------
   
   'Defineer de velden
    Dim Aantal As String
    Dim Max As Integer
        
   'vul de velden
    Aantal = ActiveDocument.Sections.Count - 1 'kijk hoeveel sectie's het actieve document bevat. (dit -1 is het aantal bouwpartners dat geselecteerd is)
    Max = "4" 'boven dit aantal wordt een melding gegeven
    
   'Controleer of het aantal bouwpartners boven Max uitkomt en zo ja geef dan een melding
    If Aantal > Max Then 'Als Aantal groter is dan Max
    c = MsgBox("U heeft " & Aantal & " bouwpartners geselecteerd, er zullen dus " & Aantal & " documenten aangemaakt worden. Weet u zeker dat u wilt doorgaan?" & vbCr & vbCr & "(U krijgt deze melding bij het selecteren van " & Max + 1 & " of meer bouwpartners om te voorkomen dat u ongewild een groot aantal documenten aanmaakt)", vbYesNo + vbDefaultButton2)
        If c = vbNo Then 'wilt u doorgaan --- NEE
        ActiveDocument.Close savechanges:=wdDoNotSaveChanges 'Sluit het PRINT document
        Windows(sBrondocument).Activate 'Activeer het brondocument
        MsgBox ("Selecteer alleen de gewenste bouwpartners") 'Geef een melding
        Application.OnTime when:=Now + TimeValue("00:00:01"), Name:="BouwpartnerToevoegen" 'Ga terug naar naar bouwpartner toevoegen
        End If
        If c = vbYes Then  'wilt u doorgaan --- JA
        Windows(sBrondocument).Activate 'Activeer het bronbestand om zometeen de ontime te kunnen activeren
        Application.OnTime when:=Now + TimeValue("00:00:01"), Name:="DocumentCreatie"  'Geef het document Printen de tijd om gemaakt te worden en zorgt dat de macro weer verder gaat
        End If
    Else: 'Als Aantal niet groter is dan Max
    
   ' Windows(sBrondocument).Activate 'Activeer het bronbestand om zometeen de ontime te kunnen activeren
    Windows("Brief (Compatibiliteitsmodus)").Activate
    Application.OnTime when:=Now + TimeValue("00:00:01"), Name:="DocumentCreatie"  'Geef het document Printen de tijd om gemaakt te worden en zorgt dat de macro weer verder gaat
    
    End If
   
End Sub

Hieronder wordt het huidige document (brief.doc) gedefinieerd. Hier:
sBrondocument = ActiveDocument 'Defineer het brondocument

code:

'------ MAAK DE DIVERSE DOCUMENTEN AAN ------------------------------------------------------------------------

Public Sub DocumentCreatie() 'tbv het aanmaken van de documenten per record
    
    Application.ScreenUpdating = False
        
   'Vul de velden
    strActivePad = ActiveDocument.Path 'Pad van Brondocument
    sFolder2 = "\Communicatie\Correspondentie_uit" 'Waar de documenten moeten worden opgeslagen
    sNewPath2 = CreateNewPath2(strActivePad, sFolder2) 'Waar de documenten moeten worden opgeslagen
    sBrondocument = ActiveDocument 'Defineer het brondocument
          
   'Open het bestand Printen uit de map "standaard_doc"
    Documents.Open FileName:=strActivePad & "\Printen.doc", ReadOnly:=False 'alleen lezen
    Aantal = ActiveDocument.Sections.Count - 1 'kijk hoeveel sectie's het actieve document bevat
    Set PrintenDoc = ActiveDocument
   
   'Verander de padnaam naar waar je de documenten wil opslaan
    ChangeFileOpenDirectory sNewPath2
     
   'Maak van het bestand Printen ipv 1 pagina per record -> 1 document per record
        Application.Browser.Target = wdBrowseSection 'Kijk naar de sectie's in het Prntdocument
        For i = 1 To ((ActiveDocument.Sections.Count) - 1) 'Controleer hoeveel secties er zijn
        PrintenDoc.Bookmarks("\Section").Range.Copy 'Kopieer de sectie
        Documents.Add 'open een nieuw document
        Selection.Paste 'Plak de sectie
  
       'Verwijderd het sectie-einde
        Selection.TypeBackspace
        Selection.Delete Unit:=wdCharacter, Count:=1
   
       'Zet de cursus bovenin
        Selection.MoveUp Unit:=wdScreen, Count:=15
                        
       'Stel de Unica standaard in
        Selection.WholeStory                'selecteer alles
        Selection.Font.Name = "Univers"     'maakt opmaak univers
        Selection.Font.Size = 11            'maakt lettertype 11
        Selection.MoveUp Unit:=wdScreen, Count:=3 'Zorg dat je bovenaan de pagina staat
         
       'Stel het volgnummer in
        DocNum = DocNum + 1
       
       '------ LET OP VOOR ELK SJABLOON ANDERS ------ Bepaal de documentinstellingen van het nieuw gemaakte document
        With ActiveDocument.Styles(wdStyleNormal).Font
           If .NameFarEast = .NameAscii Then
              .NameAscii = ""
           End If
           .NameFarEast = ""
        End With
        
        With ActiveDocument.PageSetup
           .LineNumbering.Active = False
           .Orientation = wdOrientPortrait
           .TopMargin = 137
           .BottomMargin = 56.7
           .LeftMargin = 73.7
           .RightMargin = 150
           .Gutter = 0
           .HeaderDistance = 0
           .FooterDistance = 56.7
           .PageWidth = 595.3
           .PageHeight = 841.9
           .FirstPageTray = wdPrinterMiddleBin
           .OtherPagesTray = wdPrinterLowerBin
           .SectionStart = wdSectionNewPage
           .OddAndEvenPagesHeaderFooter = False
           .DifferentFirstPageHeaderFooter = True
           .VerticalAlignment = wdAlignVerticalTop
           .SuppressEndnotes = False
           .MirrorMargins = False
           .TwoPagesOnOne = False
           .BookFoldPrinting = False
           .BookFoldRevPrinting = False
           .BookFoldPrintingSheets = 1
           .GutterPos = wdGutterPosLeft
        End With
        
                    'Maak opmaak volgens 2003
    ActiveDocument.ApplyQuickStyleSet ("Word 2003")
       
       
       'Bepaal de voor te stellen bestandsnaam (onzeReferentie komt uit de Userform / aantal = aantal secties
        With Dialogs(wdDialogFileSummaryInfo)
             .Title = Userform1.txtOnzeReferentie.Value & " " & DocNum & " van " & Aantal 'Onzereferentie (uit de userform) + Documentnummer + Totaal aantal gemaakte documenten
             .Execute
        End With
      
      'Doe hetzelfde bij de volgende sectie
       Documents.Open FileName:=strActivePad & "\Printen.doc", ReadOnly:=True 'Hierdoor wordt Printen weer geactiveerd.
       Application.Browser.Next
     
   Next i 'Hierna zijn alle documenten aangemaakt
       
   
  'Kijk of de optie PRINTDOCUMENT in de Userform is aangevinkt. Zo nee sluit het printdocument dan af
   If Userform1.ckbPrint = False Then ActiveDocument.Close savechanges:=wdDoNotSaveChanges 'Hiermee wordt Printen afgesloten
    
  'Sluit het brondocument
   Windows("Brief (Compatibiliteitsmodus)").Close savechanges:=wdDoNotSaveChanges
   'Windows(sBrondocument).Close savechanges:=wdDoNotSaveChanges
   
Application.ScreenUpdating = True


End Sub




Public Sub BestandOpslaan()
    Dim Bestandsnaam As String
    Dim dlgOpslaan As Dialog

    Bestandsnaam = Format(Date, "YYDDMM") & " " & Format(Time, "hhmmss")

        Set dlgOpslaan = Dialogs(wdDialogFileSaveAs)
        With dlgOpslaan
            .Name = Bestandsnaam
            .Show
        End With
          
End Sub

Private Function CreateNewPath(sBase, sTarget) As String
    CreateNewPath = _
      Left(sBase, InStrRev(sBase, "\", -1, vbTextCompare) - 1) & sTarget
End Function

Private Function CreateNewPath2(sBase, sTarget) As String
    CreateNewPath2 = _
      Left(sBase, InStrRev(sBase, "\", -1, vbTextCompare) - 1) & sTarget
End Function

[Kappie]

Probeer het volgende eens:

Visual Basic:

sBrondocument = ActiveWindow.Caption
Windows(sBrondocument).Activate

[kamerplant]

Toppie Kappie! It works

Case closed Tnx people.

[Kappie]

You're welcome

Als is de oplossing van Hamburger wel netter

[Lustucru]

Yup. Die van jou is ronduit ranzig net als het niet declareren van variabelen
Dat die van Hamburger niet werkt bij de TS is een kwestie van slecht overtikken: bij het toewijzen van objectvariabelen is het gebruik van 'set' verplicht in VBA:

Visual Basic:

dim doc as Document
set doc=ActiveDocument

[Verwijderd]

^^
tsja, ik had gehoopt (en hoop nog steeds) dat-ie zelf zo ver zou geraken.
even het kleinschrift van Lustucru aanvullen met toch nog een ultrakorte tip :

Visual Basic:

option explicit

[kamerplant]

Ah, oke . Top .