Stampante PredeFinita

' Vedi SettaPrinter.vb di _MyStruct_ADODB, con tutte le librerie



Private Sub SettaPrinter_Load(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles MyBase.Load
Dim Printer As New Printer

Stringa = Printer.DeviceName
Label1.Text = "Stampante di Default: " & Printer.DeviceName

Dim prn As Printer
For Each prn In Printers
List1.Items.Add(prn.DeviceName)
Next prn

If Len(Stringa) > 0 Then
For I = 0 To List1.Items.Count - 1
If VB6.GetItemString(List1, I) = Stringa Then
List1.SetSelected(I, True)
Exit For
End If
Next
End If

End Sub
###################################################################################################

sotto viene riportato il codice INTERO

Option Strict Off
Option Explicit On
Imports VB = Microsoft.VisualBasic
Imports Microsoft.VisualBasic.PowerPacks.Printing.Compatibility.VB6
Friend Class SettaPrinter
Inherits System.Windows.Forms.Form
Dim prn As Printer
Dim I As Integer
Dim Stringa As String
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 Integer) As Integer

Private Declare Function WriteProfileString Lib "kernel32" Alias "WriteProfileStringA"(ByVal lpszSection As String, ByVal lpszKeyName As String, ByVal lpszString As String) As Integer

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA"(ByVal hwnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, ByRef lparam As String) As Integer

'UPGRADE_WARNING: La struttura OSVERSIONINFO potrebbe richiedere attributi di marshalling da passare come argomento a questa istruzione Declare. Fare clic per ulteriori informazioni: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"'
Private Declare Function GetVersionExA Lib "kernel32" (ByRef lpVersionInformation As OSVERSIONINFO) As Short

'UPGRADE_WARNING: La struttura PRINTER_DEFAULTS potrebbe richiedere attributi di marshalling da passare come argomento a questa istruzione Declare. Fare clic per ulteriori informazioni: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="C429C3A5-5D47-4CD9-8F51-74A1616405DC"'
Private Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA"(ByVal pPrinterName As String, ByRef phPrinter As Integer, ByRef pDefault As PRINTER_DEFAULTS) As Integer

'UPGRADE_NOTE: Command e' stato aggiornato a Command_Renamed. Fare clic per ulteriori informazioni: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="A9E4979A-37FA-4718-9994-97DD76ED70A7"'
'UPGRADE_ISSUE: La dichiarazione di un parametro 'As Any' non e' supportata. Fare clic per ulteriori informazioni: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="FAE78A8D-8978-4FD4-8208-5B7324A8F795"'
Private Declare Function SetPrinter Lib "winspool.drv" Alias "SetPrinterA" (ByVal hPrinter As Integer, ByVal Level As Integer, ByRef pPrinter As Object, ByVal Command_Renamed As Integer) As Integer

'UPGRADE_ISSUE: La dichiarazione di un parametro 'As Any' non e' supportata. Fare clic per ulteriori informazioni: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="FAE78A8D-8978-4FD4-8208-5B7324A8F795"'
Private Declare Function GetPrinter Lib "winspool.drv" Alias "GetPrinterA" (ByVal hPrinter As Integer, ByVal Level As Integer, ByRef pPrinter As Object, ByVal cbBuf As Integer, ByRef pcbNeeded As Integer) As Integer

'UPGRADE_ISSUE: La dichiarazione di un parametro 'As Any' non e' supportata. Fare clic per ulteriori informazioni: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="FAE78A8D-8978-4FD4-8208-5B7324A8F795"'
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Object) As Integer

Private Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Integer) As Integer

Private Const HWND_BROADCAST As Integer = &HFFFF
Private Const WM_WININICHANGE As Integer = &H1A

' constants for DEVMODE structure
Private Const CCHDEVICENAME As Short = 32
Private Const CCHFORMNAME As Short = 32

' constants for DesiredAccess member of PRINTER_DEFAULTS
Private Const STANDARD_RIGHTS_REQUIRED As Integer = &HF0000
Private Const PRINTER_ACCESS_ADMINISTER As Integer = &H4
Private Const PRINTER_ACCESS_USE As Integer = &H8
Private Const PRINTER_ALL_ACCESS As Boolean = (STANDARD_RIGHTS_REQUIRED Or PRINTER_ACCESS_ADMINISTER Or PRINTER_ACCESS_USE)

' constant that goes into PRINTER_INFO_5 Attributes member
' to set it as default
Private Const PRINTER_ATTRIBUTE_DEFAULT As Short = 4

'Constant for OSVERSIONINFO.dwPlatformId
Private Const VER_PLATFORM_WIN32_WINDOWS As Short = 1

Private Structure DEVMODE
'UPGRADE_WARNING: La dimensione della stringa di lunghezza fissa deve essere contenuta nel buffer. Fare clic per ulteriori informazioni: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="3C1E4426-0B80-443E-B943-0627CD55D48B"'
<VBFixedString(CCHDEVICENAME),System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValArray,SizeConst:=CCHDEVICENAME)> Public dmDeviceName() As Char
Dim dmSpecVersion As Short
Dim dmDriverVersion As Short
Dim dmSize As Short
Dim dmDriverExtra As Short
Dim dmFields As Integer
Dim dmOrientation As Short
Dim dmPaperSize As Short
Dim dmPaperLength As Short
Dim dmPaperWidth As Short
Dim dmScale As Short
Dim dmCopies As Short
Dim dmDefaultSource As Short
Dim dmPrintQuality As Short
Dim dmColor As Short
Dim dmDuplex As Short
Dim dmYResolution As Short
Dim dmTTOption As Short
Dim dmCollate As Short
'UPGRADE_WARNING: La dimensione della stringa di lunghezza fissa deve essere contenuta nel buffer. Fare clic per ulteriori informazioni: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="3C1E4426-0B80-443E-B943-0627CD55D48B"'
<VBFixedString(CCHFORMNAME),System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValArray,SizeConst:=CCHFORMNAME)> Public dmFormName() As Char
Dim dmLogPixels As Short
Dim dmBitsPerPel As Integer
Dim dmPelsWidth As Integer
Dim dmPelsHeight As Integer
Dim dmDisplayFlags As Integer
Dim dmDisplayFrequency As Integer
Dim dmICMMethod As Integer ' // Windows 95 only
Dim dmICMIntent As Integer ' // Windows 95 only
Dim dmMediaType As Integer ' // Windows 95 only
Dim dmDitherType As Integer ' // Windows 95 only
Dim dmReserved1 As Integer ' // Windows 95 only
Dim dmReserved2 As Integer ' // Windows 95 only
End Structure

Private Structure PRINTER_INFO_5
Dim pPrinterName As String
Dim pPortName As String
Dim Attributes As Integer
Dim DeviceNotSelectedTimeout As Integer
Dim TransmissionRetryTimeout As Integer
End Structure

Private Structure PRINTER_DEFAULTS
Dim pDatatype As Integer
Dim pDevMode As Integer
Dim DesiredAccess As Integer
End Structure

Private Structure OSVERSIONINFO
Dim dwOSVersionInfoSize As Integer
Dim dwMajorVersion As Integer
Dim dwMinorVersion As Integer
Dim dwBuildNumber As Integer
Dim dwPlatformId As Integer
'UPGRADE_WARNING: La dimensione della stringa di lunghezza fissa deve essere contenuta nel buffer. Fare clic per ulteriori informazioni: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="3C1E4426-0B80-443E-B943-0627CD55D48B"'
<VBFixedString(128),System.Runtime.InteropServices.MarshalAs(System.Runtime.InteropServices.UnmanagedType.ByValArray,SizeConst:=128)> Public szCSDVersion() As Char
End Structure

'Copia un indirizzo LPSTR su una stringa VB
'UPGRADE_NOTE: Add e' stato aggiornato a Add_Renamed. Fare clic per ulteriori informazioni: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="A9E4979A-37FA-4718-9994-97DD76ED70A7"'
Private Function PtrCtoVbString(ByRef Add_Renamed As Integer) As String

'Assume un buffer di 512 byte
Dim sTemp As New VB6.FixedLengthString(512)

'Copia i dati della stringa in base all'indirizzo
Call lstrcpy(sTemp.Value, Add_Renamed)

'Se la stringa non e' null-terminated assumo che sia vuota
If (InStr(1, sTemp.Value, Chr(0)) = 0) Then
PtrCtoVbString = vbNullString
Else
'Toglie il chr$(0) dalla fine della stringa
PtrCtoVbString = VB.Left(sTemp.Value, InStr(1, sTemp.Value, Chr(0)) - 1)
End If
End Function

'Routine ausiliaria per la scrittura della stampante default su WIN.INI versione NT
Private Sub SetDefaultPrinter(ByRef PrinterName As String, ByRef DriverName As String, ByRef PrinterPort As String)

Dim DeviceLine As String

DeviceLine = PrinterName & "," & DriverName & "," & PrinterPort

'Inserisce le nuove impostazioni per la stampante nella sezione [WINDOWS]
'del WIN.INI per loa voce DEVICE=xxxxxx
Call WriteProfileString("windows", "Device", DeviceLine)

'Manda a tutte le applicazioni un messaggio che indica di rileggere WIN.INI
'Call SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, "windows")

End Sub

Private Sub Win95SetDefaultPrinter(ByRef PrinterName As String)

'UPGRADE_NOTE: Handle e' stato aggiornato a Handle_Renamed. Fare clic per ulteriori informazioni: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="A9E4979A-37FA-4718-9994-97DD76ED70A7"'
Dim Handle_Renamed As Integer 'handle to printer
Dim pd As PRINTER_DEFAULTS
Dim x As Integer
Dim need As Integer ' bytes needed
Dim pi5 As PRINTER_INFO_5 ' your PRINTER_INFO structure
Dim LastError As Integer
Dim t() As Integer

'Inizializza i dati della struttura PRINTER_DEFAULTS
pd.pDatatype = 0
pd.DesiredAccess = PRINTER_ALL_ACCESS Or pd.DesiredAccess

'Ottiene un handle alla stampante
x = OpenPrinter(PrinterName, Handle_Renamed, pd)

'Ignora l'errore in caso di fallimento
If x = False Then Exit Sub

'Chiamata a GetPrinter con Level=5 (PRINTER_INFO_5) per determinare quanti byte
'servono per il buffer
Call GetPrinter(Handle_Renamed, 5, 0, 0, need)

'Inutile controllare qui Err.LastDllError: dovrebbe esserci stato un errore
'122 - ERROR_INSUFFICIENT_BUFFER, quindi ridimensiono t per contenere i byte
'necessari
ReDim t(need \ 4)

'Adesso posso chiamare GetPrinter per ottenere le informazioni sotto forma di una
'struttura PRINTER_INFO_5
'Non ho capito perche', ma i dati della struttura arrivano nell'array t() come
'puntatori Long
x = GetPrinter(Handle_Renamed, 5, t(0), need, need)

'Ignora l'errore in caso di fallimento
If x = False Then Exit Sub

'Converte in stringa i primi 2 puntatori
pi5.pPrinterName = PtrCtoVbString(t(0))
pi5.pPortName = PtrCtoVbString(t(1))
'Gli altri sono semplici Long
pi5.Attributes = t(2)
pi5.DeviceNotSelectedTimeout = t(3)
pi5.TransmissionRetryTimeout = t(4)

'Flag che imposta la stampante default
pi5.Attributes = PRINTER_ATTRIBUTE_DEFAULT

'Imposta la stampante come default
'UPGRADE_WARNING: Impossibile risolvere la proprieta' predefinita dell'oggetto pi5. Fare clic per ulteriori informazioni: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="6A50421D-15FE-4896-8A1B-2EC21E9037B2"'
x = SetPrinter(Handle_Renamed, 5, pi5, 0)

'Ignora l'errore in caso di fallimento
If x = False Then Exit Sub

'Chiude l'handle
ClosePrinter(Handle_Renamed)

End Sub

Private Sub GetDriverAndPort(ByRef Buffer As String, ByRef DriverName As String, ByRef PrinterPort As String)

Dim iDriver As Short
Dim iPort As Short

DriverName = vbNullString
PrinterPort = vbNullString

'The driver name is first in the string terminated by a comma
iDriver = InStr(Buffer, ",")
If iDriver > 0 Then

'Strip out the driver name
DriverName = VB.Left(Buffer, iDriver - 1)

'The port name is the second entry after the driver name
'separated by commas.
iPort = InStr(iDriver + 1, Buffer, ",")

If iPort > 0 Then
'Strip out the port name
PrinterPort = Mid(Buffer, iDriver + 1, iPort - iDriver - 1)
End If
End If

End Sub

'Imposta la stampante predefinita sotto WinNT
Public Sub WinNTSetDefaultPrinter2(ByRef PrinterName As String)

Dim Buffer As String
Dim DeviceName As String
Dim DriverName As String
Dim PrinterPort As String

'Prende le informazioni sulla stampante richiesta da WIN.INI
Buffer = Space(1024)
Call GetProfileString("PrinterPorts", PrinterName, vbNullString, Buffer, Len(Buffer))

'Ottiene dal buffer il nome del driver e della porta
GetDriverAndPort(Buffer, DriverName, PrinterPort)

If Len(DriverName) > 0 And Len(PrinterPort) > 0 Then
SetDefaultPrinter(PrinterName, DriverName, PrinterPort)
End If
End Sub

'Imposta la stampante predefinita in Windows 95/98/NT
Public Sub OSSetDefaultPrinter(ByRef PrinterName As String)
Dim osinfo As OSVERSIONINFO

If Len(PrinterName) = 0 Then Exit Sub

osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space(128)
Call GetVersionExA(osinfo)

If osinfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
Win95SetDefaultPrinter(PrinterName)
Else
'Suppone che le versioni successive a win95 usino il sistema di NT
WinNTSetDefaultPrinter2(PrinterName)
End If
End Sub
'===========================================
' Versione procedura 26 Marzo 2023
'===========================================


Private Sub Command1_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles Command1.Click
Dim Printer As New Printer
System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.WaitCursor
Dim prn As Printer

'UPGRADE_WARNING: Dir ha un nuovo comportamento. Fare clic per ulteriori informazioni: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="9B7D5ADD-D8FE-4819-A36C-6DEDAF088CC7"'
If Dir(My.Application.Info.DirectoryPath & "\INI", FileAttribute.Directory) = "" Then
MkDir(My.Application.Info.DirectoryPath & "\INI")
End If


'UPGRADE_WARNING: Dir ha un nuovo comportamento. Fare clic per ulteriori informazioni: 'ms-help://MS.VSCC.v90/dv_commoner/local/redirect.htm?keyword="9B7D5ADD-D8FE-4819-A36C-6DEDAF088CC7"'
If Dir(My.Application.Info.DirectoryPath & "\Ini\PrnAccess.Dat") <> "" Then
FileOpen(1, My.Application.Info.DirectoryPath & "\Ini\PrnAccess.Dat", OpenMode.Output)
PrintLine(1, VB6.GetItemString(List1, List1.SelectedIndex))
FileClose(1)

Else
FileOpen(1, My.Application.Info.DirectoryPath & "\Ini\PrnAccess.Dat", OpenMode.Output)
PrintLine(1, "")
FileClose(1)
End If



'**********************************************
' settaggio stampante con nuova funzione
'**********************************************
If Len(Trim(VB6.GetItemString(List1, List1.SelectedIndex))) > 0 Then
For Each prn In Printers
If prn.DeviceName = VB6.GetItemString(List1, List1.SelectedIndex) Then
Printer = prn
Exit For
End If
Next prn
End If

If Check1.CheckState = 1 Then 'And prn.DeviceName <> VB6.GetItemString(List1, List1.SelectedIndex) Then
'***********************************************

' mette la stampante selezionata Predefinita

'***********************************************

WinNTSetDefaultPrinter2(VB6.GetItemString(List1, List1.SelectedIndex))
End If



If Printer.DeviceName <> VB6.GetItemString(List1, List1.SelectedIndex) Then

System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.WaitCursor
ProgressBar1.Visible = True
ProgressBar1.Maximum = 500
ProgressBar1.Value = 0
ProgressBar1.Minimum = 0

Timer1.Enabled = True

WinNTSetDefaultPrinter2(VB6.GetItemString(List1, List1.SelectedIndex))

If Printer.DeviceName <> VB6.GetItemString(List1, List1.SelectedIndex) Then


For Each prn In Printers
If prn.DeviceName = VB6.GetItemString(List1, List1.SelectedIndex) Then
Printer = prn
Exit For
End If
Next prn
End If



Timer1.Enabled = False
FileOpen(1, My.Application.Info.DirectoryPath & "\Ini\PrnAccess.Dat", OpenMode.Output)
PrintLine(1, VB6.GetItemString(List1, List1.SelectedIndex))
FileClose(1)
End If

System.Windows.Forms.Cursor.Current = System.Windows.Forms.Cursors.Default

If Check1.Checked = True Then
MsgBox("Stampante Predefinita = " & VB6.GetItemString(List1, List1.SelectedIndex), MsgBoxStyle.Information, "OK")
Else
MsgBox("Stampante di default Selezionata = " & VB6.GetItemString(List1, List1.SelectedIndex), MsgBoxStyle.Information, "OK")
End If
End Sub

Private Sub Command2_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles Command2.Click
Me.Close()
End Sub




Private Sub SettaPrinter_Load(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles MyBase.Load
Dim Printer As New Printer

Stringa = Printer.DeviceName
Label1.Text = "Stampante di Default: " & Printer.DeviceName

Dim prn As Printer
For Each prn In Printers
List1.Items.Add(prn.DeviceName)
Next prn

If Len(Stringa) > 0 Then
For I = 0 To List1.Items.Count - 1
If VB6.GetItemString(List1, I) = Stringa Then
List1.SetSelected(I, True)
Exit For
End If
Next
End If

End Sub



End Class