neoturk: ...Load the cd-rom icon ?...
function GetCDIcon(Drive: Char): TIcon;
var
ico: TIcon;
ini: TIniFile;
s, p: string;
i, j: Integer;
begin
//Abbrechen wenn "AutoRun.Inf" nicht existiert.
//Abort if "AutoRun.inf" doesn't exists.
if FileExists(Drive + ':autorun.inf') = False then Exit;
//"AutoRun.inf" öffnen
//Opens the "AutoRun.inf"
ini := TIniFile.Create(Drive + ':autorun.inf');
ico := TIcon.Create;
try
//Dateinamen lesen
//Read the filename
s := ini.ReadString('Autorun', 'ICON', '');
//Abbrechen, wenn kein Icon festgelegt wurde
//Abort if there is no icon specified
if s = '' then Exit;
//Icon von Datei laden
//load the icon from a file
if FileExists(s) then ico.LoadFromFile(s);
if FileExists(Drive + ':' + s) then ico.LoadFromFile(Drive + ':' + s);
//Icon aus einer Resource laden
//Load the icon from a Win32 resource
if (FileExists(s) = False) and (FileExists(Drive + ':' + s) = False) then
begin
for j := (Pos(',', s) + 1) to Length(s) do
begin
p := p + s[j];
end;
i := StrToInt(p);
for j := Length(s) downto (Pos(',', s)) do
Delete(s, j, Length(s));
if FileExists(s) = False then s := Drive + ':' + s;
ico.Handle := ExtractIcon(hinstance, PChar(s), i);
end;
Result := ico;
finally
ini.Free;
end;
end;
Delphi - .....................................
neoturk: ...Load the cd-rom icon ?...
function GetCDIcon(Drive: Char): TIcon;
var
ico: TIcon;
ini: TIniFile;
s, p: string;
i, j: Integer;
begin
//Abbrechen wenn "AutoRun.Inf" nicht existiert.
//Abort if "AutoRun.inf" doesn't exists.
if FileExists(Drive + ':autorun.inf') = False then Exit;
//"AutoRun.inf" öffnen
//Opens the "AutoRun.inf"
ini := TIniFile.Create(Drive + ':autorun.inf');
ico := TIcon.Create;
try
//Dateinamen lesen
//Read the filename
s := ini.ReadString('Autorun', 'ICON', '');
//Abbrechen, wenn kein Icon festgelegt wurde
//Abort if there is no icon specified
if s = '' then Exit;
//Icon von Datei laden
//load the icon from a file
if FileExists(s) then ico.LoadFromFile(s);
if FileExists(Drive + ':' + s) then ico.LoadFromFile(Drive + ':' + s);
//Icon aus einer Resource laden
//Load the icon from a Win32 resource
if (FileExists(s) = False) and (FileExists(Drive + ':' + s) = False) then
begin
for j := (Pos(',', s) + 1) to Length(s) do
begin
p := p + s[j];
end;
i := StrToInt(p);
for j := Length(s) downto (Pos(',', s)) do
Delete(s, j, Length(s));
if FileExists(s) = False then s := Drive + ':' + s;
ico.Handle := ExtractIcon(hinstance, PChar(s), i);
end;
Result := ico;
finally
ini.Free;
end;
end;
Delphi - .....................................
neoturk: ...Encrypt-decrypt files with windows ntfs functions ?...
{....}
{
Dieser Tip funktioniert ab Windows 2000 (NTFS 5)
Diese 2 Funktionen sind in windows.pas definiert, jedoch sind sie dort
falsch definiert. Deshalb hier die eigene Definition.
}
{
This tip works with Windows 2000 (NTFS 5) and later
These 2 functions are defined in windows.pas, but they're defined wrong. In this
case our own definition.
}
function EncryptFile(lpFilename: PChar): BOOL; stdcall;
external advapi32 name 'EncryptFileA';
function DecryptFile(lpFilename: PChar; dwReserved: DWORD): BOOL; stdcall;
external advapi32 name 'DecryptFileA';
{....}
procedure TForm1.Button1Click(Sender: TObject);
begin
if not EncryptFile('c:temp') then
ShowMessage('Can''t encrypt directory.');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if not DecryptFile('c:temp', 0) then
ShowMessage('Can''t decrypt directory.');
end;
Delphi - .....................................
neoturk: ...Encrypt-decrypt files with windows ntfs functions ?...
{....}
{
Dieser Tip funktioniert ab Windows 2000 (NTFS 5)
Diese 2 Funktionen sind in windows.pas definiert, jedoch sind sie dort
falsch definiert. Deshalb hier die eigene Definition.
}
{
This tip works with Windows 2000 (NTFS 5) and later
These 2 functions are defined in windows.pas, but they're defined wrong. In this
case our own definition.
}
function EncryptFile(lpFilename: PChar): BOOL; stdcall;
external advapi32 name 'EncryptFileA';
function DecryptFile(lpFilename: PChar; dwReserved: DWORD): BOOL; stdcall;
external advapi32 name 'DecryptFileA';
{....}
procedure TForm1.Button1Click(Sender: TObject);
begin
if not EncryptFile('c:temp') then
ShowMessage('Can''t encrypt directory.');
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
if not DecryptFile('c:temp', 0) then
ShowMessage('Can''t decrypt directory.');
end;
Delphi - .....................................
neoturk: ...Send data to another program by auto-drag-drop ?...
uses
ShellAPI;
function MakeDrop(const FileNames: array of string): THandle;
// Creates a hDrop Object
// erzeugt ein hDrop Object
var
I, Size: Integer;
Data: PDragInfoA;
P: PChar;
begin
// Calculate memory size needed
// berechne notwendig Speichergröße
Size := SizeOf(TDragInfoA) + 1;
for I := 0 to High(FileNames) do
Inc(Size, Length(FileNames[I]) + 1);
// allocate the memory
// alloziere den speicher
Result := GlobalAlloc(GHND or GMEM_SHARE, Size);
if Result <> 0 then
begin
Data := GlobalLock(Result);
if Data <> nil then
try
// fill up with data
// fülle daten
Data.uSize := SizeOf(TDragInfoA);
P := PChar(@Data.grfKeyState) + 4;
Data.lpFileList := P;
// filenames at the at of the header (separated with #0)
// am ende des headers nun die filenamen getrennt mit #0
for I := 0 to High(FileNames) do
begin
Size := Length(FileNames[I]);
Move(Pointer(FileNames[I])^, P^, Size);
Inc(P, Size + 1);
end;
finally
GlobalUnlock(Result);
end
else
begin
GlobalFree(Result);
Result := 0;
end;
end;
end;
function MyEnum(Wnd: hWnd; Res: PInteger): Bool; stdcall;
// search for a edit control with classname 'TEditControl'
// suche ein child fenster mit klassennamen 'TEditControl'
var
N: string;
begin
SetLength(N, MAX_PATH);
SetLength(N, GetClassName(Wnd, Pointer(N), Length(N)));
Result := AnsiCompareText('TEditControl', N) <> 0;
if not Result then Res^ := Wnd;
end;
// Example: Open msdos.sys in Delphi's Editor window
// Beispiel: msdos.sys im Delphi Editor öffnen
procedure TForm1.Button1Click(Sender: TObject);
var
Wnd: HWnd;
Drop: hDrop;
begin
// search for Delphi's Editor
// suche Delphis Editor Fenster
EnumChildWindows(FindWindow('TEditWindow', nil), @MyEnum, Integer(@Wnd));
if IsWindow(Wnd) then
begin
// Delphi's Editor found. Open msdos.sys
// Delphis editor gefunden, also öffne msdos.sys
Drop := MakeDrop(['c:msdos.sys']);
if Drop <> 0 then PostMessage(Wnd, wm_DropFiles, Drop, 0);
// Free the memory?
// Speicher wieder freigeben?
GlobalFree(Drop);
end;
end;
Delphi - .....................................
neoturk: ...Send data to another program by auto-drag-drop ?...
uses
ShellAPI;
function MakeDrop(const FileNames: array of string): THandle;
// Creates a hDrop Object
// erzeugt ein hDrop Object
var
I, Size: Integer;
Data: PDragInfoA;
P: PChar;
begin
// Calculate memory size needed
// berechne notwendig Speichergröße
Size := SizeOf(TDragInfoA) + 1;
for I := 0 to High(FileNames) do
Inc(Size, Length(FileNames[I]) + 1);
// allocate the memory
// alloziere den speicher
Result := GlobalAlloc(GHND or GMEM_SHARE, Size);
if Result <> 0 then
begin
Data := GlobalLock(Result);
if Data <> nil then
try
// fill up with data
// fülle daten
Data.uSize := SizeOf(TDragInfoA);
P := PChar(@Data.grfKeyState) + 4;
Data.lpFileList := P;
// filenames at the at of the header (separated with #0)
// am ende des headers nun die filenamen getrennt mit #0
for I := 0 to High(FileNames) do
begin
Size := Length(FileNames[I]);
Move(Pointer(FileNames[I])^, P^, Size);
Inc(P, Size + 1);
end;
finally
GlobalUnlock(Result);
end
else
begin
GlobalFree(Result);
Result := 0;
end;
end;
end;
function MyEnum(Wnd: hWnd; Res: PInteger): Bool; stdcall;
// search for a edit control with classname 'TEditControl'
// suche ein child fenster mit klassennamen 'TEditControl'
var
N: string;
begin
SetLength(N, MAX_PATH);
SetLength(N, GetClassName(Wnd, Pointer(N), Length(N)));
Result := AnsiCompareText('TEditControl', N) <> 0;
if not Result then Res^ := Wnd;
end;
// Example: Open msdos.sys in Delphi's Editor window
// Beispiel: msdos.sys im Delphi Editor öffnen
procedure TForm1.Button1Click(Sender: TObject);
var
Wnd: HWnd;
Drop: hDrop;
begin
// search for Delphi's Editor
// suche Delphis Editor Fenster
EnumChildWindows(FindWindow('TEditWindow', nil), @MyEnum, Integer(@Wnd));
if IsWindow(Wnd) then
begin
// Delphi's Editor found. Open msdos.sys
// Delphis editor gefunden, also öffne msdos.sys
Drop := MakeDrop(['c:msdos.sys']);
if Drop <> 0 then PostMessage(Wnd, wm_DropFiles, Drop, 0);
// Free the memory?
// Speicher wieder freigeben?
GlobalFree(Drop);
end;
end;
Delphi - .....................................
neoturk: ...Execute a document and wait for it to finish ?...
{
This tip allows you to open any document with its
associated application (not only exe, com) and wait for it to finish.
}
{
Dieser Tip ermöglicht es, nicht nur normale Programme, sondern auch Dateien,
die mit Programmen geöffnet werden, auszuführen und darauf zu warten,
bis sie beendet sind.
}
uses
Shellapi;
function StartAssociatedExe(FileName: string; var ErrorCode: Cardinal): Boolean;
var
Prg: string;
ProcessInfo: TProcessInformation;
StartupInfo: TStartupInfo;
begin
SetLength(Prg, MAX_PATH);
Result := False;
ErrorCode := FindExecutable(PChar(FileName), nil, PChar(Prg));
if ErrorCode >= 32 then
begin
SetLength(Prg, StrLen(PChar(Prg)));
FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
with StartupInfo do
begin
cb := SizeOf(TStartupInfo);
wShowWindow := SW_SHOW;
end;
if CreateProcess(PChar(Prg), PChar(Format('%s %s', [Prg, FileName])),
nil, nil, False, NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then
begin
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess, ErrorCode);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
Result := True;
end
else
ErrorCode := GetLastError;
end;
end;
// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
var
ErrorCode: Cardinal;
begin
StartAssociatedExe('c:test.doc', ErrorCode);
end;
Delphi - .....................................
neoturk: ...Execute a document and wait for it to finish ?...
{
This tip allows you to open any document with its
associated application (not only exe, com) and wait for it to finish.
}
{
Dieser Tip ermöglicht es, nicht nur normale Programme, sondern auch Dateien,
die mit Programmen geöffnet werden, auszuführen und darauf zu warten,
bis sie beendet sind.
}
uses
Shellapi;
function StartAssociatedExe(FileName: string; var ErrorCode: Cardinal): Boolean;
var
Prg: string;
ProcessInfo: TProcessInformation;
StartupInfo: TStartupInfo;
begin
SetLength(Prg, MAX_PATH);
Result := False;
ErrorCode := FindExecutable(PChar(FileName), nil, PChar(Prg));
if ErrorCode >= 32 then
begin
SetLength(Prg, StrLen(PChar(Prg)));
FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
with StartupInfo do
begin
cb := SizeOf(TStartupInfo);
wShowWindow := SW_SHOW;
end;
if CreateProcess(PChar(Prg), PChar(Format('%s %s', [Prg, FileName])),
nil, nil, False, NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo) then
begin
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess, ErrorCode);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
Result := True;
end
else
ErrorCode := GetLastError;
end;
end;
// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
var
ErrorCode: Cardinal;
begin
StartAssociatedExe('c:test.doc', ErrorCode);
end;
Delphi - .....................................
neoturk: ...Get the width and height of a gif-file ?...
type
TImageSize = record
Width: Integer;
Height: Integer;
end;
function ReadGIFSize(Stream: TStream): TImageSize;
type
TGifHeader = record
Signature: array [0..5] of Char;
Width, Height: Word;
end;
var
Header: TGifHeader;
begin
FillChar(Header, SizeOf(TGifHeader), #0);
Result.Width := -1;
Result.Height := -1;
with Stream do
begin
Seek(0, soFromBeginning);
ReadBuffer(Header, SizeOf(TGifHeader));
end;
if (AnsiUpperCase(Header.Signature) = 'GIF89A') or
(AnsiUpperCase(Header.Signature) = 'GIF87A') then
begin
Result.Width := Header.Width;
Result.Height := Header.Height;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
const
FileName = 'D:test.gif';
var
fs: TFileStream;
gifsize: TImageSize;
begin
fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
gifsize := ReadGIFSize(fs);
ShowMessage(Format('Breite %d Höhe %d', [gifsize.Width, gifsize.Height]));
finally
fs.Free;
end;
end;
Delphi - .....................................
neoturk: ...Get the width and height of a gif-file ?...
type
TImageSize = record
Width: Integer;
Height: Integer;
end;
function ReadGIFSize(Stream: TStream): TImageSize;
type
TGifHeader = record
Signature: array [0..5] of Char;
Width, Height: Word;
end;
var
Header: TGifHeader;
begin
FillChar(Header, SizeOf(TGifHeader), #0);
Result.Width := -1;
Result.Height := -1;
with Stream do
begin
Seek(0, soFromBeginning);
ReadBuffer(Header, SizeOf(TGifHeader));
end;
if (AnsiUpperCase(Header.Signature) = 'GIF89A') or
(AnsiUpperCase(Header.Signature) = 'GIF87A') then
begin
Result.Width := Header.Width;
Result.Height := Header.Height;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
const
FileName = 'D:test.gif';
var
fs: TFileStream;
gifsize: TImageSize;
begin
fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
gifsize := ReadGIFSize(fs);
ShowMessage(Format('Breite %d Höhe %d', [gifsize.Width, gifsize.Height]));
finally
fs.Free;
end;
end;
