Καλημέρα,
Παρακάτω είναι ένα ενδεικτικό παράδειγμα εξαγωγής Access Report σε PDF.
Στο παράδειγμα ενεργοποιώ προσωρινά την επιλογή PDF/A. Δεν το κάνω επειδή είναι υποχρεωτικό για κάθε export, αλλά επειδή εδώ θέλουμε να ελέγξουμε αν το πρόβλημα με τη γραμματοσειρά σχετίζεται με το font embedding.
Το PDF/A είναι μορφή PDF για αρχειοθέτηση και προσπαθεί να δημιουργήσει ένα πιο αυτοτελές PDF, το οποίο να μπορεί να εμφανιστεί σωστά και σε άλλο υπολογιστή. Για αυτό συνήθως γίνεται πιο αυστηρή ενσωμάτωση των γραμματοσειρών μέσα στο PDF.
Άρα, αν το report φαίνεται σωστά στην οθόνη, αλλά στο PDF/A ή στην εκτύπωση συνεχίζει να χάνει τα Bold ή άλλα variants της Inter, τότε το πρόβλημα δεν φαίνεται να είναι στην Access ή στον συγκεκριμένο κώδικα. Πιθανότερα είναι θέμα της γραμματοσειράς, των εγκατεστημένων font variants, του font embedding, του PDF rendering ή του printer driver.
Με απλά λόγια: το PDF/A εδώ χρησιμοποιείται σαν διαγνωστική δοκιμή για να δούμε αν η Inter ενσωματώνεται σωστά στο PDF.
Κώδικας:
Option Compare Database
Option Explicit
Private Sub cmdEksagogiSePDF_Click()
Const ONOMA_REPORT As String = "rptBEU"
Const REG_PDF_A As String = "HKCU\Software\Microsoft\Office\16.0\Common\FixedFormat\LastISO19005-1"
Dim diadromiTelikouPDF As String
Dim diadromiProsorinouPDF As String
Dim onomaProsorinouPDF As String
Dim vasikoOnomaArxeiou As String
Dim imerominiaOra As String
Dim paliaTimiRegistry As Variant
Dim ypirxePaliaTimiRegistry As Boolean
Dim shellWindows As Object
Dim systimaArxeion As Object
Dim whereReport As String
Dim openArgsReport As String
On Error GoTo DiaxeirisiLathous
Set shellWindows = CreateObject("WScript.Shell")
Set systimaArxeion = CreateObject("Scripting.FileSystemObject")
' ------------------------------------------------------------
' Ελληνικό όνομα αρχείου για το PDF.
' Εδώ βάζουμε ένα ενδεικτικό όνομα για τη δοκιμή.
' ------------------------------------------------------------
vasikoOnomaArxeiou = "Δοκιμή_γραμματοσειράς_Inter"
If Len(Trim$(vasikoOnomaArxeiou)) > 0 Then
vasikoOnomaArxeiou = KathariseOnomaArxeiou(vasikoOnomaArxeiou)
Else
vasikoOnomaArxeiou = "Αναφορά"
End If
' ------------------------------------------------------------
' Αν θέλουμε φίλτρο στο report, το βάζουμε εδώ.
'
' Παράδειγμα για αριθμητικό MainID:
' whereReport = "MainID=" & Me!MainID
'
' Για απλό παράδειγμα χωρίς φίλτρο:
' ------------------------------------------------------------
whereReport = vbNullString
' ------------------------------------------------------------
' Αν το report χρησιμοποιεί OpenArgs, τα βάζουμε εδώ.
' Αν δεν χρειάζονται, μπορεί να μείνει κενό.
' ------------------------------------------------------------
openArgsReport = "hidden;0;()"
' ------------------------------------------------------------
' Κρατάμε την παλιά ρύθμιση PDF/A από το Registry,
' ώστε να την επαναφέρουμε μετά το export.
' ------------------------------------------------------------
On Error Resume Next
paliaTimiRegistry = shellWindows.RegRead(REG_PDF_A)
ypirxePaliaTimiRegistry = (Err.Number = 0)
Err.Clear
On Error GoTo DiaxeirisiLathous
' ------------------------------------------------------------
' Ενεργοποιούμε προσωρινά το PDF/A.
'
' Δεν είναι απαραίτητο για κάθε export.
' Εδώ το χρησιμοποιούμε σαν διαγνωστική δοκιμή
' για το πρόβλημα της γραμματοσειράς.
'
' Το PDF/A προσπαθεί να δημιουργήσει πιο αυτοτελές PDF,
' όπου οι γραμματοσειρές πρέπει να ενσωματώνονται σωστά.
'
' Αν ακόμα και με PDF/A χάνονται τα Bold ή άλλα variants
' της Inter, τότε το πρόβλημα πιθανότατα δεν είναι στην Access,
' αλλά στη γραμματοσειρά, στο font embedding, στο PDF rendering
' ή στον printer driver.
' ------------------------------------------------------------
shellWindows.RegWrite REG_PDF_A, 1, "REG_DWORD"
' ------------------------------------------------------------
' Άνοιγμα του report σε Preview, αλλά κρυφό.
' Το ανοίγουμε πρώτα, ώστε το OutputTo να εξάγει
' ακριβώς αυτό το report.
' ------------------------------------------------------------
DoCmd.OpenReport ONOMA_REPORT, acViewPreview, , whereReport, acHidden, openArgsReport
' ------------------------------------------------------------
' Δημιουργία μοναδικού ελληνικού ονόματος PDF
' με ημερομηνία και ώρα.
' ------------------------------------------------------------
imerominiaOra = Format(Now, "yyyy-mm-dd_hh-nn-ss")
onomaProsorinouPDF = vasikoOnomaArxeiou & _
"_Παράδειγμα_εκτύπωσης_PDF_" & _
imerominiaOra & ".pdf"
' ------------------------------------------------------------
' Επιλογή τελικής διαδρομής αποθήκευσης από τον χρήστη.
' ------------------------------------------------------------
diadromiTelikouPDF = EpilogiDiadromisPDF(onomaProsorinouPDF)
If Len(diadromiTelikouPDF) > 0 Then
' --------------------------------------------------------
' Δημιουργία προσωρινής διαδρομής PDF στον Temp φάκελο.
' 2 = TemporaryFolder
' --------------------------------------------------------
diadromiProsorinouPDF = systimaArxeion.BuildPath( _
systimaArxeion.GetSpecialFolder(2), _
onomaProsorinouPDF)
' --------------------------------------------------------
' Αν υπάρχει ήδη προσωρινό αρχείο με το ίδιο όνομα,
' το διαγράφουμε.
' --------------------------------------------------------
If systimaArxeion.FileExists(diadromiProsorinouPDF) Then
systimaArxeion.DeleteFile diadromiProsorinouPDF, True
End If
' --------------------------------------------------------
' Εξαγωγή του report σε προσωρινό PDF.
' --------------------------------------------------------
DoCmd.OutputTo acOutputReport, ONOMA_REPORT, acFormatPDF, diadromiProsorinouPDF, False
' --------------------------------------------------------
' Αν υπάρχει ήδη τελικό PDF με το ίδιο όνομα,
' το αντικαθιστούμε.
' --------------------------------------------------------
If systimaArxeion.FileExists(diadromiTelikouPDF) Then
systimaArxeion.DeleteFile diadromiTelikouPDF, True
End If
' --------------------------------------------------------
' Αντιγραφή του προσωρινού PDF στην τελική θέση.
' --------------------------------------------------------
systimaArxeion.CopyFile diadromiProsorinouPDF, diadromiTelikouPDF, True
' --------------------------------------------------------
' Άνοιγμα του τελικού PDF.
' --------------------------------------------------------
Application.FollowHyperlink diadromiTelikouPDF
End If
Katharisma:
On Error Resume Next
' ------------------------------------------------------------
' Κλείσιμο του report χωρίς αποθήκευση αλλαγών.
' ------------------------------------------------------------
DoCmd.Close acReport, ONOMA_REPORT, acSaveNo
' ------------------------------------------------------------
' Διαγραφή προσωρινού PDF.
' ------------------------------------------------------------
If Len(diadromiProsorinouPDF) > 0 Then
If Not systimaArxeion Is Nothing Then
If systimaArxeion.FileExists(diadromiProsorinouPDF) Then
systimaArxeion.DeleteFile diadromiProsorinouPDF, True
End If
End If
End If
' ------------------------------------------------------------
' Επαναφορά της παλιάς ρύθμισης PDF/A στο Registry.
' Αν πριν υπήρχε τιμή, την επαναφέρουμε.
' Αν δεν υπήρχε, διαγράφουμε τη δική μας προσωρινή τιμή.
' ------------------------------------------------------------
If Not shellWindows Is Nothing Then
If ypirxePaliaTimiRegistry Then
shellWindows.RegWrite REG_PDF_A, paliaTimiRegistry, "REG_DWORD"
Else
shellWindows.RegDelete REG_PDF_A
End If
End If
Set systimaArxeion = Nothing
Set shellWindows = Nothing
Exit Sub
DiaxeirisiLathous:
MsgBox "Η εξαγωγή σε PDF απέτυχε:" & vbCrLf & _
Err.Number & " - " & Err.Description, _
vbExclamation, "Εξαγωγή PDF"
Resume Katharisma
End Sub
Private Function EpilogiDiadromisPDF(ByVal proepilegmenoOnomaArxeiou As String) As String
Const msoFileDialogSaveAs As Long = 2
Dim dialogosApothikefsis As Object
Dim epilegmeniDiadromi As String
Dim fakelosDesktop As String
On Error GoTo DiaxeirisiLathous
fakelosDesktop = Environ$("USERPROFILE") & "\Desktop\"
Set dialogosApothikefsis = Application.FileDialog(msoFileDialogSaveAs)
With dialogosApothikefsis
.Title = "Αποθήκευση παραδείγματος PDF"
.InitialFileName = fakelosDesktop & proepilegmenoOnomaArxeiou
If .Show = -1 Then
epilegmeniDiadromi = .SelectedItems(1)
' Αν ο χρήστης δεν έβαλε κατάληξη .pdf,
' την προσθέτουμε αυτόματα.
If LCase$(Right$(epilegmeniDiadromi, 4)) <> ".pdf" Then
epilegmeniDiadromi = epilegmeniDiadromi & ".pdf"
End If
EpilogiDiadromisPDF = epilegmeniDiadromi
Else
' Ο χρήστης πάτησε Cancel.
EpilogiDiadromisPDF = vbNullString
End If
End With
Set dialogosApothikefsis = Nothing
Exit Function
DiaxeirisiLathous:
EpilogiDiadromisPDF = vbNullString
Set dialogosApothikefsis = Nothing
End Function
Private Function KathariseOnomaArxeiou(ByVal onomaArxeiou As String) As String
Dim miEpitreptoiXaraktires As Variant
Dim xaraktiras As Variant
onomaArxeiou = Trim$(onomaArxeiou)
' Χαρακτήρες που δεν επιτρέπονται σε ονόματα αρχείων Windows.
miEpitreptoiXaraktires = Array("\", "/", ":", "*", "?", """", "<", ">", "|")
' Αντικατάσταση μη επιτρεπτών χαρακτήρων με κάτω παύλα.
For Each xaraktiras In miEpitreptoiXaraktires
onomaArxeiou = Replace(onomaArxeiou, xaraktiras, "_")
Next xaraktiras
' Αντικατάσταση αλλαγών γραμμής και tab.
onomaArxeiou = Replace(onomaArxeiou, vbCrLf, "_")
onomaArxeiou = Replace(onomaArxeiou, vbCr, "_")
onomaArxeiou = Replace(onomaArxeiou, vbLf, "_")
onomaArxeiou = Replace(onomaArxeiou, vbTab, "_")
' Αφαίρεση διπλών κάτω παυλών.
Do While InStr(onomaArxeiou, "__") > 0
onomaArxeiou = Replace(onomaArxeiou, "__", "_")
Loop
' Αφαίρεση τελικής τελείας ή κενού,
' γιατί τα Windows δεν τα θέλουν στο τέλος ονόματος αρχείου.
Do While Len(onomaArxeiou) > 0 And _
(Right$(onomaArxeiou, 1) = "." Or Right$(onomaArxeiou, 1) = " ")
onomaArxeiou = Left$(onomaArxeiou, Len(onomaArxeiou) - 1)
Loop
' Αν μετά τον καθαρισμό έμεινε κενό,
' βάζουμε γενικό όνομα.
If Len(onomaArxeiou) = 0 Then
onomaArxeiou = "Αναφορά"
End If
' Περιορισμός μήκους ονόματος.
If Len(onomaArxeiou) > 120 Then
onomaArxeiou = Left$(onomaArxeiou, 120)
End If
KathariseOnomaArxeiou = onomaArxeiou
End Function