1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
| Option Compare Database
Option Explicit
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal lngHKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal lngHKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, lpcbData As Long) As Long
Private Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal lngHKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Private Declare Function RegQueryValueExBinary Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal lngHKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
Private Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal lngHKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, ByVal lpData As Long, lpcbData As Long) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal lngHKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal lngHKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Private Declare Function RegSetValueExBinary Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal lngHKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As Long, ByVal cbData As Long) As Long
Private Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal lngHKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
Private Declare Function RegQueryInfoKey Lib "advapi32.dll" Alias "RegQueryInfoKeyA" (ByVal lngHKey As Long, ByVal lpClass As String, ByVal lpcbClass As Long, ByVal lpReserved As Long, lpcSubKeys As Long, lpcbMaxSubKeyLen As Long, ByVal lpcbMaxClassLen As Long, lpcValues As Long, lpcbMaxValueNameLen As Long, ByVal lpcbMaxValueLen As Long, ByVal lpcbSecurityDescriptor As Long, lpftLastWriteTime As FILETIME) As Long
Private Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal lngHKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, ByVal lpType As Long, ByVal lpData As Byte, ByVal lpcbData As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal lngHKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal lngHKey As Long, ByVal lpValueName As String) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal lngHKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal lngHKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
Private Const MCREGKEYALLACCESS = &H3F
Private Const MCREGKEYQUERYVALUE = &H1
Private Const mcregOptionNonVolatile = 0
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Enum EnumRegistryRootKeys
rootHKeyClassesRoot = &H80000000
rootHKeyCurrentUser = &H80000001
rootHKeyLocalMachine = &H80000002
rootHKeyUsers = &H80000003
End Enum
Public Enum EnumRegistryValueType
RRKREGSZ = 1
RRKREGBINARY = 3
RRKREGDWORD = 4
End Enum
Public Function fnctGetDefaultPrinter() As String
Dim nSize As Integer
Dim strPrinterName As String
Dim successReturn&
Dim iPos1 As Integer, iPos2 As Integer
nSize = 81
strPrinterName = Space(nSize)
successReturn = GetProfileString("windows", "device", vbNullString, strPrinterName, nSize)
strPrinterName = Left(strPrinterName, successReturn)
iPos1 = InStr(1, strPrinterName, ",")
iPos2 = InStr(iPos1 + 1, strPrinterName, ",")
strPrinterName = Left(strPrinterName, iPos1 - 1)
fnctGetDefaultPrinter = strPrinterName
End Function
Private Sub subGetDriverAndPort(ByVal Buffer As String, ByRef DriverName As String, ByRef PrinterPort As String)
Dim posDriver As Integer
Dim posPort As Integer
DriverName = vbNullString
PrinterPort = vbNullString
posDriver = InStr(Buffer, ",")
If posDriver > 0 Then
DriverName = Left(Buffer, posDriver - 1)
posPort = InStr(posDriver + 1, Buffer, ",")
If posPort > 0 Then
PrinterPort = Mid(Buffer, posDriver + 1, posPort - posDriver - 1)
End If
End If
End Sub
Private Sub SetDefaultPrinter(ByVal PrinterName As String)
Dim Buffer As String
Dim DeviceName As String
Dim DriverName As String
Dim PrinterPort As String
Dim DeviceLine As String
Buffer = Space(1024)
Call GetProfileString("PrinterPorts", PrinterName, vbNullString, Buffer, Len(Buffer))
subGetDriverAndPort Buffer, DriverName, PrinterPort
If (DriverName <> vbNullString) And (PrinterPort <> vbNullString) Then
DeviceLine = PrinterName & "," & DriverName & "," & PrinterPort
Call WriteProfileString("windows", "Device", DeviceLine)
End If
End Sub
'Création du PDF:
Private Sub subCreatePDFFromReport(ByVal ReportName As String, ByVal PDFFileName As String)
Dim originalprinter As Variant
originalprinter = fnctGetDefaultPrinter()
SetDefaultPrinter "Acrobat PDFWriter"
subRegistrySetKeyValue rootHKeyCurrentUser, "Software\Adobe\Acrobat PDFWriter\", "PDFFileName", PDFFileName, RRKREGSZ
DoCmd.OpenReport ReportName, 0
SetDefaultPrinter originalprinter
End Sub
'Informations supplémentaires:
'subRegistrySetKeyValue est une procédure pour écrire une valeur dans la Registre
Public Sub subRegistrySetKeyValue(ByVal RootKey As EnumRegistryRootKeys, ByVal KeyName As String, ByVal ValueName As String, ByVal varData As Variant, ByVal DataType As EnumRegistryValueType)
Dim lReturn As Long
Dim lHKey As Long
Dim sData As String
Dim lData As Long
Dim aData() As Byte
On Error GoTo L_ErrRegistryOperation
lReturn = RegCreateKeyEx(RootKey, KeyName, 0&, vbNullString, mcregOptionNonVolatile, MCREGKEYALLACCESS, 0&, lHKey, 0&)
Select Case DataType
Case RRKREGSZ
sData = varData & vbNullChar
lReturn = RegSetValueExString(lHKey, ValueName, 0&, DataType, sData, Len(sData))
Case RRKREGDWORD
lData = varData
lReturn = RegSetValueExLong(lHKey, ValueName, 0&, DataType, lData, Len(lData))
Case RRKREGBINARY
aData = varData
lReturn = RegSetValueExBinary(lHKey, ValueName, 0&, DataType, VarPtr(aData(0)), UBound(aData) + 1)
End Select
RegCloseKey (lHKey)
L_ExRegistryOperation:
Erase aData
Exit Sub
L_ErrRegistryOperation:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , "subRegistrySetKeyValue"
Resume L_ExRegistryOperation
End Sub
Private Sub Command3_Click()
On Error GoTo Err_Command3_Click
Dim stDocName As String
Dim rst As DAO.Recordset
Set rst = Me.RecordsetClone
While Not rst.EOF
subCreatePDFFromReport "Details SDS report-Generation-file", "c:\" & Me.AppID & ".pdf"
Me.Form.Recordset.MoveNext
Wend
Me.Form.Recordset.MoveFirst
Exit_Command3_Click:
Exit Sub
Err_Command3_Click:
MsgBox Err.Description
Resume Exit_Command3_Click
End Sub |
Generation de PDF
Répondre avec citation
Envoyé par stephv
Partager