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, 4 months ago) by daniel-marschall
Content type: text/x-pascal
File size: 5818 byte(s)
Log Message: 
Release 2.3.2

File Contents

# User Rev Content
1 daniel-marschall 68 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 daniel-marschall 96 function AddTransparentIconToImageList(ImageList: TImageList; Icon: TIcon; DoGreyscale: boolean=False): integer;
13 daniel-marschall 68 function CompatOpenDialogExecute(OpenDialog: TOpenDialog): boolean;
14     function CompatSaveDialogExecute(SaveDialog: TSaveDialog): boolean;
15    
16 daniel-marschall 96 function ToGray(PixelColor: Longint): Longint;
17    
18 daniel-marschall 68 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 daniel-marschall 93 result := SaveDialog.Execute;
125 daniel-marschall 68 {$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 daniel-marschall 96 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 daniel-marschall 68 // http://www.delphipages.com/forum/showthread.php?t=183999
171     var
172     buffer, mask: TBitmap;
173     p: TPoint;
174 daniel-marschall 96 x, y: integer;
175 daniel-marschall 68 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 daniel-marschall 96 if (ImageList.Width <> p.X) or (ImageList.Height <> p.Y) then
194 daniel-marschall 68 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 daniel-marschall 96 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 daniel-marschall 68 result := ImageList.Add(buffer, mask);
216     finally
217     mask.Free;
218     buffer.Free;
219     end;
220     end;
221    
222     end.