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
| // http://bdn.borland.com/article/28936
{This sample is for Windows 2000 or NT but you should be able
to adapt this code to your needs.
The call to SendMessage notifies any other apps that are running
that the default printer has changed.
Sometimes this can cause the app to "freeze" because it is waiting
for a reply from each app (which it may never get)
so the code is commented out here.
You can determine whether you need it or not. }
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
const
MAXPRINTERBUFFER = 8000;
MAXPRINTERNAME = 500;
MAXPRINTERINFO = 50;
type
TPrinterBuffer = array[0..MAXPRINTERBUFFER - 1] of char;
TForm1 = class(TForm)
ListBox1: TListBox;
Button2: TButton;
Button1: TButton;
Label1: TLabel;
procedure Button2Click(Sender: TObject);
procedure GetPrinterNames;
function ParseNames(const namebuffer: TPrinterBuffer; var startPos: integer): string;
function SetPrinter(const PrinterName : String) : boolean;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
printerNames: TStringList;
defaultPrinter: integer;
implementation
{$R *.DFM}
procedure TForm1.Button2Click(Sender: TObject);
var
x : integer;
begin
try
for x := 0 to printerNames.Count -1 do begin
If ListBox1.Selected[x] then begin
if (SetPrinter(ListBox1.Items.Strings[x]))
then label1.Caption := 'Printer set to ' + ListBox1.Items.Strings[x]
else label1.Caption := 'Printer not set';
end;
end;
except
label1.Caption := 'An error occured while setting the printer';
end;
end;
procedure TForm1.GetPrinterNames;
var
buffer: TPrinterBuffer;
currPos: integer;
printerName: string;
begin
printerNames.Free;
printerNames := TStringList.Create;
if GetProfileString(PChar('PrinterPorts'), nil, '', buffer, MAXPRINTERBUFFER) > 0 then
begin
currPos := 0;
while (true) do
begin
printerName := ParseNames(buffer, currPos);
if printerName <> '' then
printerNames.Add(printerName)
else
break;
end;
end;
end;
function TForm1.ParseNames(const namebuffer: TPrinterBuffer;
var startPos: integer): string;
var
i, j, NameLength: integer;
str: string;
begin
result := '';
if (startPos > High(namebuffer)) or (namebuffer[startPos] = Chr(0))
then
exit;
for i := startPos to High(namebuffer) do begin
if namebuffer[i] = Chr(0)
then begin
nameLength := i - startPos;
SetLength(str, nameLength);
for j := 0 to nameLength - 1 do
str[j+1] := namebuffer[startPos + j];
result := str;
startPos := i + 1;
break;
end;
end;
end;
function TForm1.SetPrinter(const PrinterName: String): boolean;
var
s2 : string;
dum1 : Pchar;
xx, qq : integer;
const
cs1 : pchar = 'Windows';
cs2 : pchar = 'Device';
cs3 : pchar = 'Devices';
cs4 : pchar = #0;
begin
xx := 254;
GetMem( dum1, xx);
Result := False;
try
qq := GetProfileString( cs3, pchar( printerName ), #0, dum1, xx);
if (qq > 0) and (trim( strpas( dum1 )) <> '')
then begin
s2 := PrinterName + ',' + strpas( dum1 );
while GetProfileString( cs1, cs2, cs4, dum1, xx) > 0 do
WriteProfileString( cs1, cs2, #0);
WriteProfileString( cs1, cs2, pchar( s2 ));
case Win32Platform of
VER_PLATFORM_WIN32_NT :
SendMessage( HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(cs1));
VER_PLATFORM_WIN32_WINDOWS :
SendMessage( HWND_BROADCAST, WM_SETTINGCHANGE, 0, LongInt(cs1));
end;
Result := True;
end;
finally
FreeMem( dum1 );
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
GetPrinterNames;
Listbox1.Items.AddStrings(PrinterNames);
end;
end. |
Partager