Subversion Repositories userdetect2

Compare Revisions

Regard whitespace Rev 70 → Rev 72

/trunk/vcl/ViaThinkSoft.dpk
0,0 → 1,41
package dclusr;
 
{$R *.res}
{$ALIGN 8}
{ ASSERTIONS ON}
{$BOOLEVAL OFF}
{ DEBUGINFO OFF}
{$EXTENDEDSYNTAX ON}
{$IMPORTEDDATA ON}
{$IOCHECKS ON}
{ LOCALSYMBOLS OFF}
{$LONGSTRINGS ON}
{$OPENSTRINGS ON}
{$OPTIMIZATION ON}
{$OVERFLOWCHECKS OFF}
{$RANGECHECKS OFF}
{$REFERENCEINFO OFF}
{$SAFEDIVIDE OFF}
{ STACKFRAMES OFF}
{$TYPEDADDRESS OFF}
{$VARSTRINGCHECKS ON}
{$WRITEABLECONST ON}
{$MINENUMSIZE 1}
{$IMAGEBASE $51000000}
{$DESCRIPTION 'ViaThinkSoft VCL Components'}
{$LIBSUFFIX '60'}
{$DESIGNONLY}
{$IMPLICITBUILD ON}
 
requires
rtl,
vcl,
designide;
 
contains
VTSListView in 'VTSListView.pas',
AlphaNumSort in 'AlphaNumSort.pas',
VTSCompat in 'VTSCompat.pas',
PatchU in 'PatchU.pas';
 
end.
/trunk/vcl/AlphaNumSort.pas
0,0 → 1,122
unit AlphaNumSort;
 
(*
* The Alphanum Algorithm is an improved sorting algorithm for strings
* containing numbers. Instead of sorting numbers in ASCII order like
* a standard sort, this algorithm sorts numbers in numeric order.
*
* The Alphanum Algorithm is discussed at http://www.DaveKoelle.com
*
* Translated from Java to Delphi by Daniel Marschall, www.daniel-marschall.de
* Revision 2015-09-30
*
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public
* License as published by the Free Software Foundation; either
* version 2.1 of the License, or any later version.
*
* This library is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*
*)
 
interface
 
uses
SysUtils;
 
function AlphaNumCompare(s1, s2: string): integer;
 
implementation
 
function isDigit(ch: char): boolean;
begin
result := (ord(ch) >= 48) and (ord(ch) <= 57);
end;
 
// Length of string is passed in for improved efficiency (only need to calculate it once)
function getChunk(s: string; slength, marker: integer): string;
var
chunk: string;
c: char;
begin
c := s[marker+1];
chunk := chunk + c;
Inc(marker);
if isDigit(c) then
begin
while marker < slength do
begin
c := s[marker+1];
if not isDigit(c) then break;
chunk := chunk + c;
Inc(marker);
end;
end
else
begin
while marker < slength do
begin
c := s[marker+1];
if (isDigit(c)) then break;
chunk := chunk + c;
Inc(marker);
end;
end;
result := chunk;
end;
 
function AlphaNumCompare(s1, s2: string): integer;
var
s1Length, s2Length, thisChunkLength: integer;
thisMarker, thatMarker, i: integer;
thisChunk, thatChunk: string;
begin
thisMarker := 0;
thatMarker := 0;
s1Length := Length(s1);
s2Length := Length(s2);
 
while (thisMarker < s1Length) and (thatMarker < s2Length) do
begin
thisChunk := getChunk(s1, s1Length, thisMarker);
Inc(thisMarker, Length(thisChunk));
 
thatChunk := getChunk(s2, s2Length, thatMarker);
Inc(thatMarker, Length(thatChunk));
 
// If both chunks contain numeric characters, sort them numerically
if isDigit(thisChunk[1]) and isDigit(thatChunk[1]) then
begin
// Simple chunk comparison by length.
thisChunkLength := Length(thisChunk);
result := thisChunkLength - Length(thatChunk);
// If equal, the first different number counts
if result = 0 then
begin
for i := 0 to thisChunkLength-1 do
begin
result := ord(thisChunk[i+1]) - ord(thatChunk[i+1]);
if result <> 0 then Exit;
end;
end;
end
else
begin
result := CompareText(thisChunk, thatChunk);
end;
 
if result <> 0 then Exit;
end;
 
result := s1Length - s2Length;
end;
 
end.
/trunk/vcl/VTSCompat.pas
0,0 → 1,197
unit VTSCompat;
 
{$IF CompilerVersion >= 25.0}
{$LEGACYIFEND ON}
{$IFEND}
 
interface
 
uses
Dialogs, Windows, Controls, Graphics, SysUtils, CommDlg, Classes;
 
function AddTransparentIconToImageList(ImageList: TImageList; Icon: TIcon): integer;
function CompatOpenDialogExecute(OpenDialog: TOpenDialog): boolean;
function CompatSaveDialogExecute(SaveDialog: TSaveDialog): boolean;
 
implementation
 
uses
PatchU, ShlObj, ShellAPI;
 
var
pp: TPatchMethod;
 
// --- CompatOpenDialogExecute
 
type
TExtOpenDialogAccessor = class(TOpenDialog);
 
TExtOpenDialog = class(TOpenDialog)
protected
function TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool; override;
end;
 
function TExtOpenDialog.TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool;
begin
TOpenFileName(DialogData).Flags :=
TOpenFileName(DialogData).Flags and not OFN_ENABLETEMPLATE;
 
TOpenFileName(DialogData).Flags :=
TOpenFileName(DialogData).Flags and not OFN_ENABLEHOOK;
 
if pp.IsPatched then pp.Restore;
 
result := inherited TaskModalDialog(DialogFunc, DialogData);
end;
 
function CompatOpenDialogExecute(OpenDialog: TOpenDialog): boolean;
{$IF CompilerVersion < 18.5} // prior to Delphi 2007
var
x: TExtOpenDialog;
MethodPtr, MethodPtr2: function(DialogFunc: Pointer; var DialogData): Bool of object;
begin
MethodPtr := TExtOpenDialogAccessor(OpenDialog).TaskModalDialog;
 
x := TExtOpenDialog.Create(nil);
try
MethodPtr2 := x.TaskModalDialog;
pp := TPatchMethod.Create(@MethodPtr, @MethodPtr2);
try
result := OpenDialog.Execute;
if pp.IsPatched then pp.Restore;
finally
pp.Free;
end;
finally
x.Free;
end;
{$ELSE}
begin
result := OpenDialog.Execute;
{$IFEND}
end;
 
// --- CompatSaveDialogExecute
 
type
TExtSaveDialogAccessor = class(TSaveDialog);
 
TExtSaveDialog = class(TSaveDialog)
protected
function TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool; override;
end;
 
function TExtSaveDialog.TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool;
begin
// Remove the two flags which let the File Dialog GUI fall back to the old design.
TOpenFileName(DialogData).Flags :=
TOpenFileName(DialogData).Flags and not OFN_ENABLETEMPLATE;
 
TOpenFileName(DialogData).Flags :=
TOpenFileName(DialogData).Flags and not OFN_ENABLEHOOK;
 
// It is important to restore TaskModalDialog, so we don't get a stack
// overflow when calling the inherited method.
if pp.IsPatched then pp.Restore;
 
result := inherited TaskModalDialog(DialogFunc, DialogData);
end;
 
function CompatSaveDialogExecute(SaveDialog: TSaveDialog): boolean;
{$IF CompilerVersion < 18.5} // prior to Delphi 2007
var
x: TExtSaveDialog;
MethodPtr, MethodPtr2: function(DialogFunc: Pointer; var DialogData): Bool of object;
begin
MethodPtr := TExtSaveDialogAccessor(SaveDialog).TaskModalDialog;
 
x := TExtSaveDialog.Create(nil);
try
MethodPtr2 := x.TaskModalDialog;
pp := TPatchMethod.Create(@MethodPtr, @MethodPtr2);
try
result := SaveDialog.Execute;
finally
pp.Free;
end;
finally
x.Free;
end;
{$ELSE}
begin
result := OpenDialog.Execute;
{$IFEND}
end;
 
// --- AddTransparentIconToImageList
 
function RealIconSize(H: HIcon): TPoint;
// http://www.delphipages.com/forum/showthread.php?t=183999
var
IconInfo: TIconInfo;
bmpmask: TBitmap;
begin
result := Point(0, 0);
 
if H <> 0 then
begin
bmpmask := TBitmap.Create;
try
IconInfo.fIcon := true;
try
GetIconInfo(H, IconInfo);
bmpmask.Handle := IconInfo.hbmMask;
bmpmask.Dormant; //lets us free the resource without 'losing' the bitmap
finally
DeleteObject(IconInfo.hbmMask);
DeleteObject(IconInfo.hbmColor)
end;
result := Point(bmpmask.Width, bmpmask.Height);
finally
bmpmask.Free;
end;
end;
end;
 
function AddTransparentIconToImageList(ImageList: TImageList; Icon: TIcon): integer;
// http://www.delphipages.com/forum/showthread.php?t=183999
var
buffer, mask: TBitmap;
p: TPoint;
begin
// result := ImageList.AddIcon(ico);
// --> In Delphi 6, Icons with half-transparency have a black border (e.g. in ListView)
 
p := RealIconSize(icon.handle);
 
buffer := TBitmap.Create;
mask := TBitmap.Create;
try
buffer.PixelFormat := pf24bit;
mask.PixelFormat := pf24bit;
 
buffer.Width := p.X;
buffer.Height := p.Y;
buffer.Canvas.Draw(0, 0, icon);
buffer.Transparent := true;
buffer.TransparentColor := buffer.Canvas.Pixels[0,0];
 
if (ImageList.Width <> p.X) or (ImageLIst.Height <> p.Y) then
begin
ImageList.Width := p.X;
ImageList.Height := p.Y;
end;
 
// create a mask for the icon.
mask.Assign(buffer);
mask.Canvas.Brush.Color := buffer.Canvas.Pixels[0, buffer.Height -1];
mask.Monochrome := true;
 
result := ImageList.Add(buffer, mask);
finally
mask.Free;
buffer.Free;
end;
end;
 
end.
/trunk/vcl/VTSListView.pas
0,0 → 1,129
unit VTSListView;
 
interface
 
// This ListView adds support for sorting arrows
 
// Recommended usage for the OnCompare event:
(*
procedure TForm1.ListViewCompare(Sender: TObject; Item1,
Item2: TListItem; Data: Integer; var Compare: Integer);
var
ListView: TVTSListView;
begin
ListView := Sender as TVTSListView;
if ListView.CurSortedColumn = 0 then
begin
Compare := CompareText(Item1.Caption, Item2.Caption);
end
else
begin
Compare := CompareText(Item1.SubItems[ListView.CurSortedColumn-1],
Item2.SubItems[ListView.CurSortedColumn-1]);
end;
if ListView.CurSortedDesc then Compare := -Compare;
end;
*)
 
uses
Windows, Messages, SysUtils, Classes, Controls, ComCtrls, CommCtrl;
 
type
TVTSListView = class(TListView)
private
FDescending: Boolean;
FSortedColumn: Integer;
procedure WMNotifyMessage(var msg: TWMNotify); message WM_NOTIFY;
protected
procedure ShowArrowOfListViewColumn;
procedure ColClick(Column: TListColumn); override;
public
constructor Create(AOwner: TComponent); override;
published
property CurSortedColumn: integer read FSortedColumn;
property CurSortedDesc: boolean read FDescending;
end;
 
procedure Register;
 
implementation
 
// The arrows require a XP Manifest
 
{$IF not Declared(HDF_SORTUP)}
const
{ For Windows >= XP }
{$EXTERNALSYM HDF_SORTUP}
HDF_SORTUP = $0400;
{$EXTERNALSYM HDF_SORTDOWN}
HDF_SORTDOWN = $0200;
{$IFEND}
 
{ TVTSListView }
 
constructor TVTSListView.Create(AOwner: TComponent);
begin
inherited;
FSortedColumn := -1;
end;
 
procedure TVTSListView.ShowArrowOfListViewColumn;
var
Header: HWND;
Item: THDItem;
i: integer;
begin
Header := ListView_GetHeader(Handle);
ZeroMemory(@Item, SizeOf(Item));
Item.Mask := HDI_FORMAT;
 
// Remove arrows
for i := 0 to Columns.Count-1 do
begin
Header_GetItem(Header, i, Item);
Item.fmt := Item.fmt and not (HDF_SORTUP or HDF_SORTDOWN);
Header_SetItem(Header, i, Item);
end;
 
// Add arrow
Header_GetItem(Header, FSortedColumn, Item);
if FDescending then
Item.fmt := Item.fmt or HDF_SORTDOWN
else
Item.fmt := Item.fmt or HDF_SORTUP;
Header_SetItem(Header, FSortedColumn, Item);
end;
 
procedure TVTSListView.WMNotifyMessage(var msg: TWMNotify);
begin
inherited;
if (Msg.NMHdr^.code = HDN_ENDTRACK) and (FSortedColumn > -1) then
begin
ShowArrowOfListViewColumn;
end;
end;
 
procedure TVTSListView.ColClick(Column: TListColumn);
begin
if not Assigned(OnCompare) then Exit;
SortType := stNone;
if Column.Index <> FSortedColumn then
begin
FSortedColumn := Column.Index;
FDescending := False;
end
else
begin
FDescending := not FDescending;
end;
ShowArrowOfListViewColumn;
SortType := stText;
inherited;
end;
 
procedure Register;
begin
RegisterComponents('ViaThinkSoft', [TVTSListView]);
end;
 
end.
/trunk/vcl/PatchU.pas
0,0 → 1,70
unit PatchU;
 
interface
 
type
pPatchEvent = ^TPatchEvent;
 
// "Asm" opcode hack to patch an existing routine
TPatchEvent = packed record
Jump: Byte;
Offset: Integer;
end;
 
TPatchMethod = class
private
PatchedMethod, OriginalMethod: TPatchEvent;
PatchPositionMethod: pPatchEvent;
FIsPatched: boolean;
public
property IsPatched: boolean read FIsPatched;
constructor Create(const aSource, aDestination: Pointer);
destructor Destroy; override;
procedure Restore;
procedure Hook;
end;
 
implementation
 
uses
Windows, Sysutils;
 
{ TPatchMethod }
 
constructor TPatchMethod.Create(const aSource, aDestination: Pointer);
var
OldProtect: Cardinal;
begin
PatchPositionMethod := pPatchEvent(aSource);
OriginalMethod := PatchPositionMethod^;
PatchedMethod.Jump := $E9;
PatchedMethod.Offset := Integer(PByte(aDestination)) - Integer(PByte(PatchPositionMethod)) - SizeOf(TPatchEvent);
 
if not VirtualProtect(PatchPositionMethod, SizeOf(TPatchEvent), PAGE_EXECUTE_READWRITE, OldProtect) then
RaiseLastOSError;
 
Hook;
end;
 
destructor TPatchMethod.Destroy;
begin
Restore;
inherited;
end;
 
procedure TPatchMethod.Hook;
begin
if FIsPatched then Exit;
FIsPatched := true;
PatchPositionMethod^ := PatchedMethod;
end;
 
procedure TPatchMethod.Restore;
begin
if not FIsPatched then Exit;
FIsPatched := false;
PatchPositionMethod^ := OriginalMethod;
end;
 
end.