/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. |