Newsgroup: it.comp.appl.access
Titolo: Problemi con cambio stampante per invio fax o creazione pdf

S.O. WinXP, Microsoft Access 2000.
Non funziona in nessuno dei due casi di cambio stampante nella funzione Test
.... perchè ? (vedi codice sottostante)
Grazie a chiunque volesse aiutarmi.
    Ciao da Mauro
Private Const GMEM_MOVEABLE As Long = &H2
Private Const GMEM_DDESHARE As Long = &H2000
Private Const GMEM_ZEROINIT As Long = &H40
Private Const GHND As Long = (GMEM_MOVEABLE Or GMEM_DDESHARE Or
GMEM_ZEROINIT)
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
Private Const MAX_SIZE = 255
Private Const MAX_SECTION = 2048
Private Declare Function aht_apiGetPrivateProfileInt Lib "kernel32" Alias
"GetPrivateProfileInt" (ByVal strAppName As String, ByVal strKeyName As
String, ByVal intDefault As Integer, ByVal strFileName As String) As Integer
Private Declare Function aht_apiGetPrivateProfileString Lib "kernel32" Alias
"GetPrivateProfileStringA" (ByVal strAppName As String, ByVal strKeyName As
String, ByVal strDefault As String, ByVal strReturned As String, ByVal
lngSize As Long, ByVal strFileName As String) As Long
Private Declare Function aht_apiGetProfileString Lib "kernel32" Alias
"GetProfileStringA" (ByVal strAppName As String, ByVal strKeyName As String,
ByVal strDefault As String, ByVal strReturned As String, ByVal lngSize As
Long) As Long
Private Declare Function aht_apiGetProfileInt Lib "kernel32" Alias
"GetProfileInt" (ByVal strAppName As String, ByVal strKeyName As String,
ByVal intDefault As Integer) As Integer
Private Declare Function aht_apiGetProfileSection Lib "kernel32" Alias
"GetProfileSectionA" (ByVal lpAppName As String, ByVal lpReturnedString As
String, ByVal nSize As Long) As Long
Private Declare Function aht_apiGetPrivateProfileSection Lib "kernel32"
Alias "GetPrivateProfileSectionA" (ByVal lpAppName As String, ByVal
lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String)
As Long
Private Declare Function aht_apiWritePrivateProfileString Lib "kernel32"
Alias "WritePrivateProfileStringA" (ByVal strAppName As String, ByVal
strKeyName As String, ByVal strValue As String, ByVal strFileName As String)
As Integer
Private Declare Function aht_apiWriteProfileString Lib "kernel32" Alias
"WriteProfileStringA" (ByVal strAppName As String, ByVal strKeyName As
String, ByVal strValue As String) As Integer
Type aht_tagDeviceRec
   drDeviceName As String
   drDriverName As String
   drPort As String
End Type
Type aht_tagDEVMODE
   dmDeviceName(1 To 32) As Byte
   dmSpecVersion As Integer
   dmDriverVersion As Integer
   dmSize As Integer
   dmDriverExtra As Integer
   dmFields As Long
   dmOrientation As Integer
   dmPaperSize As Integer
   dmPaperLength As Integer
   dmPaperWidth As Integer
   dmScale As Integer
   dmCopies As Integer
   dmDefaultSource As Integer
   dmPrintQuality As Integer
   dmColor As Integer
   dmDuplex As Integer
   dmYResolution As Integer
   dmTTOption As Integer
   dmCollate As Integer
   dmFormName(1 To 32) As Byte
   dmLogPixels As Integer
   dmBitsPerPixel As Long
   dmPelsWidth As Long
   dmPelsHeight As Long
   dmDisplayFlags As Long
   dmDisplayFrequency As Long
   dmICMMethod As Long
   dmICMIntent As Long
   dmMediaType As Long
   dmDitherType As Long
   dmICCManufacturer As Long
   dmICCModel As Long
   dmDriverExtraBytes(1 To 1024) As Byte
End Type
Type aht_tagDEVMODEStr
   DMStr As String * 1024
End Type
Type aht_tagDEVNAMES
   dnDriverOffset As Integer
   dnDeviceOffset As Integer
   dnOutputOffset As Integer
   dnDefault As Integer
End Type
Type aht_tagDEVNAMEStr
   DNStr As String * 4
End Type
Type aht_tagMIP
   xLeftMargin As Long
   yTopMargin As Long
   xRightMargin As Long
   yBotMargin As Long
   fDataOnly As Long
   xFormSize As Long
   yFormSize As Long
   fDefaultSize As Long
   cxColumns As Long
   xFormSpacing As Long
   yFormSpacing As Long
   radItemOrder As Long
   fFastPrinting As Long
   fDataSheet As Long
End Type
Type aht_tagMIPSTR
   MIPStr As String * 28
End Type
Public Function Test(StampanteSelezionata As Integer, Funzione As Integer)
    Dim StampAttuale As String
    Dim TipoStampante As String
    Select Case StampanteSelezionata
        Case 1
            TipoStampante = "WinFax"
        Case 2
            TipoStampante = "PDF995"
    End Select
    Select Case Funzione
        Case 1
            StampAttuale = GetDefaultPrinter()
            If SetDefaultPrinter(Nz(TipoStampante, "")) = False Then Exit
Function
            MsgBox "Stampante predefinita: " & StampAttuale & vbCrLf &
"Stampante selezionata : " & GetDefaultPrinter()
            DoCmd.RunCommand acCmdPrint
            Call SetDefaultPrinterEx(StampAttuale)
        Case 2
            StampAttuale = GetDefaultPrinter()
            StampAttuale = Left(StampAttuale, InStr(1, StampAttuale, ",",
vbTextCompare) - 1)
            If SetDefaultPrinter2(Nz(TipoStampante, "")) = False Then Exit
Function
            MsgBox "Stampante predefinita: " & StampAttuale & vbCrLf &
"Stampante selezionata : " & GetDefaultPrinter()
            DoCmd.RunCommand acCmdPrint
            Call SetDefaultPrinter2(StampAttuale)
    End Select
End Function
Function ahtGetDefaultPrinter(dr As aht_tagDeviceRec) As Boolean
    Dim strBuffer As String
    strBuffer = ahtGetINIString("Windows", "Device")
    If Len(strBuffer) > 0 Then
        With dr
            .drDeviceName = ahtGetToken(strBuffer, ",", 1)
            .drDriverName = ahtGetToken(strBuffer, ",", 2)
            .drPort = ahtGetToken(strBuffer, ",", 3)
        End With
        ahtGetDefaultPrinter = True
    Else
        ahtGetDefaultPrinter = False
    End If
End Function
Function ahtSetDefaultPrinter(dr As aht_tagDeviceRec) As Boolean
   Dim strBuffer As String
   strBuffer = dr.drDeviceName & ","
   strBuffer = strBuffer & dr.drDriverName & ","
   strBuffer = strBuffer & dr.drPort
   ahtSetDefaultPrinter = (aht_apiWriteProfileString("Windows", "Device",
strBuffer) <> 0)
End Function
Function ahtFillPrinterList(Ctl As Control, varID As Variant, varRow As
Variant, varCol As Variant, varCode As Variant)
    Static atagDevices() As aht_tagDeviceRec
    Static intCount As Integer
    Dim varRetval As Variant
    Select Case varCode
        Case acLBInitialize
            intCount = ahtGetPrinterList(atagDevices())
            varRetval = True
        Case acLBOpen
            varRetval = Timer
        Case acLBGetRowCount
            varRetval = intCount
        Case acLBGetColumnCount
            varRetval = 1
        Case acLBGetValue
            varRetval = atagDevices(varRow + 1).drDeviceName & " on " &
atagDevices(varRow + 1).drPort
       Case acLBEnd
            Erase atagDevices
    End Select
    ahtFillPrinterList = varRetval
End Function
Function ahtGetPrinterList(atagDevices() As aht_tagDeviceRec) As Integer
    Dim astrPrinters() As String
    Dim intCount As Integer
    Dim varPrinters As Variant
    varPrinters = ahtGetProfileSection("DEVICES")
    If Len(varPrinters & "") = 0 Then
        ahtGetPrinterList = 0
    Else
        intCount = GetDevices(varPrinters, atagDevices())
    End If
    ahtGetPrinterList = intCount
End Function
Private Function GetDevices(ByVal strPrinters As String, atagDevices() As
aht_tagDeviceRec) As Integer
    Dim intI As Integer
    Dim strBuffer As String
    Dim intCount As Integer
    For intI = 1 To Len(strPrinters)
        If Mid$(strPrinters, intI, 1) = Chr$(0) Then
            intCount = intCount + 1
        End If
    Next intI
    ReDim atagDevices(1 To intCount)
    For intI = 1 To intCount
        strBuffer = ahtGetToken(strPrinters, Chr$(0), intI)
        atagDevices(intI).drDeviceName = ahtGetToken(strBuffer, "=", 1)
        strBuffer = ahtGetToken(strBuffer, "=", 2)
        atagDevices(intI).drDriverName = ahtGetToken(strBuffer, ",", 1)
        atagDevices(intI).drPort = ahtGetToken(strBuffer, ",", 2)
    Next intI
    GetDevices = intCount
End Function
Function ahtGetINIInt(ByVal strGroup As String, ByVal strItem As String) As
Variant
    ahtGetINIInt = aht_apiGetProfileInt(strGroup, strItem, -1)
End Function
Function ahtGetINIString(ByVal strGroup As String, ByVal strItem As String)
As Variant
    Dim intChars As Integer
    Dim strBuffer As String
    strBuffer = String(MAX_SIZE, 0)
    intChars = aht_apiGetProfileString(strGroup, strItem, "", strBuffer,
MAX_SIZE)
    ahtGetINIString = Left(strBuffer, intChars)
End Function
Function ahtGetPrivateINIInt(ByVal strGroup As String, ByVal strItem As
String, ByVal strFile As String) As Variant
    ahtGetPrivateINIInt = aht_apiGetPrivateProfileInt(strGroup, strItem, -1,
strFile)
End Function
Function ahtGetPrivateIniString(ByVal strGroup As String, ByVal strItem As
String, ByVal strFile As String) As Variant
    Dim intChars As Integer
    Dim strBuffer As String
    strBuffer = String(MAX_SIZE, 0)
    intChars = aht_apiGetPrivateProfileString(strGroup, strItem, "",
strBuffer, MAX_SIZE, strFile)
    ahtGetPrivateIniString = Left(strBuffer, intChars)
End Function
Function ahtGetProfileSection(ByVal strGroup As String) As Variant
    Dim strBuffer As String
    Dim intCount As Integer
    strBuffer = Space(MAX_SECTION)
    intCount = aht_apiGetProfileSection(strGroup, strBuffer, MAX_SECTION)
    ahtGetProfileSection = Left(strBuffer, intCount)
End Function
Function ahtGetPrivateProfileSection(ByVal strGroup As String, ByVal strFile
As String) As Variant
    Dim strBuffer As String
    Dim intCount As Integer
    strBuffer = Space(MAX_SECTION)
    intCount = aht_apiGetPrivateProfileSection(strGroup, strBuffer,
MAX_SECTION, strFile)
    ahtGetPrivateProfileSection = Left(strBuffer, intCount)
End Function
Function ahtGetToken(ByVal strValue As String, ByVal strDelimiter As String,
ByVal intPiece As Integer) As Variant
    Dim intPos As Integer
    Dim intLastPos As Integer
    Dim intNewPos As Integer
    On Local Error GoTo ahtGetTokenExit
    strDelimiter = Left(strDelimiter, 1)
    If (InStr(strValue, strDelimiter) = 0) Or (intPiece <= 0) Then
        ahtGetToken = strValue
    Else
        intPos = 0
        intLastPos = 0
        Do While intPiece > 0
            intLastPos = intPos
            intNewPos = InStr(intPos + 1, strValue, strDelimiter)
            If intNewPos > 0 Then
                intPos = intNewPos
                intPiece = intPiece - 1
            Else
                intPos = Len(strValue) + 1
                Exit Do
            End If
        Loop
        If intPiece > 1 Then
           ahtGetToken = Null
        Else
           ahtGetToken = Mid$(strValue, intLastPos + 1, intPos -
intLastPos - 1)
        End If
    End If
ahtGetTokenExit:
    Exit Function
ahtGetTokenErr:
    MsgBox "Error in ahtGetToken: " & Error & " (" & Err & ")"
    Resume ahtGetTokenExit
End Function
Function SetDefaultPrinter(ByVal NomeStampante As String) As Boolean
    Dim atagDevices() As aht_tagDeviceRec
    Dim intCount As Integer, I As Long, ok As Boolean
    SetDefaultPrinter = False
    intCount = ahtGetPrinterList(atagDevices())
    If intCount = 0 Then
        Exit Function
    End If
    For I = LBound(atagDevices) To UBound(atagDevices)
        If atagDevices(I).drDeviceName = NomeStampante Then
            ok = ahtSetDefaultPrinter(atagDevices(I))
            SetDefaultPrinter = ok
            Exit For
        End If
    Next I
End Function
Public Function SetDefaultPrinter2(s As String) As Boolean
On Error GoTo Esci
    Dim WshNetwork As Object
    If s = "" Then GoTo Esci
    Set WshNetwork = CreateObject("WScript.Network")
        WshNetwork.SetDefaultPrinter (s)
        DoEvents
    Set WshNetwork = Nothing
    SetDefaultPrinter2 = True
    Exit Function
Esci:
    SetDefaultPrinter2 = False
End Function
Public Function GetDefaultPrinter() As String
    Dim X As Long, szTmp As String, dwBuf As Long
    On Local Error GoTo GestErr
    GetDefaultPrinter = ""
    dwBuf = 1024
    szTmp = Space(dwBuf + 1)
    X = aht_apiGetProfileString("windows", "device", "", szTmp, dwBuf)
    GetDefaultPrinter = Trim(Left(szTmp, X))
    Exit Function
GestErr:
    MsgBox "Errore in GetDefaultPrinter: " & Err.Description & " (" &
Err.Number & ")", vbCritical
End Function
Public Function SetDefaultPrinterEx(ByVal sDeviceInfo As String) As Long
    On Local Error GoTo GestErr
    SetDefaultPrinterEx = aht_apiWriteProfileString("windows", "device",
sDeviceInfo)
    Exit Function
GestErr:
    MsgBox "Errore in SetDefaultPrinterEx: " & Err.Description & " (" &
Err.Number & ")", vbCritical
End Function

 ha scritto nel messaggio
news:QD%de.79402$IN.13...@twister2.libero.it...

Onestamente non me la sono sentita, o meglio non ho avuto voglia di
spulciare tutto il tuo codice VBA.
Se però il tuo problema è quello di modificare da codice VBA la stampante
predefinita, vai sul Sito Comune (link qui sotto) e nella Sezione General
leggi la FAQ di Carlo Costarella e Lorenzo Coronati intitolata "6.66 Gestire
la stampante predefinita" (6.66 ? Ma questa è la FAQ del diavolo :-) ).
Se poi devi inviare un fax da VBA leggi nella Sezione General del Sito
Comune le seguenti FAQ:
1) 6.65 Inviare Fax da MSAccess di Giorgio Valsangiacomo
2) 6.111 Inviare da VBA per FAX una copertina e/o un file usando SDK di
WinFax PRO 10.0 di Symantec
3) 6.112 Inviare da VBA una copertina e/o un report per FAX usando WinFax
PRO 10.0 di Symantec
4) 6.131 Inviare da VBA uno o più file per fax usando FaxServer di Windows
XP di Sergio MAZZA
Se invece il tuo problema è ottenere file PDF da un report vai sul Sito
Comune e nella Sezione Reports leggi la FAQ di Walter Negrinelli intitolata
"4.21 Esportare un report in un file PDF".
-- 
Roberto
-----------------------------------------------------
il Sito Comune di it.comp.appl.access
http://www.sitocomune.com
----------------------------------------------------