Login | ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/userdetect2/trunk/vcl/VTSCompat.pas
Revision: 96
Committed: Tue Jan 3 13:13:18 2017 UTC (5 years, 7 months ago) by daniel-marschall
Content type: text/x-pascal
File size: 5818 byte(s)
Log Message:
Release 2.3.2

File Contents

# Content
1 unit VTSCompat;
2
3 {$IF CompilerVersion >= 25.0}
4 {$LEGACYIFEND ON}
5 {$IFEND}
6
7 interface
8
9 uses
10 Dialogs, Windows, Controls, Graphics, SysUtils, CommDlg, Classes;
11
12 function AddTransparentIconToImageList(ImageList: TImageList; Icon: TIcon; DoGreyscale: boolean=False): integer;
13 function CompatOpenDialogExecute(OpenDialog: TOpenDialog): boolean;
14 function CompatSaveDialogExecute(SaveDialog: TSaveDialog): boolean;
15
16 function ToGray(PixelColor: Longint): Longint;
17
18 implementation
19
20 uses
21 PatchU, ShlObj, ShellAPI;
22
23 var
24 pp: TPatchMethod;
25
26 // --- CompatOpenDialogExecute
27
28 type
29 TExtOpenDialogAccessor = class(TOpenDialog);
30
31 TExtOpenDialog = class(TOpenDialog)
32 protected
33 function TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool; override;
34 end;
35
36 function TExtOpenDialog.TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool;
37 begin
38 TOpenFileName(DialogData).Flags :=
39 TOpenFileName(DialogData).Flags and not OFN_ENABLETEMPLATE;
40
41 TOpenFileName(DialogData).Flags :=
42 TOpenFileName(DialogData).Flags and not OFN_ENABLEHOOK;
43
44 if pp.IsPatched then pp.Restore;
45
46 result := inherited TaskModalDialog(DialogFunc, DialogData);
47 end;
48
49 function CompatOpenDialogExecute(OpenDialog: TOpenDialog): boolean;
50 {$IF CompilerVersion < 18.5} // prior to Delphi 2007
51 var
52 x: TExtOpenDialog;
53 MethodPtr, MethodPtr2: function(DialogFunc: Pointer; var DialogData): Bool of object;
54 begin
55 MethodPtr := TExtOpenDialogAccessor(OpenDialog).TaskModalDialog;
56
57 x := TExtOpenDialog.Create(nil);
58 try
59 MethodPtr2 := x.TaskModalDialog;
60 pp := TPatchMethod.Create(@MethodPtr, @MethodPtr2);
61 try
62 result := OpenDialog.Execute;
63 if pp.IsPatched then pp.Restore;
64 finally
65 pp.Free;
66 end;
67 finally
68 x.Free;
69 end;
70 {$ELSE}
71 begin
72 result := OpenDialog.Execute;
73 {$IFEND}
74 end;
75
76 // --- CompatSaveDialogExecute
77
78 type
79 TExtSaveDialogAccessor = class(TSaveDialog);
80
81 TExtSaveDialog = class(TSaveDialog)
82 protected
83 function TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool; override;
84 end;
85
86 function TExtSaveDialog.TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool;
87 begin
88 // Remove the two flags which let the File Dialog GUI fall back to the old design.
89 TOpenFileName(DialogData).Flags :=
90 TOpenFileName(DialogData).Flags and not OFN_ENABLETEMPLATE;
91
92 TOpenFileName(DialogData).Flags :=
93 TOpenFileName(DialogData).Flags and not OFN_ENABLEHOOK;
94
95 // It is important to restore TaskModalDialog, so we don't get a stack
96 // overflow when calling the inherited method.
97 if pp.IsPatched then pp.Restore;
98
99 result := inherited TaskModalDialog(DialogFunc, DialogData);
100 end;
101
102 function CompatSaveDialogExecute(SaveDialog: TSaveDialog): boolean;
103 {$IF CompilerVersion < 18.5} // prior to Delphi 2007
104 var
105 x: TExtSaveDialog;
106 MethodPtr, MethodPtr2: function(DialogFunc: Pointer; var DialogData): Bool of object;
107 begin
108 MethodPtr := TExtSaveDialogAccessor(SaveDialog).TaskModalDialog;
109
110 x := TExtSaveDialog.Create(nil);
111 try
112 MethodPtr2 := x.TaskModalDialog;
113 pp := TPatchMethod.Create(@MethodPtr, @MethodPtr2);
114 try
115 result := SaveDialog.Execute;
116 finally
117 pp.Free;
118 end;
119 finally
120 x.Free;
121 end;
122 {$ELSE}
123 begin
124 result := SaveDialog.Execute;
125 {$IFEND}
126 end;
127
128 // --- AddTransparentIconToImageList
129
130 function RealIconSize(H: HIcon): TPoint;
131 // http://www.delphipages.com/forum/showthread.php?t=183999
132 var
133 IconInfo: TIconInfo;
134 bmpmask: TBitmap;
135 begin
136 result := Point(0, 0);
137
138 if H <> 0 then
139 begin
140 bmpmask := TBitmap.Create;
141 try
142 IconInfo.fIcon := true;
143 try
144 GetIconInfo(H, IconInfo);
145 bmpmask.Handle := IconInfo.hbmMask;
146 bmpmask.Dormant; //lets us free the resource without 'losing' the bitmap
147 finally
148 DeleteObject(IconInfo.hbmMask);
149 DeleteObject(IconInfo.hbmColor)
150 end;
151 result := Point(bmpmask.Width, bmpmask.Height);
152 finally
153 bmpmask.Free;
154 end;
155 end;
156 end;
157
158 function ToGray(PixelColor: Longint): Longint;
159 var
160 Red, Green, Blue, Gray: Byte;
161 begin
162 Red := PixelColor;
163 Green := PixelColor shr 8;
164 Blue := PixelColor shr 16;
165 Gray := Round(0.299 * Red + 0.587 * Green + 0.114 * Blue);
166 result := Gray + Gray shl 8 + Gray shl 16;
167 end;
168
169 function AddTransparentIconToImageList(ImageList: TImageList; Icon: TIcon; DoGreyscale: boolean=False): integer;
170 // http://www.delphipages.com/forum/showthread.php?t=183999
171 var
172 buffer, mask: TBitmap;
173 p: TPoint;
174 x, y: integer;
175 begin
176 // result := ImageList.AddIcon(ico);
177 // --> In Delphi 6, Icons with half-transparency have a black border (e.g. in ListView)
178
179 p := RealIconSize(icon.handle);
180
181 buffer := TBitmap.Create;
182 mask := TBitmap.Create;
183 try
184 buffer.PixelFormat := pf24bit;
185 mask.PixelFormat := pf24bit;
186
187 buffer.Width := p.X;
188 buffer.Height := p.Y;
189 buffer.Canvas.Draw(0, 0, icon);
190 buffer.Transparent := true;
191 buffer.TransparentColor := buffer.Canvas.Pixels[0,0];
192
193 if (ImageList.Width <> p.X) or (ImageList.Height <> p.Y) then
194 begin
195 ImageList.Width := p.X;
196 ImageList.Height := p.Y;
197 end;
198
199 // create a mask for the icon.
200 mask.Assign(buffer);
201 mask.Canvas.Brush.Color := buffer.Canvas.Pixels[0, buffer.Height -1];
202 mask.Monochrome := true;
203
204 if DoGreyscale then
205 begin
206 for x := 0 to buffer.Width - 1 do
207 begin
208 for y := 0 to buffer.Height - 1 do
209 begin
210 buffer.Canvas.Pixels[x, y] := ToGray(buffer.Canvas.Pixels[x, y]);
211 end;
212 end;
213 end;
214
215 result := ImageList.Add(buffer, mask);
216 finally
217 mask.Free;
218 buffer.Free;
219 end;
220 end;
221
222 end.