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
| procedure TForm1.PrintForm;
var
DC: HDC;
isDcPalDevice: Bool;
MemDC: HDC;
MemBitmap: HBITMAP;
OldMemBitmap: HBITMAP;
hDibHeader: THandle;
pDibHeader: Pointer;
hBits: THandle;
pBits: Pointer;
ScaleX: Double;
ScaleY: Double;
pPal: PLOGPALETTE;
pal: HPALETTE;
OldPal: HPALETTE;
i: Integer;
begin
{Get the screen dc}
DC := GetDC(0);
{Create a compatible dc}
MemDC := CreateCompatibleDC(DC);
{create a bitmap}
MemBitmap := CreateCompatibleBitmap(DC, Self.Width, Self.Height);
{select the bitmap into the dc}
OldMemBitmap := SelectObject(MemDC, MemBitmap);
{Lets prepare to try a fixup for broken video drivers}
isDcPalDevice := False;
if GetDeviceCaps(DC, RASTERCAPS) and RC_PALETTE=RC_PALETTE then
begin
GetMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
FillChar(pPal^, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)),
#0);
pPal^.palVersion := $300;
pPal^.palNumEntries := GetSystemPaletteEntries(DC, 0, 256, pPal^.palPalEntry);
if pPal^.palNumEntries<>0 then
begin
pal := CreatePalette(pPal^);
OldPal := SelectPalette(MemDC, pal, False);
isDcPalDevice := True
end
else
FreeMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
end;
{copy from the screen to the memdc/bitmap}
BitBlt(MemDC, 0, 0, Self.Width, Self.Height, DC, Self.Left, Self.Top, SRCCOPY);
if isDcPalDevice=True then
begin
SelectPalette(MemDC, OldPal, False);
DeleteObject(pal);
end;
{unselect the bitmap}
SelectObject(MemDC, OldMemBitmap);
{delete the memory dc}
DeleteDC(MemDC);
{Allocate memory for a DIB structure}
hDibHeader := GlobalAlloc(GHND, SizeOf(TBITMAPINFO)+(SizeOf(TRGBQUAD)*
256));
{get a pointer to the alloced memory}
pDibHeader := GlobalLock(hDibHeader);
{fill in the dib structure with info on the way we want the DIB}
FillChar(pDibHeader^, SizeOf(TBITMAPINFO)+(SizeOf(TRGBQUAD)*
256), #0);
PBITMAPINFOHEADER(pDibHeader)^.biSize := SizeOf(TBITMAPINFOHEADER);
PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
PBITMAPINFOHEADER(pDibHeader)^.biWidth := Self.Width;
PBITMAPINFOHEADER(pDibHeader)^.biHeight := Self.Height;
PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;
{find out how much memory for the bits}
GetDIBits(DC, MemBitmap, 0, Self.Height, nil, TBITMAPINFO(pDibHeader^),
DIB_RGB_COLORS);
{Alloc memory for the bits}
hBits := GlobalAlloc(GHND, PBITMAPINFOHEADER(pDibHeader)^.BiSizeImage);
{Get a pointer to the bits}
pBits := GlobalLock(hBits);
{Call fn again, but this time give us the bits!}
GetDIBits(DC, MemBitmap, 0, Self.Height, pBits, PBitmapInfo(pDibHeader)^,
DIB_RGB_COLORS);
{Lets try a fixup for broken video drivers}
if isDcPalDevice=True then
begin
for i := 0 to (pPal^.palNumEntries-1) do
begin
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed := pPal^.palPalEntry[i].peRed;
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen := pPal^.palPalEntry[i].peGreen;
PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue := pPal^.palPalEntry[i].peBlue;
end;
FreeMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
end;
{Release the screen dc}
ReleaseDC(0, DC);
{Delete the bitmap}
DeleteObject(MemBitmap);
{Start print job}
Printer.BeginDoc;
{Scale print size }
ScaleX := Self.Width*3;
ScaleY := Self.Height*3;
{
if Printer.PageWidth < Printer.PageHeight then
begin
ScaleX := Printer.PageWidth;
ScaleY := Self.Height*(Printer.PageWidth/Self.Width);
end
else
begin
ScaleX := Self.Width*(Printer.PageHeight/Self.Height);
ScaleY := Printer.PageHeight;
end;
}
{Just incase the printer drver is a palette device}
isDcPalDevice := False;
if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and RC_PALETTE=RC_PALETTE
then
begin
{Create palette from dib}
GetMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
FillChar(pPal^, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)),
#0);
pPal^.palVersion := $300;
pPal^.palNumEntries := 256;
for i := 0 to (pPal^.palNumEntries-1) do
begin
pPal^.palPalEntry[i].peRed := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
pPal^.palPalEntry[i].peGreen := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
pPal^.palPalEntry[i].peBlue := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
end;
pal := CreatePalette(pPal^);
FreeMem(pPal, SizeOf(TLOGPALETTE)+(255*SizeOf(TPALETTEENTRY)));
OldPal := SelectPalette(Printer.Canvas.Handle, pal, False);
isDcPalDevice := True
end;
{send the bits to the printer}
StretchDiBits(Printer.Canvas.Handle, 0, 0, Round(ScaleX), Round(ScaleY),
0, 0, Self.Width, Self.Height, pBits, PBitmapInfo(pDibHeader)^,
DIB_RGB_COLORS, SRCCOPY);
{Just incase you printer drver is a palette device}
if isDcPalDevice=True then
begin
SelectPalette(Printer.Canvas.Handle, OldPal, False);
DeleteObject(pal);
end;
{Clean up allocated memory}
GlobalUnlock(hBits);
GlobalFree(hBits);
GlobalUnlock(hDibHeader);
GlobalFree(hDibHeader);
{end the print job}
Printer.EndDoc;
end; |
:strip_exif()/u/34938/futurama.gif?f=community)
/u/30806/Bacardi2.png?f=community)