Opgelost Kleur werkblad uit zetten bij het maken van een PDF

Dit topic is als opgelost gemarkeerd
Status
Niet open voor verdere reacties.
D

DutchOirs

Gebruiker
Lid geworden
30 sep 2009
Berichten
891
Goedemorgen,
Zit weer met een vraagje waar ik al enige dagen mee bezig ben.
Doelstelling is om een werkblad te kunnen printen met keuze: Zwart-wit of Kleur. Dit werkt perfect.
Maar er is ook een keuze om van dit werkblad een PDF te maken. Ook dit wert goed, alleen kom het volgende probleem tegen:
Krijg het niet voor elkaar om hier de keuze Zwart-wit of Kleur te verkrijgen.
Bij een PDF omzetting wordt het excel file alles Paars, wat dan vervolgens ook een paarse PDF wordt??
Code: 
If PDFKleurOfCheckBox = True Then Worksheets("Blad1").PageSetup.BlackAndWhite = True: MsgBox ("uit") ' zwart-wit aan
If PDFKleurOnCheckBox = True Then Worksheets("Blad1").PageSetup.BlackAndWhite = False: MsgBox ("aan") ' kleur aan
Iemand een idee hierover?
Al many thanks

Dutch
 
Je hebt 2x true staan bij PDFkleurofcheckbox,
ik weet niet of dit de fout is maar het lijkt mij niet goed
 
1 vinkvak volstaat:

sheets("Blad1").PageSetup.BlackAndWhite = PDFKleurOfCheckBox.value
 
Inderdaad.
En met je msgbox:
Code: 
Sheets("Blad1").PageSetup.BlackAndWhite = PDFKleurOnCheckBox
MsgBox IIf(PDFKleurOnCheckBox, "Aan", "Uit")
 
1e voor Mde:
Code: 
If PDFKleurOfCheckBox = True Then Worksheets("Blad1").PageSetup.BlackAndWhite = True: MsgBox ("uit") ' zwart-wit aan
If PDFKleurOnCheckBox = True Then Worksheets("Blad1").PageSetup.BlackAndWhite = False: MsgBox ("aan") ' kleur aan
of PDFKleurOfCheckBox = waar
of PDFKleurOnCheckBox = waar
Deze 2 checkboxen is een keuze of je het document zwart-wit wilt of in kleur wilt maken
 
Het voorstel van snb en mij doet exact hetzelfde met maar 1 CheckBox.
 
Voor de andere:
Heb een document in Excel (2003). Deze bestaat uit 3 pagina's
Vervolgens wik ik een keuze hebben om één v/d 3, of alle 3 of de actuele gevallen vanaf een bepaald jaar te kunnen:
A: Printen en dit werkt met of zonder kleur
B: een PDF van te maken en bij een PDF maken komt het probleem
om een PDF te verkrijgen maakt hij een nieuw excel document met de gegevens erop en slaat dit op
Dit werkt ook goed, alleen wat bij Printen wel goed werkt wil niet bij een PDF maken.
Namelijk hij maakt het excel file helemaal paars.
De werkwijze als met printen wil niet bij het PDF maken.

Hoi Edmoor,
ja begrijp ik, maar maakt verder niet uit. gaat erom dat als hij een PDF maakt ook wel of niet kleuren meeneemt!
 
Met 2 CheckBoxen heb je 4 mogelijkheden.
Dan kan je beter 2 OptionButtons in een Group gebruiken, dan heb je alleen de twee benodigde mogelijkheden.
 
Plaats dan, zoals al eerder gevraagd, een voorbeeld documentje waarin gebeurt wat je beschrijft.
 
Laatst bewerkt:
Begrijp ik Edmoor, maar staat gevoelige informatie op, vandaar.
Zal vanavond wel weer even kijken
Thanks
 
Alvast de macro: Vanwaar de PDF verwerking begint
Code: 
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
        If PrintPDFType > 0 Then        ' alleen PDF maken
          If PDFKleurOfCheckBox = True Then Worksheets("Blad1").PageSetup.BlackAndWhite = True: MsgBox ("0 uit") ' zwart-wit aan
          If PDFKleurOnCheckBox = True Then Worksheets("Blad1").PageSetup.BlackAndWhite = False: MsgBox ("0 aan") ' kleur aan
          Excel_File_Maken
         
          Check_Excel_Bestaat
        End If      
      End With
      If PrintPDFType > 0 Then GoTo Door9          ' alleen PDF maken
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

Volgende sub± Excel File Maken:

Code: 
Private Sub Excel_File_Maken()                              ' revisie [22-01-2025]  maakt een extra WerkBlad aan
  Dim c01 As String, MJOBJaar As Integer, i As Integer, SelRange As String
 
  Application.DisplayAlerts = False
  Worksheets("Blad1").Activate         ' activeert wb DBase cel A1

  If PDFKleurOfCheckBox = True Then Worksheets("Blad1").PageSetup.BlackAndWhite = True: MsgBox ("1 uit") ' zwart-wit aan
  If PDFKleurOnCheckBox = True Then Worksheets("Blad1").PageSetup.BlackAndWhite = False: MsgBox ("1 aan") ' kleur aan
 
[CODE]Volgende Sub Check Excel Bestaat:
Private Sub Check_Excel_Bestaat()                                   ' revisie [20-02-2023]
  Dim wb As Workbook, fName As String, TB As Workbook, i As Integer, bOpen As Boolean, fPath As String, sFullName As String, strOld As String  ', MijnNaam As String
  Set TB = ThisWorkbook                                                                                                ' object verwijzing naar TB van (dit) file
  fPath = ActiveWorkbook.Worksheets("Control").Range("D6")         ' Path waar (dit) excel file staat
   If PrintPDFType = 2 Then
     If Pagina = 1 Then fName = ActiveWorkbook.Worksheets("Control").Range("D10") & "Pag1" & ".xls"  ' Path en Naam  + Pag1 + extensie
     If Pagina = 2 Then fName = ActiveWorkbook.Worksheets("Control").Range("D10") & "Pag2" & ".xls" ' Path en Naam  + Pag1 + extensie
     If Pagina = 3 Then fName = ActiveWorkbook.Worksheets("Control").Range("D10") & "Pag3" & ".xls" ' Path en Naam  + Pag1 + extensie
   End If
    MijnNaam = fName
 
  sFullName = Dir(fPath & IIf(Right(fPath, 1) <> "\", "\", "") & fName & "*")         ' zoek in dit Path dit File

  If Not Right(sFullName, 5) Like "*.xls" Then
    Do
      If sFullName = "" Then MsgBox "Dat File " & fPath & IIf(Right(fPath, 1) <> "\", "\", "") & fName & "*" & " als xls-file bestaat niet eens": Exit Sub ' foutje bedankt
      If Not (Right(sFullName, 5) Like "*.xls") Then sFullName = Dir(ActiveWorkbook.Worksheets("Control").Range("L5"))            ' zoek naar volgende file
      GoTo Door
    Loop
    fName = sFullName                                               ' nu heeft fName een extensie
    MsgBox ("Not")
  End If
  i = InStrRev(fName, ".", -1)                                      ' zoekt de positie v/d extensie punt vanaf rechts
  If i = 0 Then MsgBox ("File heeft geen extensie!"): Exit Sub      ' fileName heeft geen Extensie
  MijnNaam = Left(fName, i - 1)                                     ' geeft var. MijnNaam de fileName zonder extensie voor PDFMaken
  On Error Resume Next
  wb = Nothing: Set wb = Workbooks(fName)                           ' maakt wb leeg en geeft hem de naam van dit file (fName)
  bOpen = Not (wb Is Nothing)                                       ' file al open? onthouden voor straks, anders straks sluiten
  If Not bOpen Then Set wb = Workbooks.Open(fPath & IIf(Right(fPath, 1) <> "\", "\", "") & fName)
  On Error GoTo 0
  If wb Is Nothing Then MsgBox ("File is niet te vinden!!"): Exit Sub   ' als wb komt niet voor exit sub
  Application.CutCopyMode = False                                   ' niet in de modus Knippen of Copieeren
  strOld = Application.ActivePrinter                                ' slaat naam printer op, voor terugzetten
  PDF_Maken                                                         ' sub PDF maken
 
  If Not bOpen Then wb.Close False                                  ' als niet bOpen dan close het file, anders straks file open staan
  Application.ActivePrinter = strOld                                ' zet active printer weer terug!
Door:
End Sub
With Worksheets("Blad1")
If PrintType = "Individueel" Then ' But2 één bepaalde pagina printen
ActiveWorkbook.Worksheets("Blad1").Range("A1").Select ' zet active cel op A1
If Pagina = 1 Then .Range("A1:H42").Select: SelRange = "A1:H42" ' SelRange = selectie
If Pagina = 2 Then .Range("A43:H83").Select: SelRange = "A43:H83" ' SelRange = selectie
If Pagina = 3 Then .Range("A84:H94").Select: SelRange = "A84:H94" ' SelRange = selectie
End If
.Range(SelRange).Copy
End With
If PrintPDFType = 2 Then
If Pagina = 1 Then c01 = ActiveWorkbook.Worksheets("Control").Range("D6") & ActiveWorkbook.Worksheets("Control").Range("D10") & "Pag1" & ".xls" ' Path en Naam + Pag1 + extensie
If Pagina = 2 Then c01 = ActiveWorkbook.Worksheets("Control").Range("D6") & ActiveWorkbook.Worksheets("Control").Range("D10") & "Pag2" & ".xls" ' Path en Naam + Pag1 + extensie
If Pagina = 3 Then c01 = ActiveWorkbook.Worksheets("Control").Range("D6") & ActiveWorkbook.Worksheets("Control").Range("D10") & "Pag3" & ".xls" ' Path en Naam + Pag1 + extensie
End If

With ActiveWorkbook.Sheets.Add ' maakt een nieuw wb aan
.Range("A1").Select
.Range("A1").PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False ' maakt klembord leeg
.Columns("A").ColumnWidth = 4 ' kolom A in nwe file
.Columns("B").ColumnWidth = 12 ' kolom B in nwe file
.Columns("C").ColumnWidth = 20 ' kolom C in nwe file
.Columns("D").ColumnWidth = 10 ' kolom D in nwe file
.Columns("E").ColumnWidth = 12.67 ' kolom E in nwe file
.Columns("F").ColumnWidth = 22.22 ' kolom F in nwe file
.Columns("G").ColumnWidth = 6.11 ' kolom G in nwe file
.Columns("H").ColumnWidth = 52.89 ' kolom H in nwe file
.Copy ' maakt een kopie van dit nieuwe wb
With ActiveWorkbook ' met nieuwe wb
With ActiveSheet.PageSetup ' zet de juiste marges neer voor nieuwe file
.Orientation = xlLandscape ' https://www.ozgrid.com/forum/forum/help-forums/excel-general/139429-pagesetup-and-papersize-macro
.PaperSize = xlPaperA4
.LeftMargin = Application.InchesToPoints(0.2)
.RightMargin = Application.InchesToPoints(0.2)
.TopMargin = Application.InchesToPoints(0.2)
.BottomMargin = Application.InchesToPoints(0.2)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
If PDFKleurOfCheckBox = True Then .BlackAndWhite = True: MsgBox ("2 uit") ' zwart-wit aan EIGENSCHAP WORDT NIET ONDERSTEUNT
If PDFKleurOnCheckBox = True Then .BlackAndWhite = False: MsgBox ("2 aan")
End With
.SaveCopyAs c01 ' met nieuwe wb, slaat op als file
.Close ' met nieuwe wb, sluit dit nieuw file, belangrijk omdat onder Check Excel Bestaat
End With ' een Path moet worden ingelezen van wb Control.Range("D6")!
.Delete ' met nieuwe wb, deze verwijderen
End With
End Sub
[/CODE]
 
Sub PDF maken

Code: 
Private Sub PDF_Maken()                                 ' revisie [20-02-2023]
  Dim pdfjob As Object, sPDFName As String, ePDFPath As String, Bestand As String, txt As String, strPrinter As String

  sPDFName = IIf(MijnNaam = "", "GeenNaam", MijnNaam) & ".xls"      ' sPDFNaame = Als MijnNaam = "" dan "GeenNaam" anders MijnNaam & xls
  ePDFPath = ThisWorkbook.Sheets("Control").Range("D8")             ' ePath is het path voor het opslaan van PDF-RGAK overzichten
  Bestand = ePDFPath & sPDFName                                     ' Bestand = Path + sPDFName
  Application.DisplayAlerts = False

'  If Dir(Bestand) <> "" Then
'    txt = MsgBox("Bestand: " & Bestand & " bestaat al! " & vbCrLf & "Wilt u deze overschrijven? ", vbYesNo, "Check File")
'    If txt <> vbYes Then Exit Sub
'  End If
  Set pdfjob = CreateObject("PDFCreator.clsPDFCreator") ' objectverwijzing naar pdfjob
  With pdfjob
    If .cStart("/NoProcessingAtStartup") = False Then   ' als pdfjob niet wil starten
      MsgBox "Can't initialize PDFCreator.", vbCritical + vbOKOnly, "PrtPDFCreator"         ' https://www.google.nl/search?source=hp&ei=ZggfXYzSKdL5kwW0lLeoBQ&q=.cOption+%28%22UseAutoSave%22%29+-+1+++&oq=.cOption+%28%22UseAutoSave%22%29+-+1+++&gs_l=psy-ab.3..0i22i10i30.11086.11086..17811...0.0..0.98.98.1......0....2j1..gws-wiz.....0.pX0AorYfMgU
      Exit Sub                                                                              ' https://www.cimaware.com/expert-zone/printing-worksheets-to-a-pdf-file-using-early-binding
    End If
    .cOPtion("UseAutoSave") = 1                         ' gebruik Autosave aan
    .cOPtion("UseAutosaveDirectory") = 1                ' gebruik Autosave Directory aan
    .cOPtion("AutosaveDirectory") = ePDFPath            ' AutosaveDirectory = SPDFPath
    .cOPtion("AutosaveFilename") = sPDFName             ' AutosaveFileName = SPDFName
    .cOPtion("AutosaveFormat") = 0                      ' 0 = PDF
    .cClearCache                                        '
 '    .cOPtion(".PageSetup.BlackAndWhite") = 1: MsgBox ("3 uit")  ' zwart-wit aan EIGENSCHAP WORDT NIET ONDERSTEUNT
     .cOPtion(".PageSetup.BlackAndWhite") = 0: MsgBox ("3 aan") ' kleur aan    EIGENSCHAP WORDT NIET ONDERSTEUNT

'  If PDFKleurOfCheckBox = True Then cOPtion(".PageSetup.BlackAndWhite") = 1: MsgBox ("4 2uit")  ' zwart-wit aan EIGENSCHAP WORDT NIET ONDERSTEUNT
'  If PDFKleurOnCheckBox = True Then cOPtion(".PageSetup.BlackAndWhite") = 0: MsgBox ("4 aan") ' kleur aan    EIGENSCHAP WORDT NIET ONDERSTEUNT
    

  End With
  ActiveSheet.Range("A1:AV344").PrintOut copies:=1, ActivePrinter:="PDFCreator"   ' maakt een PDF-file
  Do Until pdfjob.cCountOfPrintjobs = 1                         ' wait until the print job has entered the print queue
    DoEvents
  Loop
  pdfjob.cPrinterStop = False
  Do Until pdfjob.cCountOfPrintjobs = 0                         ' wait until PDF creator is finished then release the objects
    DoEvents
  Loop
  pdfjob.cClose
  Set pdfjob = Nothing
End Sub
 
pfff ging niet lekker.
Vraag is kan men net zoals met printen de kleur aan en uit zetten om een PDF te maken?
 
één probleem getackeld.
Met het aanmaken van een nieuw excel file, waarin de gegevens gekopieerd worden, werd de lichtgroene kleur v/h document de kleur Paars. !
Probleem is als het een aangepaste kleur is, wordt deze niet goed over gekopieerd.
Dus kan in deze alleen de vaste kleuren gebruiken.
.
 
Nu het volgende:
Kan ik dan ook deze pagina in zwart-wit krijgen met het over kopiëren?
Of gaat dit alleen als ik een PDF maak met de PDF-printer?
 
kom tot de volgende slotsom:
.PageSetup.BlackAndWhite = geschikt voor het Printen
Maar helaas niet voor een PDF-printer.
Dus maar op een andere manier:
In het begin bij het maken v/h nieuwe excel file, daar worden de gegevens in gekopieeerd.
Komt volgende vraag: Is er ook een paste die geen kleur plakt.
Wel de regels en lijnen maar geen kleur?
 
Na het kopiëren:
Code: 
    With Cells
        .Interior.Pattern = xlNone
        .Font.ColorIndex = xlAutomatic
    End With
 
Goedemorgen AHulpje,
Geprobeerd, maar geeft een foutmelding.
Fout 1004 tijdens uitvoering
Methode PasteSpecial van klasse Range is mislukt.
Wat gebeurd is ook dat originele file daar ook de kleur weg is.
De bedoeling is juist dat het in het nieuwe excel file komt
Thanks aniway
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan