• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Excel PDF printen kwaliteit verschil.

Status
Niet open voor verdere reacties.
G

Gerton64

Gebruiker
Lid geworden
8 sep 2006
Berichten
88
Vraag:

Heb een bestand met script die een selectie maakt om pdf document te maken en opslaat in een directory, en daarna gelijk het document in de een mail zet. (werkt)

Maar als ik PDF maakt via script, dan is de kwaliteit minder en ander lettertype (rechterkant 2), als ik menu > Print PDF ziet het er goed uit (linkerkant 1)

voorbeeld.PNG
 
Module 1

Sub RDB_Selection_Range_To_PDF()
Dim FileName As String

If ActiveWindow.SelectedSheets.Count > 1 Then
MsgBox "Er is meer dan een werkblad geselecteerd," & vbNewLine & _
"Ieder blad zal worden opgeslagen!"
Else
FileName = RDB_Create_PDF(Source:=Range("A1:AB76"), _
FixedFilePathName:="", _
OverwriteIfFileExist:=True, _
OpenPDFAfterPublish:=True)
If FileName <> "" Then

Else
MsgBox "Kan PDF niet opslaan, Mogelijke oorzaken:" & vbNewLine & _
"Microsoft Add-in is niet geinstaleerd" & vbNewLine & _
"U hebt op annuleren gedrukt" & vbNewLine & _
"Het pad in argument 2 is niet correct of bestaat niet" & vbNewLine & _
"U heeft gekozen een reeds bestaande PDF niet te overschrijven"
End If
End If
End Sub
Sub RDB_Selection_Range_To_PDF_And_Create_Mail()
Dim FileName As String
If ActiveWindow.SelectedSheets.Count > 1 Then
MsgBox "Er is meer dan een werkblad geselecteerd," & vbNewLine & _
"Ieder blad zal worden opgeslagen!"
Else
FileName = RDB_Create_PDF(Source:=Range("A1:AB76"), _
FixedFilePathName:="", _
OverwriteIfFileExist:=True, _
OpenPDFAfterPublish:=False)

If FileName <> "" Then
RDB_Mail_PDF_Outlook FileNamePDF:=FileName, _
StrTo:=ActiveSheet.Range("AH3"), _
StrCC:=ActiveSheet.Range("AH3"), _
StrBCC:="", _
StrSubject:="Incidentgegevens 2019" & ActiveSheet.Range("h9"), _
Signature:=True, _
Send:=False, _
StrBody:="<H3><B>Beste,aanvrager</B></H3><br>" & _
"<body>Deze Mail is automatisch gegenereerd en daarom niet ondertekend" & _
"<br><br>" & " ......</body>"
Else
MsgBox "Kan PDF niet opslaan, Mogelijke oorzaken:" & vbNewLine & _
"Microsoft Add-in is niet geinstaleerd" & vbNewLine & _
"U hebt op annuleren gedrukt" & vbNewLine & _
"Het pad in argument 2 is niet correct of bestaat niet" & vbNewLine & _
"U heeft gekozen een reeds bestaande PDF niet te overschrijven"
End If
End If
End Sub


==================================
FunctionsModule

Function RDB_Create_PDF(Source As Object, FixedFilePathName As String, _
OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
Dim FileFormatstr As String
Dim Fname As Variant
If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
& Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then
If FixedFilePathName = "" Then
FileFormatstr = "PDF Files (*.pdf), *.pdf"
Fname = Application.GetSaveAsFilename(Format(Now, "yyyy mm dd") & "_" & Range("K3") & "_" & Range("D6"), filefilter:=FileFormatstr, _
Title:="Create PDF")
If Fname = False Then Exit Function
Else
Fname = FixedFilePathName
End If
If OverwriteIfFileExist = False Then
If Dir(Fname) <> "" Then Exit Function
End If
On Error Resume Next
Source.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=OpenPDFAfterPublish
On Error GoTo 0
If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
End If
End Function
Function RDB_Mail_PDF_Outlook(FileNamePDF As String, StrTo As String, _
StrCC As String, StrBCC As String, StrSubject As String, _
Signature As Boolean, Send As Boolean, StrBody As String)
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
If Signature = True Then .Display
.To = StrTo
.CC = StrCC
.BCC = StrBCC
.Subject = StrSubject
.HTMLBody = StrBody & "<br>" & .HTMLBody
.Attachments.Add FileNamePDF
If Send = True Then
.Send
Else
.Display
End If
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
End Function
 
Is het niet mogelijk om een representatief voorbeeldbestandje te posten?
De code in je 2e post moet je tussen code tags zetten. Dit is een onleesbare brij geworden zo.

Mijn enige tip is om het woord gealarmeringen, in de zin: "aantal gealarmeringen eenheden", aan te passen.
 
gerton64 zei:
module 1

Code: 
sub rdb_selection_range_to_pdf()
    dim filename as string

    if activewindow.selectedsheets.count > 1 then
       msgbox "er is meer dan een werkblad geselecteerd," & vbnewline & _
               "ieder blad zal worden opgeslagen!"
    else
        filename = rdb_create_pdf(source:=range("a1:ab76"), _
                                  fixedfilepathname:="", _
                                  overwriteiffileexist:=true, _
                                  openpdfafterpublish:=true)
        if filename <> "" then
            
        else
            msgbox "kan pdf niet opslaan, mogelijke oorzaken:" & vbnewline & _
               "microsoft add-in is niet geinstaleerd" & vbnewline & _
               "u hebt op annuleren gedrukt" & vbnewline & _
               "het pad in argument 2 is niet correct of bestaat niet" & vbnewline & _
               "u heeft gekozen een reeds bestaande pdf niet te overschrijven"
        end if
    end if
end sub
sub rdb_selection_range_to_pdf_and_create_mail()
    dim filename as string
    if activewindow.selectedsheets.count > 1 then
        msgbox "er is meer dan een werkblad geselecteerd," & vbnewline & _
               "ieder blad zal worden opgeslagen!"
    else
        filename = rdb_create_pdf(source:=range("a1:ab76"), _
                                  fixedfilepathname:="", _
                                  overwriteiffileexist:=true, _
                                  openpdfafterpublish:=false)

        if filename <> "" then
            rdb_mail_pdf_outlook filenamepdf:=filename, _
                                 strto:=activesheet.range("ah3"), _
                                 strcc:=activesheet.range("ah3"), _
                                 strbcc:="", _
                                 strsubject:="incidentgegevens 2019" & activesheet.range("h9"), _
                                 signature:=true, _
                                 send:=false, _
                                 strbody:="<h3><b>beste,aanvrager</b></h3><br>" & _
                                          "<body>deze mail is automatisch gegenereerd en daarom niet ondertekend" & _
                                          "<br><br>" & " ......</body>"
        else
            msgbox "kan pdf niet opslaan, mogelijke oorzaken:" & vbnewline & _
               "microsoft add-in is niet geinstaleerd" & vbnewline & _
               "u hebt op annuleren gedrukt" & vbnewline & _
               "het pad in argument 2 is niet correct of bestaat niet" & vbnewline & _
               "u heeft gekozen een reeds bestaande pdf niet te overschrijven"
        end if
    end if
end sub


==================================
Code: 
functionsmodule

function rdb_create_pdf(source as object, fixedfilepathname as string, _
                        overwriteiffileexist as boolean, openpdfafterpublish as boolean) as string
    dim fileformatstr as string
    dim fname as variant
    if dir(environ("commonprogramfiles") & "\microsoft shared\office" _
         & format(val(application.version), "00") & "\exp_pdf.dll") <> "" then
if fixedfilepathname = "" then
            fileformatstr = "pdf files (*.pdf), *.pdf"
            fname = application.getsaveasfilename(format(now, "yyyy mm dd") & "_" & range("k3") & "_" & range("d6"), filefilter:=fileformatstr, _
                                                  title:="create pdf")
            if fname = false then exit function
        else
            fname = fixedfilepathname
        end if
        if overwriteiffileexist = false then
            if dir(fname) <> "" then exit function
        end if
        on error resume next
        source.exportasfixedformat _
                type:=xltypepdf, _
                filename:=fname, _
                quality:=xlqualitystandard, _
                includedocproperties:=true, _
                ignoreprintareas:=false, _
                openafterpublish:=openpdfafterpublish
        on error goto 0
        if dir(fname) <> "" then rdb_create_pdf = fname
    end if
end function
function rdb_mail_pdf_outlook(filenamepdf as string, strto as string, _
                              strcc as string, strbcc as string, strsubject as string, _
                              signature as boolean, send as boolean, strbody as string)
    dim outapp as object
    dim outmail as object
    set outapp = createobject("outlook.application")
    set outmail = outapp.createitem(0)
    on error resume next
    with outmail
        if signature = true then .display
        .to = strto
        .cc = strcc
        .bcc = strbcc
        .subject = strsubject
        .htmlbody = strbody & "<br>" & .htmlbody
        .attachments.add filenamepdf
        if send = true then
            .send
        else
            .display
        end if
    end with
    on error goto 0

    set outmail = nothing
    set outapp = nothing
end function[/quote]
Klik om te vergroten...
 
Gijsbert1 zei:
Is het niet mogelijk om een representatief voorbeeldbestandje te posten?
De code in je 2e post moet je tussen code tags zetten. Dit is een onleesbare brij geworden zo.

Mijn enige tip is om het woord gealarmeringen, in de zin: "aantal gealarmeringen eenheden", aan te passen.
Klik om te vergroten...

Weer wat geleerd ..top
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan