title image


Smiley Re: Ergänzungen: ...Access97+2003, Anfänger (oT)
A97 und A2003 ist schon mal so eine Sache - in A2003 gibt es das Printer-Objekt, das Handling der Druckerumschaltung ist also ein ganz anderes.



Und wenn du Anfänger bist, ist die Gefahr groß, dass du dich verhebst...



Ich hab dir mal einen Codeteil herausgelöst, der so etwas für den PDF Creator und den PDF Writer (aber nur bis Acrobat 4.0) macht, vielleicht kannst du ja etwas damit anfangen - wenn nicht, ist guter Rat teuer, denn ich habe weder Zeit noch Energie, das jetzt im Detail zu erklären:



Option Compare Database

Option Explicit

Public Const HKEY_CLASSES_ROOT = &H80000000

Public Const HKEY_CURRENT_USER = &H80000001

Public Const HKEY_LOCAL_MACHINE = &H80000002

Public Const HKEY_USERS = &H80000003

Public Const ERROR_SUCCESS = 0&

Public Const ERROR_NO_MORE_ITEMS = 259&

Public Const REG_NONE = 0

Public Const REG_SZ = 1

Public Const REG_EXPAND_SZ = 2

Public Const REG_BINARY = 3

Public Const REG_DWORD = 4

Public Const REG_DWORD_LITTLE_ENDIAN = 4

Public Const REG_DWORD_BIG_ENDIAN = 5

Public Const REG_LINK = 6

Public Const REG_MULTI_SZ = 7

Public Const REG_RESOURCE_LIST = 8

Public Const REG_OPTION_NON_VOLATILE = 0

Public Const KEY_QUERY_VALUE = &H1

Public Const KEY_SET_VALUE = &H2

Public Const KEY_CREATE_SUB_KEY = &H4

Public Const KEY_ENUMERATE_SUB_KEYS = &H8

Public Const KEY_NOTIFY = &H10

Public Const KEY_CREATE_LINK = &H20

Public Const SYNCHRONIZE = &H100000

Public Const STANDARD_RIGHTS_ALL = &H1F0000

Public Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or _

KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or _

KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))



Public Type SECURITY_ATTRIBUTES

nLength As Long

lpSecurityDescriptor As Long

bInheritHandle As Boolean

End Type

Public Declare Function RegCreateKey Lib "advapi32" Alias "RegCreateKeyA" _

(ByVal hKey As Long, _

ByVal lpszSubKey As String, _

phkResult As Long) _

As Long

Public Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" _

(ByVal hKey As Long, _

ByVal lpSubKey As String, _

ByVal Reserved As Long, _

ByVal lpClass As String, _

ByVal dwOptions As Long, _

ByVal samDesired As Long, _

lpSecurityAttributes As Any, _

phkResult As Long, lpdwDisposition As Long) _

As Long



Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _

(ByVal hKey As Long, _

ByVal lpSubKey As String) _

As Long



Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _

(ByVal hKey As Long, _

ByVal lpValueName As String) _

As Long



Public Declare Function RegCloseKey Lib "advapi32.dll" _

(ByVal hKey As Long) _

As Long



Declare Function RegEnumValue Lib "advapi32" Alias "RegEnumValueA" _

(ByVal hKey As Long, _

ByVal iSubKey As Long, _

ByVal lpszName As String, _

cchName As Long, _

dwReserved As Long, _

lpdwType As Long, _

lpbData As Any, _

cbData As Long) _

As Long



Declare Function RegEnumKeyEx Lib "advapi32" Alias "RegEnumKeyA" _

(ByVal hKey As Long, _

ByVal iSubKey As Long, _

ByVal lpszName As String, _

ByVal cchName As Long) _

As Long



Public Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" _

(ByVal hKey As Long, _

ByVal lpszSubKey As String, _

ByVal ulOptions As Long, _

ByVal samDesired As Long, _

phkResult As Long) _

As Long



Public Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" _

(ByVal hKey As Long, _

ByVal lpszValueName As String, _

ByVal dwReserved As Long, _

lpdwType As Long, _

lpbData As Any, _

cbData As Long) _

As Long



Public Declare Function RegSetValueEx Lib "advapi32" Alias "RegSetValueExA" _

(ByVal hKey As Long, _

ByVal lpszValueName As String, _

ByVal dwReserved As Long, _

ByVal fdwType As Long, _

lpbData As Any, _

ByVal cbData As Long) _

As Long



Public Declare Function RegSetStringEx Lib "advapi32" Alias "RegSetValueExA" _

(ByVal hKey As Long, _

ByVal lpszValueName As String, _

ByVal dwReserved As Long, _

ByVal fdwType As Long, _

lpbData As String, _

ByVal cbData As Long) _

As Long



Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long

Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" _

(ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, _

ByVal lpReturnedString As String, ByVal nSize As Long) As Long

Private Declare Function GetProfileSection Lib "kernel32" Alias "GetProfileSectionA" _

(ByVal lpAppName As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long

Private Declare Function WriteProfileString Lib "kernel32" Alias "WriteProfileStringA" _

(ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Long

Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" _

(ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, _

ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" _

(ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, _

ByVal lpFileName As String) As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _

(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, LParam As Any) As Long



Public Const HWND_BROADCAST = &HFFFF&

Public Const WM_WININICHANGE = &H1A



Public Function SetDefaultPrinter(PrName As String)

' Parameter: Druckername

' Rückgabewert: Erfolg der Aktion

Dim Buffer As String, RW, Tmp As String

On Error GoTo Er



Buffer = String(255, 0)

RW = GetProfileString(ByVal "devices", ByVal PrName, ByVal "", Buffer, Len(Buffer))

If RW <= 0 Then

SetDefaultPrinter = False

Exit Function

Else

Tmp = PrName & "," & Mid(Buffer, 1, RW)

End If

' Standarddrucker setzen

RW = WriteProfileString(ByVal "Windows", ByVal "Device", ByVal Tmp)

If RW 1 Then

SetDefaultPrinter = False

Exit Function

End If

' und mitteilen, daß sich die WIN.INI geändert hat

RW = SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0&, 0&)

SetDefaultPrinter = True



Ex:

Exit Function



Er:

MsgBox "SetDefaultPrinter: " & Err.Description

SetDefaultPrinter = False

Resume Ex

End Function

Public Function GetDefaultPrinter()

' Rückgabewert: Standarddrucker

' (In der Form: Druckername,Treibername,Gerätename)

' Z.B. HP LaserJet III,HPPCL5MS,LPT1:

Dim Tmp As String, RW, Res

On Error GoTo Er

Res = ""

Tmp = String(256, 0)

RW = GetProfileString("Windows", "Device", "", Tmp, Len(Tmp))

If RW > 0 Then Res = Mid(Tmp, 1, RW)



Ex:

GetDefaultPrinter = Res

Exit Function

Er:

MsgBox "GetDefaultPrinter: " & Err.Description

Resume Ex

End Function

Public Function GetDefaultPrinterName()

' Rückgabewert: Standarddrucker (Druckername)

Dim Tmp As String, I As Long

On Error GoTo Er



Tmp = GetDefaultPrinter()

I = InStr(Tmp, ",")

If I > 0 Then Tmp = Mid(Tmp, 1, I - 1)



Ex:

GetDefaultPrinterName = Tmp

Exit Function



Er:

MsgBox "GetDefaultPrinterName: " & Err.Description

Resume Ex



End Function

Public Function GetWindowDeviceNames()

Dim Tmp As String, RW, Res As String, Wert As String, I

On Error GoTo Er



Res = ""

Tmp = String(1024, 0)

RW = GetProfileSection("Devices", Tmp, Len(Tmp))

If RW > 0 Then

Wert = Mid(Tmp, 1, RW)

Res = Replace(Wert, Chr(0), ";")

Res = Replace(Res, "=", ",")

End If



Ex:

GetWindowDeviceNames = Res

Exit Function



Er:

MsgBox "GetWindowDeviceNames: " & Err.Description

Resume Ex



End Function

Public Function GetPDFWriter(Optional S = "PDFWriter")

Dim Tmp As String, Res As String, T, I As Long

On Error GoTo Er



T = Split(GetWindowDeviceNames, ";")

For I = LBound(T) To UBound(T)

If InStr(T(I), S) > 0 Then Res = Split(T(I), ",")(0): Exit For

Next I



Ex:

GetPDFWriter = Res

Exit Function



Er:

MsgBox "GetPDFWriter: " & Err.Description

Resume Ex

End Function





Public Function SetRegValue(hKey As Long, KeyPath As String, WhatKey As String, _

SetValue, Optional IsVerbose As Boolean = False)

On Local Error GoTo Er



' Declare local usage variables.

Dim lResult As Long, dwResult As Long, dwType As Long, cbData As Long, I As Integer

Dim varStrData As String, varLngData As Long, MSG, KeyValue



KeyValue = Null



' Open the key's path.

lResult = RegOpenKeyEx(hKey, KeyPath, ByVal 0&, KEY_ALL_ACCESS, dwResult)

If lResult ERROR_SUCCESS Then

If IsVerbose Then

MSG = "Error Opening Registry Key Entry:" & vbCrLf

MSG = MSG & "Key/Path=" & KeyPath & vbCrLf

MSG = MSG & "DLL Returned=" & Format$(lResult)

MsgBox MSG, vbOKOnly Or vbExclamation, "Registry"

End If

GoTo Ex

End If



' Find out the key type.

lResult = RegQueryValueEx(dwResult, WhatKey, ByVal 0&, dwType, ByVal 0&, ByVal 0&)

If lResult = 2 Then ' Key does not exist, create it

If VarType(SetValue) = vbString Then

dwType = REG_SZ

Else

dwType = REG_DWORD

End If

lResult = RegCreateKeyEx(hKey, KeyPath, ByVal 0&, _

dwType, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, _

ByVal 0&, dwResult, lResult)

If lResult ERROR_SUCCESS Then

MSG = "Error Creating Registry Key Entry:" & vbCrLf

MSG = MSG & "Key=" & WhatKey & vbCrLf

MSG = MSG & "DLL Returned=" & Format$(lResult)

MsgBox MSG, vbOKOnly Or vbExclamation, "Registry"

GoTo Ex

End If

ElseIf lResult ERROR_SUCCESS Then

If IsVerbose Then

MSG = "Error Retrieving Registry Key Entry:" & vbCrLf

MSG = MSG & "Key=" & WhatKey & vbCrLf

MSG = MSG & "DLL Returned=" & Format$(lResult)

MsgBox MSG, vbOKOnly Or vbExclamation, "Registry"

End If

lResult = RegCloseKey(dwResult)

GoTo Ex

End If



' Set up passed variables and set value.

Select Case dwType

Case REG_DWORD

varLngData = SetValue

lResult = RegSetValueEx(dwResult, WhatKey, _

ByVal 0&, dwType, _

varLngData, Len(varLngData))

Case REG_SZ

varStrData = SetValue

lResult = RegSetValueEx(dwResult, WhatKey, _

ByVal 0&, dwType, _

ByVal varStrData, Len(varStrData))

End Select

If lResult ERROR_SUCCESS Then

If IsVerbose Then

MSG = "Error Retrieving Registry Key Entry:" & vbCrLf

MSG = MSG & "Key=" & WhatKey & vbCrLf

MSG = MSG & "DLL Returned=" & Format$(lResult)

MsgBox MSG, vbOKOnly Or vbExclamation, "Registry"

End If

lResult = RegCloseKey(dwResult)

GoTo Ex

End If



' Close key.

lResult = RegCloseKey(dwResult)



' Select data type (for the needed types used in the values) and assign value.

Select Case dwType

Case REG_SZ

KeyValue = Mid$(varStrData, 1, cbData)

If InStr(KeyValue, Chr(0)) > 0 Then _

KeyValue = Mid$(KeyValue, 1, InStr(KeyValue, Chr(0)) - 1)

Case REG_DWORD

KeyValue = varLngData

End Select

'Debug.Print KeyValue



Ex:

On Error Resume Next

SetRegValue = KeyValue

Exit Function



Er:

MsgBox "SetRegValue: " & Err.Description

Resume Ex

End Function

Public Function GetRegValue(hKey As Long, KeyPath As String, WhatKey As String, Optional IsVerbose As Boolean = False)

On Local Error GoTo Er



' Declare local usage variables.

Dim lResult As Long, dwResult As Long, dwType As Long, cbData As Long, I As Integer

Dim varStrData As String, varLngData As Long, MSG, KeyValue



KeyValue = Null



' Open the key's path.

lResult = RegOpenKeyEx(hKey, KeyPath, ByVal 0&, KEY_ALL_ACCESS, dwResult)

If lResult ERROR_SUCCESS Then

If IsVerbose Then

MSG = "Error Opening Registry Key Entry:" & vbCrLf

MSG = MSG & "Key/Path=" & KeyPath & vbCrLf

MSG = MSG & "DLL Returned=" & Format$(lResult)

MsgBox MSG, vbOKOnly Or vbExclamation, "Registry"

End If

GoTo Ex

End If



' Find out the key type.

lResult = RegQueryValueEx(dwResult, WhatKey, ByVal 0&, dwType, ByVal 0&, ByVal 0&)

If lResult ERROR_SUCCESS Then

If IsVerbose Then

MSG = "Error Retrieving Registry Key Entry:" & vbCrLf

MSG = MSG & "Key=" & WhatKey & vbCrLf

MSG = MSG & "DLL Returned=" & Format$(lResult)

MsgBox MSG, vbOKOnly Or vbExclamation, "Registry"

End If

lResult = RegCloseKey(dwResult)

GoTo Ex

End If



' Set up passed variables and retrieve value.

Select Case dwType

Case REG_SZ

varStrData = String$(255, 0)

cbData = Len(varStrData)

lResult = RegQueryValueEx(dwResult, WhatKey, ByVal 0&, _

dwType, ByVal varStrData, cbData)

Case REG_DWORD

varLngData = False

cbData = Len(varLngData)

lResult = RegQueryValueEx(dwResult, WhatKey, ByVal 0&, _

dwType, varLngData, cbData)

End Select

If lResult ERROR_SUCCESS Then

If IsVerbose Then

MSG = "Error Retrieving Registry Key Entry:" & vbCrLf

MSG = MSG & "Key=" & WhatKey & vbCrLf

MSG = MSG & "DLL Returned=" & Format$(lResult)

MsgBox MSG, vbOKOnly Or vbExclamation, "Registry"

End If

lResult = RegCloseKey(dwResult)

GoTo Ex

End If



' Close key.

lResult = RegCloseKey(dwResult)



' Select data type (for the needed types used in the values) and assign value.

Select Case dwType

Case REG_SZ

KeyValue = Mid$(varStrData, 1, cbData)

If InStr(KeyValue, Chr(0)) > 0 Then _

KeyValue = Mid$(KeyValue, 1, InStr(KeyValue, Chr(0)) - 1)

Case REG_DWORD

KeyValue = varLngData

End Select

'Debug.Print KeyValue



Ex:

On Error Resume Next

GetRegValue = KeyValue

Exit Function



Er:

MsgBox "GetRegValue: " & Err.Description

Resume Ex

End Function



Public Function GetAdobeStartDocTitle()

GetAdobeStartDocTitle = GetRegValue(HKEY_CURRENT_USER, "Software\Adobe\Acrobat PDFWriter", "StartDocTitle")

End Function

Public Function GetAdobePDFFileName()

GetAdobeStartDocTitle = GetRegValue(HKEY_CURRENT_USER, "Software\Adobe\Acrobat PDFWriter", "PDFFileName")

End Function

Public Function SetAdobePDFFileName(S As String)

SetRegValue HKEY_CURRENT_USER, "Software\Adobe\Acrobat PDFWriter", "PDFFileName", S

End Function



Public Function GetPDFCreatorFileName()

Dim F As String, Lg As Long, Buf As String, Res As String

Buf = String(255, 0)

F = GetSpecFolder(CSIDL_APPDATA) & "\PDFCreator\PDFCreator.INI"

Lg = GetPrivateProfileString("Options", "AutosaveDirectory", "", Buf, Len(Buf), F)

Res = Left(Buf, Lg)

Lg = GetPrivateProfileString("Options", "AutosaveFilename", "", Buf, Len(Buf), F)

Res = Res & Left(Buf, Lg)

GetPDFCreatorFileName = Res

End Function

Public Function SetPDFCreatorFileName(FullPath As String)

Dim F As String, Path As String, FName As String, I As Long

I = InStrRev(FullPath, "\")

FName = Mid(FullPath, I + 1)

Path = Left(FullPath, I)

I = InStrRev(FName, ".")

If I > 0 Then FName = Left(FName, I - 1)

F = GetSpecFolder(CSIDL_APPDATA) & "\PDFCreator\PDFCreator.INI"

WritePrivateProfileString "Options", "AutosaveDirectory", Path, F

WritePrivateProfileString "Options", "AutosaveFilename", FName, F

End Function

Public Function ss()

SetRegValue HKEY_CURRENT_USER, "Software\Adobe\Acrobat Distiller\4.0", "AskForPdfFileName", 1

End Function



Public Function PrintOnPDFWriter(FName As String, RptName As String, Krit As String)

Dim Tmp As String, PDFP As String, Merk As String

PDFP = GetPDFWriter("PDFWriter")

If PDFP = "" Then

PDFP = GetPDFWriter("PDFCreator")

If PDFP = "" Then

MsgBox "Keine PDF Ausgabe gefunden!", vbExclamation

Else

On Error Resume Next

Tmp = GetDefaultPrinter()

SetDefaultPrinter PDFP

Merk = GetPDFCreatorFileName

SetPDFCreatorFileName FName

DoCmd.OpenReport RptName, , , Krit

SetPDFCreatorFileName Merk

SetDefaultPrinter Tmp

End If

Else

On Error Resume Next

Tmp = GetDefaultPrinter()

SetDefaultPrinter PDFP

SetAdobePDFFileName FName

DoCmd.OpenReport RptName, , , Krit

SetAdobePDFFileName ""

SetDefaultPrinter Tmp

End If

End Function





Gruß aus dem Norden
Reinhard


Bitte immer die Access-Version angeben!
DB-Wiki


Wie man Fragen richtig stellt

YaccessAccess-FAQUnd ansonsten: Wikipedia




geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: