Dialoogvenster voor kop- en voettekst in Excel 2003

[Marie01]

Wij hebben in Excel 2003 nieuwe layout (kop- en voetteksten en marges) voor onze Excel documenten gekregen.
Nu moeten we ongeveer driehonderd bestaande bestanden aanpassen. Het zou me nog wel lukken om met de macrorecorder een macro op te nemen maar handiger zou zijn dit met een dialoogvenster te doen. Want er moet in de kop- en voettekst namelijk een lijn-plaatje ingevoegd worden.
Het hangt dan af of het blad A4 staand, A4 liggend, A3 staand of A3 liggend is welke lijn dat moet worden.
Voor elk van die keuzes is er een lijn: Lijn A4 staand.jpg, Lijn A4 liggend.jpg enz.
Het zou handig zijn als dat in een dialoogvenster gekozen kan worden. Kan iemand mij daarbij helpen?

Het komt soms ook voor dat de linker- en rechtermarge niet aangepast mogen worden omdat er te veel in staat
Dat zou dan ook een keuze moeten zijn in het dialoogvenster. En ook het pad naar het bestand weergeven is een vraag. (tsjee, er komt steeds meer bij)

Het dialoogvenster:
Bladsoort: A4 / A3 - Staand / Liggend
Linker- rechter marge aanpassen?: ja/nee
Titel: ......
Subtitel: .....
ProjectID: ......
Pad naar bestand weergeven? ja/nee
Datum: ........
Versie: ........
Adviseur: ......

Koptekst wordt dan: (eerst alles leegmaken)
Links: Logo.jpg
Midden: (lettertype Arial 10 bold)
Titel <enter>
Subtitel <enter>
<enter>
Lijn A4 liggend.jpg (gekozen bladsoort)

Voettekst: (eerst alles leegmaken) (Lettertype Arial standaard 8)
Links: Project: ProjectID / Pad naar het bestand (als ja)
Midden: Lijn (gekozen lijn) <enter><enter>blad / aantal bladen<enter>
Rechts: Datum, Versie, Adviseur

De Pagina-instelling:
A4 of A3 Staand of Liggend
Boven 3,4
Koptekst 0,8
Links 2 (als ja)
Rechts 2 (als ja)
Onder 2,7
Voettekst 1,2

 

[danny147]

Beste Marie01

Ligt het aan mij of aan jou, maar de lijn afbeeldingen zie ik niet tevoorschijn komen, ook op mijn andere computer niet

Groetjes Danny. :thumb:

 

[Marie01]

Het is een heel dun paars lijntje van 1 pixel. Ik zie hem helemaal bovenin verschijnen.
Ik kon niet op een andere manier een lijn krijgen over de volle breedte in de koptekst.

 

[Marie01]

Nu ik dit zo lees, is het wel een gigantische vraag geworden. Ik kan me voorstellen dat jullie niet massaal in de rij staan te dringen om dit te maken. Het probleem is dat ik niet zomer met VBA kan werken. Een macro opnemen met de macro-recorder lukt nog wel, en deze afspelen ook. Eventueel zou het me ook nog wel lukken een dialoogvenster met OK en annuleren te maken, maar daarin keuzes maken en die keuzes dan verwerken ergens in, is different cook. Dat zal me waarschijnlijk dagen kosten. En dat is dan het grootste probleem, we moeten volgende week al beginnen! (En ik heb gezegd dat ik wel iets zou verzinnen! dom dom dom).
Mijn dankbaarheid zal onmetelijk groot zijn als iemand het probeert! :love:

 

[snb]

1e aanzet.

zet in c0 de drierrectory waarin de bestanden staan.
De macro opent de bestanden, past ze aan en slaat hde gewijzigde bestanden op.
Ik ben een verklaard tegenstander van dialoogvensters.

De orientatie en grootte van het blad kunnen als afzonderlijke eigenschap worden uitgelezen.
Staand = 1; liggend is 2
A4 = 4; A3 =7 ( dit moet je testen want niet voor iedere printer hetzelfde).
Met dit voorbeeld: 14= staand A4'; open 14.jpg
24=liggend A4; open 24.jpg
Afhankelijk van de 4 combinaties moet je de in te laden figuren een naam geven overeenkomstig die combinatie.
Mij lukt het in Excel 2000 niet een figuur in een koptekst te zetten.
Wellicht kun je een macro opnemen waarin je alle gewenste akties voor een voorbeeldblad uitvoert, dan kunnen we die VBA-code simpel aanpassen.

Sub Macro19()
  c0 = "C:\"
  c1 = Dir(c0 & "*.xls")
  Do Until c1 = ""
    With GetObject(c1)
      With .Sheets(1).PageSetup
        .TopMargin = Application.CentimetersToPoints(3.8)
        .RightMargin = Application.CentimetersToPoints(2)
        .LeftMargin = Application.CentimetersToPoints(2)
        .BottomMargin = Application.CentimetersToPoints(2.7)
        .PageSetup.HeaderMargin = Application.CentimetersToPoints(0.8)
        .FooterMargin = Application.CentimetersToPoints(1.2)
        c2 = .Orientation & .PaperSize & ".jpg"
      End With
      .Close True
    End With
    c1 = Dir
  Loop
End Sub

 

[Marie01]

Bedankt SNB, Ik ga het morgen uitproberen

 

[Marie01]

snb,
Ik heb weliswaar de vraag als opgelost gezet, maar ik ben nog wel met je oplossing aan het stoeien, waarvoor nogmaals dank, ik laat je weten of het lukt.
De vraag heb ik op aanraden van een vriend bij vba neergezet, vandaar dat ik deze bij Excel op opgelost heb gezet. Want het lijkt me niet goed om een vraag op 2 plaatsen te hebben.

 

[Marie01]

Hoi SNB, zoals je vroeg ga ik dus toch hier in Excel weer verder.

Je oplossing bij het invoegen van de lijnplaatjes die automatisch passen op A4 en A3 is mooi!
Ik krijg het echter alleen werkend zoals in de code hieronder. (het testbestand moet ik dan openzetten en ik moet dan 1 voor 1 de tabbladen openen en de macro uitvoeren)

Ik begrijp het do until loop gedeelte niet, of het werkt niet goed.
Wat er gebeurde was dat de documenten "verborgen"werden geopend, (misschien is dat ook de bedoeling?)
Vervolgens werkte het eerste tabblad goed en op het laatste kwam de lijn van het eerste tabblad te staan. En de tabbladen daartussenin waren helemaal niet bewerkt.

Met de macro zoals hieronder komt er vaste tekst in de kop en voetteks. Hoe wil je zonder gebruik van een dialoogvenster daar maar 1 x de titels hoeven intypen?

Groet,
Marie

Sub KopVoet()
    
  'c0 = "C:\"
  'c1 = Dir(c0 & "*.xls")
    
    c0 = "C:\Users\Marie\Desktop\ABC\Bestanden\"
    c1 = Dir(c0 & "Test.xls")
    C2 = ActiveSheet.PageSetup.Orientation & ActiveSheet.PageSetup.PaperSize & ".jpg"
    C3 = "C:\Users\Marie\Desktop\ABC\Afbeeldingen\Logo.tif"
    C4 = "C:\Users\Marie\Desktop\ABC\Afbeeldingen\" & C2
  
'       Do Until c1 = ""
'       With GetObject(c1)
    ActiveSheet.PageSetup.LeftHeaderPicture.Filename = C3
  ActiveSheet.PageSetup.CenterHeaderPicture.Filename = C4
   ActiveSheet.PageSetup.CenterFooterPicture.Filename = C4
   
  
      With ActiveSheet.PageSetup
        .LeftHeader = "&G"
        .CenterHeader = "&""Arial,Vet""Projecttitel" & Chr(10) & "Subtitel" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "&G"
        .RightHeader = ""
        .LeftFooter = "&8" & Chr(10) & "" & Chr(10) & "Referentie"
        .CenterFooter = "&8&G" & Chr(10) & "" & Chr(10) & "&P / &N"
        .RightFooter = "&8" & Chr(10) & "" & Chr(10) & "Datum / Status / Auteur"
        .LeftMargin = Application.InchesToPoints(0.78740157480315)
        .RightMargin = Application.InchesToPoints(0.78740157480315)
        .TopMargin = Application.InchesToPoints(1.33858267716535)
        .BottomMargin = Application.InchesToPoints(1.06299212598425)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.47244094488189)

'        C2 = .Orientation & .PaperSize & ".jpg"
      End With
      Close
   ' End With
    'c1 = Dir
  'Loop
End Sub

 

[snb]

1. kun je de status van je vraag wijzigien van opgelost, naar in behandeling?
2. kun je VBA-code tussen code-tags (#) zetten ?
3. omdat het om meer dan 1 bestadn ging (en het me praktisch lijkt die voor deze exercitie in 1 maop te zetten lopen we met dir alls xls betadnen in een bepaalde map langs.
4. omdat we genoeg koffie gehad hebben worden de bestanden niet zichtbaar bewerkt, dat bespaart een hoop tijd.

Sub Macro19()
  c0 = "C:\Users\Marie\Desktop\ABC\Bestanden\"
  c1 = Dir(c0 & "*.xls")
  c3 = "C:\Users\Marie\Desktop\ABC\Afbeeldingen\" 
  c2 = c3 & "Logo.tif"
 
  Do Until c1 = ""
    With GetObject([COLOR="Red"]c0 & [/COLOR]c1)
       for each ch in sheets
         With .Sh.PageSetup
            .TopMargin = Application.CentimetersToPoints(3.8)
            .RightMargin = Application.CentimetersToPoints(2)
            .LeftMargin = Application.CentimetersToPoints(2)
            .BottomMargin = Application.CentimetersToPoints(2.7)
            .PageSetup.HeaderMargin = Application.CentimetersToPoints(0.8)
            .FooterMargin = Application.CentimetersToPoints(1.2)
            .LeftHeaderPicture.Filename = c2
             c4=c3 &.Orientation & .PaperSize & ".jpg"
            .CenterHeaderPicture.Filename =c4
            .CenterFooterPicture.Filename = c4
            .LeftHeader = "&G"
            .CenterHeader = "&""Arial,Vet""Projecttitel" & Chr(10) & "Subtitel" & Chr(10) & "" & Chr(10) & "" & Chr(10) & "&G"
            .LeftFooter = "&8" & Chr(10) & "" & Chr(10) & "Referentie"
            .CenterFooter = "&8&G" & Chr(10) & "" & Chr(10) & "&P / &N"
            .RightFooter = "&8" & Chr(10) & "" & Chr(10) & "Datum / Status / Auteur"
         End With
 [COLOR="Red"]      Next[/COLOR]
      .Close True
     End With
    c1 = Dir
  Loop
End Sub

 

[Marie01]

Hoi SNB,
ik krijg allemaal fouten: End with zonder with. Loop zonder do, enso.
Ik heb ze wat heen en weer geschoven, maar krijg dan bij With GetObject(c1) een "automatiseringsfout ongeldige syntaxis".

Nu werk ik op een laptop waar zowel office 2007 als Office2003 op staat, dat heeft hier misschien mee te maken.
Morgen ga ik het proberen op een omgeving met alleen 2003.
Bedankt weer voor je input.

 

[snb]

Vorige suggestie verbeterd.

 

[Marie01]

Hoi SNB
Ik probeer het nu op een omgeving met Office 2003:

"With .Sh.PageSetup" - wordt niet herkend.

Hij loopt alleen door met "With ActiveSheet.PageSetup"
en dan bewerkt hij (zij?) alleen het eerste tabblad.

 

[Marie01]

Ik geef het automatisme van bestanden openen bewerken en weer sluiten op.
Dit kost te veel tijd. Het is al heel handig dat vanzelf logo en lijnen gezet worden.

Het is ook niet zo moeilijk om (met flinke hoeveelheid koffie erbij) op elk tabblad een macro in werking te zetten toch? Kun je meteen kijken of het goed gelukt is.

Maar als laatste en belangrijker vind ik de tekst die per bestand op elk tabblad gezet moet worden, zoals Projecttitel, subtitel enz. Daar heb je toch echt een dialoogvenster voor nodig? Maar hoe maak ik die?

 

[snb]

Niet zo somber:

Sub Macro19()
  c0 = "C:\Users\Marie\Desktop\ABC\Bestanden\"
  c1 = Dir(c0 & "*.xls")
  c3 = "C:\Users\Marie\Desktop\ABC\Afbeeldingen\" 
  c2 = c3 & "Logo.tif"
 
  Do Until c1 = ""
    With GetObject(c0 & c1)
       for each sh [COLOR="Red"][B]in .s[/B][/COLOR]heets
         [COLOR="red"]With sh[/COLOR].PageSetup
            .TopMargin = Application.CentimetersToPoints(3.8)
            .RightMargin = Application.CentimetersToPoints(2)
            .LeftMargin = Application.CentimetersToPoints(2)
            .BottomMargin = Application.CentimetersToPoints(2.7)
            .PageSetup.HeaderMargin = Application.CentimetersToPoints(0.8)
            .FooterMargin = Application.CentimetersToPoints(1.2)
            .LeftHeaderPicture.Filename = c2
             c4=c3 &.Orientation & .PaperSize & ".jpg"
            .CenterHeaderPicture.Filename =c4
            .CenterFooterPicture.Filename = c4
            .LeftHeader = "&G"
 [COLOR="Red"]           .CenterHeader = "&""Arial,Vet" & ThisWorkbook.BuiltinDocumentProperties("Title") & & Chr(10) & ThisWorkbook.BuiltinDocumentProperties("SubTitle") & Chr(10) & "" & Chr(10) & "" & Chr(10) & "&G"
            .LeftFooter = "&8" & Chr(10) & "" & Chr(10) & ThisWorkbook.BuiltinDocumentProperties("Reference")
            .CenterFooter = "&8&G" & Chr(10) & "" & Chr(10) & "&P / &N"
            .RightFooter = "&8" & Chr(10) & "" & Chr(10) & format(date("dd-mm-jjjj") & " " & ThisWorkbook.BuiltinDocumentProperties("Status") & " " & ThisWorkbook.BuiltinDocumentProperties("Author")[/COLOR]         End With
       Next
      .Close True
     End With
    c1 = Dir
  Loop
End Sub

 

[Marie01]

En dan ben ik natuurlijk weer vreselijk nieuwsgierig naar deze aanvullingen!
Kan nu niet. Probeer ze morgen. Bedankt wilde weldoener.

 

[Marie01]

Hi SNB.
Sorry voor late reactie.
De volgende macro werkt! We hebben al wat test-documenten hiermee omgezet. Maar hij werkt alleen als ik hem in het aan te passen Excel document plaats. Hem starten vanuit Prsnlk.xls lukt niet. omdat hij dan de eigenschappen van prsnlk.xls neemt (i.p.v. het om te zetten document).
Ik heb nog een wens, zou er per tabblad een msgbox kunnen komen met de vraag of de linker en rechtermarge aangepast moeten worden, of niet?
Zoals hieronder (door mij geprutst) werkt het niet, omdat je niet ziet voor welk tabblad de vraag gesteld wordt.
Mocht dit niet lukken, dan kunnen we toch heel goed hiermee werken. En ik bedank je voor je geweldige hulp.

Sub Macro19()
  c0 = "C:\Marie\Documenten\"
  c1 = Dir(c0 & "*.xls")
  C3 = "C:\Marie\Afbeeldingen\"
  c2 = C3 & "Logo.tif"
Do Until c1 = ""
    With GetObject(c0 & c1)
       For Each sh In .Sheets
         With sh.PageSetup
            .TopMargin = Application.CentimetersToPoints(3.8)
            
            Dim Msg, Style, Title, Response, MyString
            Msg = "linker en rechtermarge aanpassen?"
            Style = vbYesNo + vbDefaultButton1
            Title = "Marge aanpassen"
            Response = MsgBox(Msg, Style, Title)
            If Response = vbYes Then
            MyString = "Ja"
 
               .RightMargin = Application.CentimetersToPoints(2)
               .LeftMargin = Application.CentimetersToPoints(2)
            Else
            MyString = "Nee"
            GoTo verder
            End If
verder:
            .BottomMargin = Application.CentimetersToPoints(2.7)
            .HeaderMargin = Application.CentimetersToPoints(0.8)
            .FooterMargin = Application.CentimetersToPoints(1.2)
            .LeftHeaderPicture.Filename = c2
            .LeftHeader = "&8&G"
             c4 = C3 & .Orientation & .PaperSize & ".tif"
            .CenterHeaderPicture.Filename = c4
            .CenterHeader = "&8" & nn10 & b & ThisWorkbook.BuiltinDocumentProperties("Title") & Chr(10) & ThisWorkbook.BuiltinDocumentProperties("Subject") & Chr(10) & "" & Chr(10) & "" & Chr(10) & "&G" & b
            .LeftFooter = "&8" & nn10 & "" & Chr(10) & ThisWorkbook.CustomDocumentProperties("Referentie") & " / " & ThisWorkbook.CustomDocumentProperties("Klant")
            .CenterFooterPicture.Filename = c4
            .CenterFooter = "&8&G" & Chr(10) & "" & Chr(10) & "&P / &N"
            .RightFooter = "&8" & Chr(10) & "" & Chr(10) & ThisWorkbook.CustomDocumentProperties.Item("Datum voltooid") & " " & ThisWorkbook.CustomDocumentProperties("Status")
            End With
        Next
      .Close True
     End With
    c1 = Dir
  Loop
End Sub

 

[snb]

vanuit persnlk.xls

Sub Macro19()
  c0 = "C:\Users\Marie\Desktop\ABC\Bestanden\"
  c1 = Dir(c0 & "*.xls")
  c3 = "C:\Users\Marie\Desktop\ABC\Afbeeldingen\" 
  c2 = c3 & "Logo.tif"
 
  Do Until c1 = ""
    With GetObject(c0 & c1)
       for each sh in .sheets
         With sh.PageSetup
            .TopMargin = Application.CentimetersToPoints(3.8)
            .RightMargin = Application.CentimetersToPoints(2)
            .LeftMargin = Application.CentimetersToPoints(2)
            .BottomMargin = Application.CentimetersToPoints(2.7)
            .PageSetup.HeaderMargin = Application.CentimetersToPoints(0.8)
            .FooterMargin = Application.CentimetersToPoints(1.2)
            .LeftHeaderPicture.Filename = c2
             c4=c3 &.Orientation & .PaperSize & ".jpg"
            .CenterHeaderPicture.Filename =c4
            .CenterFooterPicture.Filename = c4
            .LeftHeader = "&G"
            .CenterHeader = "&""Arial,Vet" & [COLOR="Red"].parent.parent[/COLOR].BuiltinDocumentProperties("Title") &  Chr(10) & [COLOR="red"].parent.parent[/COLOR].BuiltinDocumentProperties("SubTitle") & Chr(10) & "" & Chr(10) & "" & Chr(10) & "&G"
            .LeftFooter = "&8" & Chr(10) & "" & Chr(10) & [COLOR="red"].parent.parent[/COLOR].BuiltinDocumentProperties("Reference")
            .CenterFooter = "&8&G" & Chr(10) & "" & Chr(10) & "&P / &N"
            .RightFooter = "&8" & Chr(10) & "" & Chr(10) & format(date("dd-mm-jjjj") & " " & [COLOR="red"].Parent.Parent[/COLOR].BuiltinDocumentProperties("Status") & " " & [COLOR="red"].Parent.parent[/COLOR].BuiltinDocumentProperties("Author")         
          End With
       Next
      .Close True
     End With
    c1 = Dir
  Loop
End Sub

Wat bedoel je met:

Ik heb nog een wens, zou er per tabblad een msgbox kunnen komen met de vraag of de linker en rechtermarge aangepast moeten worden, of niet?

Gaat het om de marges of om de kopteksten ?
In welke geval zou het ene moeten geeuren en wanneer het andere ? en waarom zou dat niet automatisch kunnen gebeuren zonder de gebruiker lastig te vallen ?

 

[Marie01]

Bedankt SNB Ik ga het weer proberen.

Alle tabbladen krijgen de kopteksten.

Maar soms staat er zoveel informatie op een blad dat de marge 1 links en 1 rechts moet worden (of nog kleiner)
Per tabblad zou (eventueel) aangegeven moeten kunnen worden of de marges wel of niet gewijzigd moet worden naar 2 links en 2 rechts.

 

[snb]

Waarin druk je 'zoveel informatie, dat...' uit ?
M.a.w. bijv. als de lengte van de linkervoettekst groter is dan 120 dan moet de linkermarge 1 cm zijn.

 

[Marie01]

Moeilijk iets aan te wijzen.
Het gaat om calculatiebladen waarbij de cellen op het blad zo vol zijn dat als voor afdrukken 100% wordt gekozen , 1 bij ... en A4 staand, bijvoorbeeld, de cellen van links naar rechts gevuld zijn.