Subversion Repositories delphiutils

Compare Revisions

No changes between revisions

Regard whitespace Rev 43 → Rev 44

/trunk/Delphi Code/ParamUtils/DemoMain.ddp
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property
/trunk/Delphi Code/ParamUtils/Demo.cfg
0,0 → 1,35
-$A8
-$B-
-$C+
-$D+
-$E-
-$F-
-$G+
-$H+
-$I+
-$J-
-$K-
-$L+
-$M-
-$N+
-$O+
-$P+
-$Q-
-$R-
-$S-
-$T-
-$U-
-$V+
-$W-
-$X+
-$YD
-$Z1
-cg
-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
-H+
-W+
-M
-$M16384,1048576
-K$00400000
-LE"c:\programme\borland\delphi6\Projects\Bpl"
-LN"c:\programme\borland\delphi6\Projects\Bpl"
/trunk/Delphi Code/ParamUtils/ParamUtils.pas
0,0 → 1,92
unit ParamUtils;
 
// ParamUtils.pas
// Copyright (C) 2010 ViaThinkSoft. All rights reserved.
 
interface
 
uses
Windows, SysUtils, Classes, Functions;
 
type
TParamInfo = packed record
ParamName: String; // in actual case, if found
Found: boolean;
Position: integer; // only if found, otherwise 0
Values: TDynStringArray;
end;
 
function CheckParam(AParamStr: String; ACaseSensitive: boolean): TParamInfo;
// function DecodeFilename(): TDynStringArray;
// function GetFilenames(AOffset: integer): TDynStringArray;
// function GetFilenames(): TDynStringArray;
 
implementation
 
function _NewParamInfo: TParamInfo;
begin
result.ParamName := '';
result.Found := false;
result.Position := 0;
SetLength(result.Values, 0);
end;
 
function _IsFlag(AParam: string): boolean;
var
c: string;
begin
c := Copy(AParam, 1, 1);
 
result := (c = '/') or (c = '-');
end;
 
function CheckParam(AParamStr: String; ACaseSensitive: boolean): TParamInfo;
var
i: integer;
s: String;
begin
result := _NewParamInfo;
result.ParamName := AParamStr;
 
// Search
for i := 1 to ParamCount do
begin
s := ParamStr(i);
 
if s = '--' then break;
 
if ACaseSensitive then
begin
result.Found := AnsiUpperCase(AParamStr) = AnsiUpperCase(s);
end
else
begin
result.Found := AParamStr = s;
end;
 
if result.Found then
begin
result.Position := i;
result.ParamName := s; // Correct case
break;
end;
end;
 
// Determinate value
if result.Found then
begin
for i := result.Position+1 to ParamCount do
begin
s := ParamStr(i);
 
if not _IsFlag(s) then
begin
AppendStringToArray(result.Values, s);
end;
end;
end;
end;
 
 
 
end.
/trunk/Delphi Code/ParamUtils/Demo.exe
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property
/trunk/Delphi Code/ParamUtils/Demo.dpr
0,0 → 1,15
program Demo;
 
uses
Forms,
DemoMain in 'DemoMain.pas' {Form1},
ParamUtils in 'ParamUtils.pas',
Functions in 'Functions.pas';
 
{$R *.res}
 
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
/trunk/Delphi Code/ParamUtils/Functions.pas
0,0 → 1,66
unit Functions;
 
interface
 
uses
Windows, SysUtils;
 
type
TDynStringArray = array of String;
 
procedure AppendStringToArray(var x: TDynStringArray; const s: string);
 
function ExtendFilename(s: string; AllowDirs: boolean): TDynStringArray;
 
implementation
 
procedure AppendStringToArray(var x: TDynStringArray; const s: string);
begin
SetLength(x, Length(x)+1);
x[Length(x)-1] := s;
end;
 
// Src: http://www.swissdelphicenter.ch/torry/showcode.php?id=1140
function _ExpandEnvironment(const strValue: string): string;
var
chrResult: array[0..1023] of Char;
wrdReturn: DWORD;
begin
wrdReturn := ExpandEnvironmentStrings(PChar(strValue), chrResult, 1024);
if wrdReturn = 0 then
Result := strValue
else
begin
Result := Trim(chrResult);
end;
end;
 
function ExtendFilename(s: string; AllowDirs: boolean): TDynStringArray;
var
SR: TSearchRec;
IsFound: boolean;
begin
// 1. Expand environment variables
s := _ExpandEnvironment(s);
 
// 2. Expand wildcards (and ensure that file/directory actually exists!)
if AllowDirs then
IsFound := FindFirst(s, faAnyFile, SR) = 0
else
IsFound := FindFirst(s, faAnyFile-faDirectory, SR) = 0;
 
try
while IsFound do
begin
// 3. Make UNC
s := ExpandUNCFileName(SR.Name);
AppendStringToArray(result, s);
 
IsFound := FindNext(SR) = 0;
end;
finally
FindClose(SR);
end;
end;
 
end.
/trunk/Delphi Code/ParamUtils/Demo.dof
0,0 → 1,87
[FileVersion]
Version=6.0
[Compiler]
A=8
B=0
C=1
D=1
E=0
F=0
G=1
H=1
I=1
J=0
K=0
L=1
M=0
N=1
O=1
P=1
Q=0
R=0
S=0
T=0
U=0
V=1
W=0
X=1
Y=1
Z=1
ShowHints=1
ShowWarnings=1
UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
[Linker]
MapFile=0
OutputObjs=0
ConsoleApp=1
DebugInfo=0
RemoteSymbols=0
MinStackSize=16384
MaxStackSize=1048576
ImageBase=4194304
ExeDescription=
[Directories]
OutputDir=
UnitOutputDir=
PackageDLLOutputDir=
PackageDCPOutputDir=
SearchPath=
Packages=
Conditionals=
DebugSourceDirs=
UsePackages=0
[Parameters]
RunParams=
HostApplication=
Launcher=
UseLauncher=0
DebugCWD=
[Language]
ActiveLang=
ProjectLang=
RootDir=
[Version Info]
IncludeVerInfo=0
AutoIncBuild=0
MajorVer=1
MinorVer=0
Release=0
Build=0
Debug=0
PreRelease=0
Special=0
Private=0
DLL=0
Locale=1031
CodePage=1252
[Version Info Keys]
CompanyName=
FileDescription=
FileVersion=1.0.0.0
InternalName=
LegalCopyright=
LegalTrademarks=
OriginalFilename=
ProductName=
ProductVersion=1.0.0.0
Comments=
/trunk/Delphi Code/ParamUtils/DemoMain.pas
0,0 → 1,25
unit DemoMain;
 
interface
 
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
 
type
TForm1 = class(TForm)
Button1: TButton;
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
 
var
Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
end.
/trunk/Delphi Code/ParamUtils/Demo.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property
/trunk/Delphi Code/ParamUtils/DemoMain.dfm
0,0 → 1,24
object Form1: TForm1
Left = 192
Top = 131
Width = 870
Height = 640
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 120
TextHeight = 16
object Button1: TButton
Left = 120
Top = 136
Width = 409
Height = 241
Caption = 'Button1'
TabOrder = 0
end
end
/trunk/Delphi Code/DragNDropDlgs/DlgExtended.res
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property
/trunk/Delphi Code/DragNDropDlgs/WindowsCompat.pas
0,0 → 1,78
unit WindowsCompat;
 
// Ref: http://qc.embarcadero.com/wc/qcmain.aspx?d=48771
 
interface
 
uses
Windows;
 
{$IF NOT DECLARED(GWLP_WNDPROC)}
const
GWLP_WNDPROC = -4;
{$IFEND}
 
{$IF NOT DECLARED(PtrInt)}
type
{$IFDEF WIN32}
PtrInt = Longint;
{$ELSE}
PtrInt = Int64;
{$ENDIF}
{$IFEND}
 
{$IF NOT DECLARED(LONG_PTR)}
type
LONG_PTR = PtrInt; // Offizielle Deklaration?
{$IFEND}
 
{$IF NOT DECLARED(WNDPROC)}
type
WNDPROC = TFNWndProc; // Offizielle Deklaration?
{$IFeND}
 
{$IF NOT DECLARED(GetWindowLongPtr)}
{$DEFINE Do_Implement_GetWindowLongPtr}
function GetWindowLongPtr(hWnd: HWND; nIndex: Integer): LONG_PTR; stdcall;
{$IFEND}
 
{$IF NOT DECLARED(SetWindowLongPtr)}
{$DEFINE Do_Implement_SetWindowLongPtr}
function SetWindowLongPtr(hWnd: HWND; nIndex: Integer; dwNewLong: LONG_PTR): LONG_PTR; stdcall;
{$IFEND}
 
implementation
 
{$IFDEF Do_Implement_GetWindowLongPtr}
{$IFNDEF _WIN64}
{$IFDEF UNICODE}
function GetWindowLongPtr; external user32 name 'GetWindowLongW';
{$ELSE}
function GetWindowLongPtr; external user32 name 'GetWindowLongA';
{$ENDIF}
{$ELSE}
{$IFDEF UNICODE}
function GetWindowLongPtr; external user32 name 'GetWindowLongPtrW';
{$ELSE}
function GetWindowLongPtr; external user32 name 'GetWindowLongPtrA';
{$ENDIF}
{$ENDIF}
{$ENDIF}
 
{$IFDEF Do_Implement_SetWindowLongPtr}
{$IFNDEF _WIN64}
{$IFDEF UNICODE}
function SetWindowLongPtr; external user32 name 'SetWindowLongW';
{$ELSE}
function SetWindowLongPtr; external user32 name 'SetWindowLongA';
{$ENDIF}
{$ELSE}
{$IFDEF UNICODE}
function SetWindowLongPtr; external user32 name 'SetWindowLongPtrW';
{$ELSE}
function SetWindowLongPtr; external user32 name 'SetWindowLongPtrA';
{$ENDIF}
{$ENDIF}
{$ENDIF}
 
end.
/trunk/Delphi Code/DragNDropDlgs/DlgExtended.cfg
0,0 → 1,35
-$A8
-$B-
-$C+
-$D+
-$E-
-$F-
-$G+
-$H+
-$I+
-$J-
-$K-
-$L+
-$M-
-$N+
-$O+
-$P+
-$Q-
-$R-
-$S-
-$T-
-$U-
-$V+
-$W-
-$X+
-$YD
-$Z1
-cg
-AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
-H+
-W+
-M
-$M16384,1048576
-K$00400000
-LE"c:\programme\borland\delphi6\Projects\Bpl"
-LN"c:\programme\borland\delphi6\Projects\Bpl"
/trunk/Delphi Code/DragNDropDlgs/Main.pas
0,0 → 1,41
unit Main;
 
interface
 
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
 
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
 
var
Form1: TForm1;
 
implementation
 
uses
DragDropOpenDlg;
 
{$R *.dfm}
 
procedure TForm1.Button1Click(Sender: TObject);
var
x: TDragDropOpenDlg;
begin
x := TDragDropOpenDlg.Create(self);
try
if x.execute then ShowMessage('Datei erhalten: ' + x.FileName);
finally
x.free;
end;
end;
 
end.
/trunk/Delphi Code/DragNDropDlgs/DlgExtended.exe
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property
/trunk/Delphi Code/DragNDropDlgs/MethodPtr.pas
0,0 → 1,45
unit MethodPtr;
 
// Ref: http://www.swissdelphicenter.ch/de/showcode.php?id=1671
 
interface
 
function MakeProcInstance(M: TMethod): Pointer;
procedure FreeProcInstance(ProcInstance: Pointer);
 
implementation
 
// type TMyMethod = procedure of object;
 
function MakeProcInstance(M: TMethod): Pointer;
begin
// allocate memory
GetMem(Result, 15);
asm
// MOV ECX,
MOV BYTE PTR [EAX], $B9
MOV ECX, M.Data
MOV DWORD PTR [EAX+$1], ECX
// POP EDX
MOV BYTE PTR [EAX+$5], $5A
// PUSH ECX
MOV BYTE PTR [EAX+$6], $51
// PUSH EDX
MOV BYTE PTR [EAX+$7], $52
// MOV ECX,
MOV BYTE PTR [EAX+$8], $B9
MOV ECX, M.Code
MOV DWORD PTR [EAX+$9], ECX
// JMP ECX
MOV BYTE PTR [EAX+$D], $FF
MOV BYTE PTR [EAX+$E], $E1
end;
end;
 
procedure FreeProcInstance(ProcInstance: Pointer);
begin
// free memory
FreeMem(ProcInstance, 15);
end;
 
end.
/trunk/Delphi Code/DragNDropDlgs/Main.dfm
0,0 → 1,25
object Form1: TForm1
Left = 192
Top = 131
Width = 870
Height = 640
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -13
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 120
TextHeight = 16
object Button1: TButton
Left = 136
Top = 136
Width = 161
Height = 81
Caption = 'Button1'
TabOrder = 0
OnClick = Button1Click
end
end
/trunk/Delphi Code/DragNDropDlgs/DlgExtended.dpr
0,0 → 1,14
program DlgExtended;
 
uses
Forms,
Main in 'Main.pas' {Form1},
DragDropOpenDlg in 'DragDropOpenDlg.pas';
 
{$R *.res}
 
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
/trunk/Delphi Code/DragNDropDlgs/DragDropOpenDlg.pas
0,0 → 1,144
unit DragDropOpenDlg;
 
// Improvements to the Dialogs
// - New design
// - Overwrite (Save) / MustExists (Open) as default
// - DragDrop feature!
 
// TODO (incl. QuerySystemMenu): Besser mit WndProc(var Message) und Dispatch wie in Dialogs.pas arbeiten?
 
interface
 
uses
Windows, Dialogs, Classes, messages, shellapi, sysutils, WindowsCompat;
 
type
TDragDropOpenDlg = class(TOpenDialog)
private
MsgProcPointer: pointer;
FPrevWndProc: LONG_PTR;
procedure OpenDialog1Show(Sender: TObject);
procedure OpenDialog1Close(Sender: TObject);
function msgr(Handle: HWnd; Msg: UInt;
WParam: Windows.WParam; LParam: Windows.LParam): LResult; stdcall;
public
constructor Create(AOwner: TComponent); override;
end;
 
implementation
 
uses
MethodPtr;
 
{ TDragDropOpenDlg }
 
const
IDA = 101;
 
function TDragDropOpenDlg.msgr(Handle: HWnd; Msg: UInt;
WParam: Windows.WParam; LParam: Windows.LParam): LResult;
const
MAXFILENAME = 255; // TODO MAX_PATH?
var
cnt, fileCount : integer;
fileName : array [0..MAXFILENAME] of char;
begin
if Msg = WM_DROPFILES then
begin
// how many files dropped?
fileCount := DragQueryFile(wParam, $FFFFFFFF, fileName, MAXFILENAME) ;
 
// query for file names
 
for cnt := 0 to fileCount-1 do
begin
DragQueryFile(wParam, cnt, fileName, MAXFILENAME) ;
 
//do something with the file(s)
showmessage('Drag accepted: ' + filename);
end;
 
//release memory
DragFinish(wParam);
 
// TODO: Geht nicht
SendMessage(Self.Handle, WM_CLOSE, 0, 0);
DestroyWindow(Self.Handle);
end;
 
result := Windows.CallWindowProc({!!!}WindowsCompat.WNDPROC(FPrevWndProc), Handle, Msg, WParam, LParam)
end;
 
procedure TDragDropOpenDlg.OpenDialog1Show(Sender: TObject);
var
hParent: THandle;
rect: TRect;
hEdit: THandle;
f: TMethod;
begin
// OpenDialog1.Handle ist irgendwie das falsche :?
hParent := GetParent(Handle);
// Position und Größe ermitteln
GetWindowRect(hParent, rect);
// Dialog vergrößern für Edit
SetWindowPos(hParent, 0, 0, 0, rect.Right - rect.Left, rect.Bottom - rect.Top
+ 25*2, SWP_NOMOVE);
// Edit erzeugen, ID = 101
hEdit := CreateWindowEx(WS_EX_CLIENTEDGE, 'EDIT', '', WS_VISIBLE or WS_CHILD,
195, rect.Bottom - rect.Top - 27, 150, 20, hParent, IDA, 0, nil);
if hEdit = 0 then
RaiseLastOSError;
 
FPrevWndProc := GetWindowLongPtr(hEdit, GWLP_WNDPROC);
 
f.Code := @TDragDropOpenDlg.msgr;
f.Data := Self;
MsgProcPointer := {!!!}MethodPtr.MakeProcInstance(f);
 
// Problem: Kann es zu Komplikationen mit mehreren msg handlern kommen?
// (Beim vermischten register+unregister !)
 
SetWindowLongPtr(hEdit, GWLP_WNDPROC, LONG_PTR(MsgProcPointer));
DragAcceptFiles(hEdit, true);
end;
 
procedure TDragDropOpenDlg.OpenDialog1Close(Sender: TObject);
var
hParent: THandle;
hEdit: THandle;
Buffer: PChar;
len: Integer;
begin
hParent := GetParent(Handle);
// Handle des Edits ermitteln, ID = 101 siehe oben
hEdit := GetDlgItem(hParent, IDA);
 
DragAcceptFiles(hEdit, false);
SetWindowLongPtr(hEdit, GWLP_WNDPROC, FPrevWndProc);
 
// Speicher allozieren
len := SendMessage(hEdit, WM_GETTEXTLENGTH, 0, 0);
GetMem(Buffer, len + 1);
try
ZeroMemory(Buffer, len + 1);
// Text aus Edit holen
SendMessage(hEdit, WM_GETTEXT, len, lParam(Buffer));
ShowMessage('Text im Editfeld:' + Buffer);
finally
FreeMem(Buffer, len + 1);
end;
end;
 
constructor TDragDropOpenDlg.Create(AOwner: TComponent);
begin
inherited;
 
// TODO: Als Wrapper, damit auch weiter verwendbar!
OnClose := OpenDialog1Close;
OnShow := OpenDialog1Show;
 
end;
 
// {!!!} = Bitte auch in QuerySystemMenu verwenden!
 
end.
/trunk/Delphi Code/DragNDropDlgs/DlgExtended.dof
0,0 → 1,87
[FileVersion]
Version=6.0
[Compiler]
A=8
B=0
C=1
D=1
E=0
F=0
G=1
H=1
I=1
J=0
K=0
L=1
M=0
N=1
O=1
P=1
Q=0
R=0
S=0
T=0
U=0
V=1
W=0
X=1
Y=1
Z=1
ShowHints=1
ShowWarnings=1
UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;
[Linker]
MapFile=0
OutputObjs=0
ConsoleApp=1
DebugInfo=0
RemoteSymbols=0
MinStackSize=16384
MaxStackSize=1048576
ImageBase=4194304
ExeDescription=
[Directories]
OutputDir=
UnitOutputDir=
PackageDLLOutputDir=
PackageDCPOutputDir=
SearchPath=
Packages=
Conditionals=
DebugSourceDirs=
UsePackages=0
[Parameters]
RunParams=
HostApplication=
Launcher=
UseLauncher=0
DebugCWD=
[Language]
ActiveLang=
ProjectLang=
RootDir=
[Version Info]
IncludeVerInfo=0
AutoIncBuild=0
MajorVer=1
MinorVer=0
Release=0
Build=0
Debug=0
PreRelease=0
Special=0
Private=0
DLL=0
Locale=1031
CodePage=1252
[Version Info Keys]
CompanyName=
FileDescription=
FileVersion=1.0.0.0
InternalName=
LegalCopyright=
LegalTrademarks=
OriginalFilename=
ProductName=
ProductVersion=1.0.0.0
Comments=