Login | ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/userdetect2/trunk/UserDetect2/vcl/VTSCompat.pas
Revision: 68
Committed: Tue Sep 29 18:31:10 2015 UTC (7 years ago) by daniel-marschall
Content type: text/x-pascal
File size: 5131 byte(s)

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