Programlama yapalım ve Öğrenelim.

Aktif pencerenin başlığının alınması

function ActiveCaption: string;

var

Handle: THandle;

Len: LongInt;

Title: string;

begin

Result := '';

Handle := GetForegroundWindow;

if Handle <> 0 then

begin

Len := GetWindowTextLength(Handle) + 1;

SetLength(Title, Len);

GetWindowText(Handle, PChar(Title), Len);

ActiveCaption := TrimRight(Title);

end;

Formunuza timer nesnesi ekleyin

procedure TForm1.Timer1Timer(Sender: TObject);

begin

Label1.Caption := ActiveCaption;

end;

Delphi - .....................................

Geçerli printerin değiştirilmesi

Aktif printerin değiştirilmesi

Printerin isminin girilmesi yeterli

procedure SetDefaultPrinter(PrinterName: String) ;

var

j: Integer;

Device : PChar;

Driver : Pchar;

Port : Pchar;

HdeviceMode: Thandle;

aPrinter : TPrinter;

begin

Printer.PrinterIndex := -1;

getmem(Device, 255) ;

getmem(Driver, 255) ;

getmem(Port, 255) ;

aPrinter := TPrinter.create;

for j := 0 to Printer.printers.Count-1 do

begin

if Printer.printers[j] = PrinterName then

begin

aprinter.printerindex := i;

aPrinter.getprinter

(device, driver, port, HdeviceMode) ;

StrCat(Device, ',') ;

StrCat(Device, Driver ) ;

StrCat(Device, Port ) ;

WriteProfileString('windows', 'device', Device) ;

StrCopy( Device, 'windows' ) ;

SendMessage(HWND_BROADCAST, WM_WININICHANGE,

0, Longint(@Device)) ;

end;

Freemem(Device, 255) ;

Freemem(Driver, 255) ;

Freemem(Port, 255) ;

aPrinter.Free;

end;

Delphi - .....................................

Geçerli printerin değiştirilmesi

Aktif printerin değiştirilmesi

Printerin isminin girilmesi yeterli

procedure SetDefaultPrinter(PrinterName: String) ;

var

j: Integer;

Device : PChar;

Driver : Pchar;

Port : Pchar;

HdeviceMode: Thandle;

aPrinter : TPrinter;

begin

Printer.PrinterIndex := -1;

getmem(Device, 255) ;

getmem(Driver, 255) ;

getmem(Port, 255) ;

aPrinter := TPrinter.create;

for j := 0 to Printer.printers.Count-1 do

begin

if Printer.printers[j] = PrinterName then

begin

aprinter.printerindex := i;

aPrinter.getprinter

(device, driver, port, HdeviceMode) ;

StrCat(Device, ',') ;

StrCat(Device, Driver ) ;

StrCat(Device, Port ) ;

WriteProfileString('windows', 'device', Device) ;

StrCopy( Device, 'windows' ) ;

SendMessage(HWND_BROADCAST, WM_WININICHANGE,

0, Longint(@Device)) ;

end;

Freemem(Device, 255) ;

Freemem(Driver, 255) ;

Freemem(Port, 255) ;

aPrinter.Free;

end;

Delphi - .....................................

Dosya yerel sürücüde mi?Yoksa uzak sürücüde mi?

function IsOnLocalDrive(aFileName: string): Boolean;

var

aDrive: string;

begin

aDrive := ExtractFileDrive(aFileName);

if (GetDriveType(PChar(aDrive)) = DRIVE_REMOVABLE) or

(GetDriveType(PChar(aDrive)) = DRIVE_FIXED) then

Result := True

else

Result := False;

end;

//Kullanımı

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

if IsOnLocalDrive(OpenDialog1.FileName) then

ShowMessage(OpenDialog1.FileName + ' dosyası yerel sürücüde bulunuyor');

end;

Delphi - .....................................

Dosya yerel sürücüde mi?Yoksa uzak sürücüde mi?

function IsOnLocalDrive(aFileName: string): Boolean;

var

aDrive: string;

begin

aDrive := ExtractFileDrive(aFileName);

if (GetDriveType(PChar(aDrive)) = DRIVE_REMOVABLE) or

(GetDriveType(PChar(aDrive)) = DRIVE_FIXED) then

Result := True

else

Result := False;

end;

//Kullanımı

procedure TForm1.Button1Click(Sender: TObject);

begin

if OpenDialog1.Execute then

if IsOnLocalDrive(OpenDialog1.FileName) then

ShowMessage(OpenDialog1.FileName + ' dosyası yerel sürücüde bulunuyor');

end;

Delphi - .....................................

Dosya veya string şifreleme-şifre çözme

unit EZCrypt;

{modeled by Ben Hochstrasser(bhoc@surfeu.ch) after some code snippet from borland}

interface

uses Windows, Classes;

type

TWordTriple = Array[0..2] of Word;

function FileEncrypt(InFile, OutFile: String; Key: TWordTriple): boolean;

function FileDecrypt(InFile, OutFile: String; Key: TWordTriple): boolean;

function TextEncrypt(const s: string; Key: TWordTriple): string;

function TextDecrypt(const s: string; Key: TWordTriple): string;

function MemoryEncrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;

function MemoryDecrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;

implementation

function MemoryEncrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;

var

pIn, pOut: ^byte;

i : Cardinal;

begin

if SrcSize = TargetSize then

begin

pIn := Src;

pOut := Target;

for i := 1 to SrcSize do

begin

pOut^ := pIn^ xor (Key[2] shr 8);

Key[2] := Byte(pIn^ + Key[2]) * Key[0] + Key[1];

inc(pIn);

inc(pOut);

end;

Result := True;

end else

Result := False;

end;

function MemoryDecrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;

var

pIn, pOut: ^byte;

i : Cardinal;

begin

if SrcSize = TargetSize then

begin

pIn := Src;

pOut := Target;

for i := 1 to SrcSize do

begin

pOut^ := pIn^ xor (Key[2] shr 8);

Key[2] := byte(pOut^ + Key[2]) * Key[0] + Key[1];

inc(pIn);

inc(pOut);

end;

Result := True;

end else

Result := False;

end;

function TextCrypt(const s: string; Key: TWordTriple; Encrypt: Boolean): string;

var

bOK: Boolean;

begin

SetLength(Result, Length(s));

if Encrypt then

bOK := MemoryEncrypt(PChar(s), Length(s), PChar(Result), Length(Result), Key)

else

bOK := MemoryDecrypt(PChar(s), Length(s), PChar(Result), Length(Result), Key);

if not bOK then Result := '';

end;

function FileCrypt(InFile, OutFile: String; Key: TWordTriple; Encrypt: Boolean): boolean;

var

MIn, MOut: TMemoryStream;

begin

MIn := TMemoryStream.Create;

MOut := TMemoryStream.Create;

Try

MIn.LoadFromFile(InFile);

MOut.SetSize(MIn.Size);

if Encrypt then

Result := MemoryEncrypt(MIn.Memory, MIn.Size, MOut.Memory, MOut.Size, Key)

else

Result := MemoryDecrypt(MIn.Memory, MIn.Size, MOut.Memory, MOut.Size, Key);

MOut.SaveToFile(OutFile);

finally

MOut.Free;

MIn.Free;

end;

function TextEncrypt(const s: string; Key: TWordTriple): string;

begin

Result := TextCrypt(s, Key, True);

end;

function TextDecrypt(const s: string; Key: TWordTriple): string;

begin

Result := TextCrypt(s, Key, False);

end;

function FileEncrypt(InFile, OutFile: String; Key: TWordTriple): boolean;

begin

Result := FileCrypt(InFile, OutFile, Key, True);

end;

function FileDecrypt(InFile, OutFile: String; Key: TWordTriple): boolean;

begin

Result := FileCrypt(InFile, OutFile, Key, False);

end;

Delphi - .....................................

Dosya veya string şifreleme-şifre çözme

unit EZCrypt;

{modeled by Ben Hochstrasser(bhoc@surfeu.ch) after some code snippet from borland}

interface

uses Windows, Classes;

type

TWordTriple = Array[0..2] of Word;

function FileEncrypt(InFile, OutFile: String; Key: TWordTriple): boolean;

function FileDecrypt(InFile, OutFile: String; Key: TWordTriple): boolean;

function TextEncrypt(const s: string; Key: TWordTriple): string;

function TextDecrypt(const s: string; Key: TWordTriple): string;

function MemoryEncrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;

function MemoryDecrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;

implementation

function MemoryEncrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;

var

pIn, pOut: ^byte;

i : Cardinal;

begin

if SrcSize = TargetSize then

begin

pIn := Src;

pOut := Target;

for i := 1 to SrcSize do

begin

pOut^ := pIn^ xor (Key[2] shr 8);

Key[2] := Byte(pIn^ + Key[2]) * Key[0] + Key[1];

inc(pIn);

inc(pOut);

end;

Result := True;

end else

Result := False;

end;

function MemoryDecrypt(Src: Pointer; SrcSize: Cardinal; Target: Pointer; TargetSize: Cardinal; Key: TWordTriple): boolean;

var

pIn, pOut: ^byte;

i : Cardinal;

begin

if SrcSize = TargetSize then

begin

pIn := Src;

pOut := Target;

for i := 1 to SrcSize do

begin

pOut^ := pIn^ xor (Key[2] shr 8);

Key[2] := byte(pOut^ + Key[2]) * Key[0] + Key[1];

inc(pIn);

inc(pOut);

end;

Result := True;

end else

Result := False;

end;

function TextCrypt(const s: string; Key: TWordTriple; Encrypt: Boolean): string;

var

bOK: Boolean;

begin

SetLength(Result, Length(s));

if Encrypt then

bOK := MemoryEncrypt(PChar(s), Length(s), PChar(Result), Length(Result), Key)

else

bOK := MemoryDecrypt(PChar(s), Length(s), PChar(Result), Length(Result), Key);

if not bOK then Result := '';

end;

function FileCrypt(InFile, OutFile: String; Key: TWordTriple; Encrypt: Boolean): boolean;

var

MIn, MOut: TMemoryStream;

begin

MIn := TMemoryStream.Create;

MOut := TMemoryStream.Create;

Try

MIn.LoadFromFile(InFile);

MOut.SetSize(MIn.Size);

if Encrypt then

Result := MemoryEncrypt(MIn.Memory, MIn.Size, MOut.Memory, MOut.Size, Key)

else

Result := MemoryDecrypt(MIn.Memory, MIn.Size, MOut.Memory, MOut.Size, Key);

MOut.SaveToFile(OutFile);

finally

MOut.Free;

MIn.Free;

end;

function TextEncrypt(const s: string; Key: TWordTriple): string;

begin

Result := TextCrypt(s, Key, True);

end;

function TextDecrypt(const s: string; Key: TWordTriple): string;

begin

Result := TextCrypt(s, Key, False);

end;

function FileEncrypt(InFile, OutFile: String; Key: TWordTriple): boolean;

begin

Result := FileCrypt(InFile, OutFile, Key, True);

end;

function FileDecrypt(InFile, OutFile: String; Key: TWordTriple): boolean;

begin

Result := FileCrypt(InFile, OutFile, Key, False);

end;

Delphi - .....................................

Klasör boş mu?

function DirectoryIsEmpty(Directory: string): Boolean;

var

SR: TSearchRec;

i: Integer;

begin

Result := False;

FindFirst(IncludeTrailingPathDelimiter(Directory) + '*', faAnyFile, SR);

for i := 1 to 2 do

if (SR.Name = '.') or (SR.Name = '..') then

Result := FindNext(SR) <> 0;

FindClose(SR);

end;

//Kullanımı

procedure TForm1.Button1Click(Sender: TObject);

begin

if DirectoryIsEmpty('C:test') then

Label1.Caption := 'boş'

else

Label1.Caption := 'boş değil';

end;

Delphi - .....................................

Klasör boş mu?

function DirectoryIsEmpty(Directory: string): Boolean;

var

SR: TSearchRec;

i: Integer;

begin

Result := False;

FindFirst(IncludeTrailingPathDelimiter(Directory) + '*', faAnyFile, SR);

for i := 1 to 2 do

if (SR.Name = '.') or (SR.Name = '..') then

Result := FindNext(SR) <> 0;

FindClose(SR);

end;

//Kullanımı

procedure TForm1.Button1Click(Sender: TObject);

begin

if DirectoryIsEmpty('C:test') then

Label1.Caption := 'boş'

else

Label1.Caption := 'boş değil';

end;

Delphi - .....................................

Exe içinde sanal dosya sistemi oluşturmak

Exe içine dosya yazıp silebilirsiniz.

{*********************************************************************

This Sourcecode is Freeware i.e Credit-Ware:

you should say e.g. "Thanks to Cybergen"

if you use it in your software.

At least, it would be ^^ nice.

Cybergen <nope2k@web.de>

*********************************************************************}

{

Reference:

bool : csi_fat_available

bool : csi_fat_get_file_list(files:tstringlist)

cardinal : cis_load_file(fn:string;p:pointer)

bool : cis_save_file(fn:string)

bool : cis_delete_file(fn:string)

bool : cis_file_exists(fn:string)

CIS-FAT - Code: [Cybergen Internal Small - File Allocation Table]

}

(* CSI-FAT - START *)

function RunProg(Cmd, WorkDir: string): string;

var

tsi: TStartupInfo;

tpi: TProcessInformation;

nRead: DWORD;

aBuf: array[0..101] of Char;

sa: TSecurityAttributes;

hOutputReadTmp, hOutputRead, hOutputWrite, hInputWriteTmp, hInputRead,

hInputWrite, hErrorWrite: THandle;

FOutput: string;

begin

FOutput := '';

sa.nLength := SizeOf(TSecurityAttributes);

sa.lpSecurityDescriptor := nil;

sa.bInheritHandle := True;

CreatePipe(hOutputReadTmp, hOutputWrite, @sa, 0);

DuplicateHandle(GetCurrentProcess(), hOutputWrite, GetCurrentProcess(),

@hErrorWrite, 0, True, DUPLICATE_SAME_ACCESS);

CreatePipe(hInputRead, hInputWriteTmp, @sa, 0);

// Create new output read handle and the input write handle. Set

// the inheritance properties to FALSE. Otherwise, the child inherits

// the these handles; resulting in non-closeable handles to the pipes

// being created.

DuplicateHandle(GetCurrentProcess(), hOutputReadTmp, GetCurrentProcess(),

@hOutputRead, 0, False, DUPLICATE_SAME_ACCESS);

DuplicateHandle(GetCurrentProcess(), hInputWriteTmp, GetCurrentProcess(),

@hInputWrite, 0, False, DUPLICATE_SAME_ACCESS);

CloseHandle(hOutputReadTmp);

CloseHandle(hInputWriteTmp);

FillChar(tsi, SizeOf(TStartupInfo), 0);

tsi.cb := SizeOf(TStartupInfo);

tsi.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;

tsi.hStdInput := hInputRead;

tsi.hStdOutput := hOutputWrite;

tsi.hStdError := hErrorWrite;

CreateProcess(nil, PChar(Cmd), @sa, @sa, True, 0, nil, PChar(WorkDir),

tsi, tpi);

CloseHandle(hOutputWrite);

CloseHandle(hInputRead);

CloseHandle(hErrorWrite);

Application.ProcessMessages;

repeat

if (not ReadFile(hOutputRead, aBuf, 16, nRead, nil)) or (nRead = 0) then

begin

if GetLastError = ERROR_BROKEN_PIPE then Break

else

MessageDlg('Pipe read error, could not execute file', mtError, [mbOK], 0);

end;

aBuf[nRead] := #0;

FOutput := FOutput + PChar(@aBuf[0]);

Application.ProcessMessages;

until False;

Result := FOutput;

//GetExitCodeProcess(tpi.hProcess, nRead) = True;

end;

type

PImageDosHeader = ^TImageDosHeader;

TImageDosHeader = packed record

e_magic: Word;

e_ignore: packed array[0..28] of Word;

_lfanew: Longint;

end;

function GetExeSize: Cardinal;

var

p: PChar;

i, NumSections: Integer;

begin

Result := 0;

p := Pointer(hinstance);

Inc(p, PImageDosHeader(p)._lfanew + SizeOf(DWORD));

NumSections := PImageFileHeader(p).NumberOfSections;

Inc(p, SizeOf(TImageFileHeader) + SizeOf(TImageOptionalHeader));

for i := 1 to NumSections do

begin

with PImageSectionHeader(p)^ do

if PointerToRawData + SizeOfRawData > Result then

Result := PointerToRawData + SizeOfRawData;

Inc(p, SizeOf(TImageSectionHeader));

end;

function csi_fat_available: Boolean;

var

f: file;

head: Word;

nr: Integer;

begin

Result := False;

filemode := 0;

assignfile(f, ParamStr(0));

reset(f, 1);

head := 0;

if filesize(f) = getexesize then

begin

closefile(f);

Exit;

end;

seek(f, getexesize);

blockread(f, head, 2,nr);

if (head = $12FE) and (nr = 2) then Result := True;

closefile(f);

filemode := 2;

end;

function csi_fat_get_file_list(var files: TStringList): Boolean;

type

tfileentry = record

FileName: string[255];

filesize: Cardinal;

end;

var

f: file;

i, num, head: Word;

nr: Integer;

tfe: tfileentry;

begin

Result := False;

filemode := 0;

assignfile(f, ParamStr(0));

reset(f, 1);

seek(f, getexesize);

blockread(f, head, 2,nr);

if not ((head = $12FE) and (nr = 2)) then

begin

Result := False;

closefile(f);

Exit;

end;

blockread(f, num, 2,nr);

if (nr <> 2) then

begin

Result := False;

closefile(f);

Exit;

end;

for i := 1 to num do

begin

blockread(f, tfe, SizeOf(tfe), nr);

if nr <> SizeOf(tfe) then

begin

Result := False;

closefile(f);

Exit;

end;

files.Add(tfe.FileName);

end;

closefile(f);

filemode := 2;

Result := True;

end;

function cis_load_file(fn: string; var p: Pointer): Cardinal;

type

tfileentry = record

FileName: string[255];

filesize: Cardinal;

end;

var

f: file;

i, num, head: Word;

nr: Longint;

tfe: tfileentry;

fofs: Cardinal;

begin

Result := 0;

filemode := 0;

assignfile(f, ParamStr(0));

reset(f, 1);

fofs := getexesize;

seek(f, fofs);

blockread(f, head, 2,nr);

Inc(fofs, 2);

if not ((head = $12FE) and (nr = 2)) then

begin

Result := 0;

closefile(f);

Exit;

end;

blockread(f, num, 2,nr);

Inc(fofs, 2);

if (nr <> 2) then

begin

Result := 0;

closefile(f);

Exit;

end;

for i := 1 to num do

begin

blockread(f, tfe, SizeOf(tfe), nr);

Inc(fofs, SizeOf(tfe));

if nr <> SizeOf(tfe) then

begin

Result := 0;

closefile(f);

Exit;

end;

if (lowercase(tfe.FileName) = lowercase(fn)) then

begin

seek(f, fofs);

getmem(p, tfe.filesize);

blockread(f, p^, tfe.filesize, nr);

if (nr <> tfe.filesize) then

begin

ShowMessage('Unable to Load whole file');

freemem(p, tfe.filesize);

Result := tfe.filesize;

filemode := 2;

Exit;

end;

Result := tfe.filesize;

closefile(f);

ShowMessage('Loaded');

filemode := 2;

Exit;

end;

Inc(fofs, tfe.filesize);

end;

closefile(f);

// file nicht im CIS

ShowMessage('File not in CIS loading Orig. Destination');

assignfile(f, fn);

reset(f, 1);

getmem(p, tfe.filesize);

blockread(f, p^, filesize(f));

closefile(f);

filemode := 2;

Result := 0;

end;

function cis_file_exists(fn: string): Boolean;

var

files: TStringList;

i: Word;

begin

Result := False;

files := TStringList.Create;

csi_fat_get_file_list(files);

for i := 1 to files.Count do

if i <= files.Count then

if lowercase(files[i - 1]) = lowercase(fn) then Result := True;

files.Free;

end;

procedure FileCopy(const sourcefilename, targetfilename: string);

var

S, T: TFileStream;

begin

filemode := 2;

S := TFileStream.Create(sourcefilename, fmOpenRead);

try

T := TFileStream.Create(targetfilename, fmOpenWrite or fmCreate);

try

T.CopyFrom(S, S.Size);

finally

T.Free;

end;

finally

S.Free;

end;

function randname: string;

var

i: Integer;

s: string;

begin

Randomize;

s := '';

for i := 1 to 20 do s := s + chr(Ord('a') + Random(26));

Result := s;

end;

procedure _filecopy(von, nach: string);

var

f: file;

c, cmd: string;

begin

filemode := 2;

ShowMessage(von + ' -> ' + nach);

cmd := 'cmd';

if fileexists('cmd.exe') then cmd := 'cmd';

if fileexists('c:command.com') then cmd := 'command.com';

c := 'ren ' + nach + ' ' + randname;

runprog(cmd + ' /c ' + c, GetCurrentDir);

assignfile(f, von);

rename(f, nach);

end;

function cis_delete_file(fn: string): Boolean;

type

tfileentry = record

FileName: string[255];

filesize: Cardinal;

end;

var

f, o: file;

nrr, nr: Integer;

exes: Longint;

j, i, num, w: Word;

tfe: tfileentry;

tfel: array[1..$ff] of tfileentry;

p: Pointer;

begin

if not cis_file_exists(fn) then

begin

Result := False;

Exit;

end;

assignfile(f, ParamStr(0));

reset(f, 1);

assignfile(o, ParamStr(0) + '.tmp');

rewrite(o, 1);

exes := getexesize;

// nur die exe kopieren

getmem(p, exes);

blockread(f, p^, exes);

blockwrite(o, p^, exes);

freemem(p, exes);

blockread(f, w, 2);

blockread(f, num, 2);

Dec(num);

// cis-header schreiben

w := $12FE;

blockwrite(o, w, 2);

blockwrite(o, num, 2);

// jetzt alle files außer "fn" kopieren

// aber erst die FAT

fillchar(tfel, SizeOf(tfel), 0);

for i := 1 to num + 1 do

begin

blockread(f, tfe, SizeOf(tfe));

move(tfe, tfel[i], SizeOf(tfe));

if lowercase(tfe.FileName) <> lowercase(fn) then blockwrite(o, tfe, SizeOf(tfe));

end;

// jetzt noch die file daten einkopieren

for i := 1 to num + 1 do

begin

getmem(p, tfel[i].filesize);

blockread(f, p^, tfel[i].filesize);

if lowercase(tfe.FileName) <> lowercase(fn) then // copy block

blockwrite(o, p^, tfel[i].filesize);

freemem(p, tfel[i].filesize);

end;

closefile(f);

closefile(o);

_filecopy(ParamStr(0) + '.tmp', ParamStr(0));

end;

function cis_append_file(fn: string): Boolean;

type

tfileentry = record

FileName: string[255];

filesize: Cardinal;

end;

var

f, o, s: file;

exes: Longint;

p: Pointer;

i, w, num: Word;

tfe: tfileentry;

fs: Cardinal;

nwr: Cardinal;

begin

assignfile(f, ParamStr(0));

reset(f, 1);

assignfile(o, ParamStr(0) + '.tmp');

rewrite(o, 1);

exes := getexesize;

if not csi_fat_available then

begin

// create cis

getmem(p, exes);

blockread(f, p^, exes);

blockwrite(o, p^, exes);

freemem(p, exes);

// create fat-header

w := $12FE;

blockwrite(o, w, 2);

num := 1;

blockwrite(o, num, 2);

tfe.FileName := fn;

// copy file

assignfile(s, fn);

reset(s, 1);

tfe.filesize := filesize(s);

getmem(p, filesize(s));

blockwrite(o, tfe, SizeOf(tfe));

blockread(s, p^, filesize(s));

blockwrite(o, p^, filesize(s));

freemem(p, filesize(s));

closefile(s);

closefile(f);

closefile(o);

_filecopy(ParamStr(0) + '.tmp', ParamStr(0));

Result := True;

Exit;

end;

// nur die exe kopieren

getmem(p, exes);

blockread(f, p^, exes);

blockwrite(o, p^, exes);

freemem(p, exes);

blockread(f, w, 2);

blockread(f, num, 2);

Inc(num);

// cis-header schreiben

w := $12FE;

blockwrite(o, w, 2);

blockwrite(o, num, 2);

// copy all file entrys

for i := 1 to num - 1 do

begin

blockread(f, tfe, SizeOf(tfe));

blockwrite(o, tfe, SizeOf(tfe));

end;

tfe.FileName := fn;

assignfile(s, fn);

reset(s, 1);

tfe.filesize := filesize(s);

blockwrite(o, tfe, SizeOf(tfe));

fs := filesize(f);

getmem(p, fs);

blockread(f, p^, fs, nwr);

blockwrite(o, p^, nwr);

freemem(p, fs);

getmem(p, fs);

blockread(f, p^, fs);

blockwrite(o, p^, fs);

freemem(p, fs);

closefile(f);

closefile(o);

_filecopy(ParamStr(0) + '.tmp', ParamStr(0));

Result := True;

end;

function cis_save_file(fn: string): Boolean;

begin

if not cis_file_exists(fn) then cis_append_file(fn)

else

begin

cis_delete_file(fn);

cis_save_file(fn);

end;

(* CSI-FAT - STOP *)

// -------------- KULLANIMI: -----------------------------------------

// ... some code ...

// if file is not in the VFS load it into ..

if not cis_file_exists('e:xmshold.xm') then cis_save_file('e:xmshold.xm');

// Load File

cis_load_file('e:xmshold.xm', muke);

// ... some code ...

play(muke);

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Delphi - .....................................

Exe içinde sanal dosya sistemi oluşturmak

Exe içine dosya yazıp silebilirsiniz.

{*********************************************************************

This Sourcecode is Freeware i.e Credit-Ware:

you should say e.g. "Thanks to Cybergen"

if you use it in your software.

At least, it would be ^^ nice.

Cybergen <nope2k@web.de>

*********************************************************************}

{

Reference:

bool : csi_fat_available

bool : csi_fat_get_file_list(files:tstringlist)

cardinal : cis_load_file(fn:string;p:pointer)

bool : cis_save_file(fn:string)

bool : cis_delete_file(fn:string)

bool : cis_file_exists(fn:string)

CIS-FAT - Code: [Cybergen Internal Small - File Allocation Table]

}

(* CSI-FAT - START *)

function RunProg(Cmd, WorkDir: string): string;

var

tsi: TStartupInfo;

tpi: TProcessInformation;

nRead: DWORD;

aBuf: array[0..101] of Char;

sa: TSecurityAttributes;

hOutputReadTmp, hOutputRead, hOutputWrite, hInputWriteTmp, hInputRead,

hInputWrite, hErrorWrite: THandle;

FOutput: string;

begin

FOutput := '';

sa.nLength := SizeOf(TSecurityAttributes);

sa.lpSecurityDescriptor := nil;

sa.bInheritHandle := True;

CreatePipe(hOutputReadTmp, hOutputWrite, @sa, 0);

DuplicateHandle(GetCurrentProcess(), hOutputWrite, GetCurrentProcess(),

@hErrorWrite, 0, True, DUPLICATE_SAME_ACCESS);

CreatePipe(hInputRead, hInputWriteTmp, @sa, 0);

// Create new output read handle and the input write handle. Set

// the inheritance properties to FALSE. Otherwise, the child inherits

// the these handles; resulting in non-closeable handles to the pipes

// being created.

DuplicateHandle(GetCurrentProcess(), hOutputReadTmp, GetCurrentProcess(),

@hOutputRead, 0, False, DUPLICATE_SAME_ACCESS);

DuplicateHandle(GetCurrentProcess(), hInputWriteTmp, GetCurrentProcess(),

@hInputWrite, 0, False, DUPLICATE_SAME_ACCESS);

CloseHandle(hOutputReadTmp);

CloseHandle(hInputWriteTmp);

FillChar(tsi, SizeOf(TStartupInfo), 0);

tsi.cb := SizeOf(TStartupInfo);

tsi.dwFlags := STARTF_USESTDHANDLES or STARTF_USESHOWWINDOW;

tsi.hStdInput := hInputRead;

tsi.hStdOutput := hOutputWrite;

tsi.hStdError := hErrorWrite;

CreateProcess(nil, PChar(Cmd), @sa, @sa, True, 0, nil, PChar(WorkDir),

tsi, tpi);

CloseHandle(hOutputWrite);

CloseHandle(hInputRead);

CloseHandle(hErrorWrite);

Application.ProcessMessages;

repeat

if (not ReadFile(hOutputRead, aBuf, 16, nRead, nil)) or (nRead = 0) then

begin

if GetLastError = ERROR_BROKEN_PIPE then Break

else

MessageDlg('Pipe read error, could not execute file', mtError, [mbOK], 0);

end;

aBuf[nRead] := #0;

FOutput := FOutput + PChar(@aBuf[0]);

Application.ProcessMessages;

until False;

Result := FOutput;

//GetExitCodeProcess(tpi.hProcess, nRead) = True;

end;

type

PImageDosHeader = ^TImageDosHeader;

TImageDosHeader = packed record

e_magic: Word;

e_ignore: packed array[0..28] of Word;

_lfanew: Longint;

end;

function GetExeSize: Cardinal;

var

p: PChar;

i, NumSections: Integer;

begin

Result := 0;

p := Pointer(hinstance);

Inc(p, PImageDosHeader(p)._lfanew + SizeOf(DWORD));

NumSections := PImageFileHeader(p).NumberOfSections;

Inc(p, SizeOf(TImageFileHeader) + SizeOf(TImageOptionalHeader));

for i := 1 to NumSections do

begin

with PImageSectionHeader(p)^ do

if PointerToRawData + SizeOfRawData > Result then

Result := PointerToRawData + SizeOfRawData;

Inc(p, SizeOf(TImageSectionHeader));

end;

function csi_fat_available: Boolean;

var

f: file;

head: Word;

nr: Integer;

begin

Result := False;

filemode := 0;

assignfile(f, ParamStr(0));

reset(f, 1);

head := 0;

if filesize(f) = getexesize then

begin

closefile(f);

Exit;

end;

seek(f, getexesize);

blockread(f, head, 2,nr);

if (head = $12FE) and (nr = 2) then Result := True;

closefile(f);

filemode := 2;

end;

function csi_fat_get_file_list(var files: TStringList): Boolean;

type

tfileentry = record

FileName: string[255];

filesize: Cardinal;

end;

var

f: file;

i, num, head: Word;

nr: Integer;

tfe: tfileentry;

begin

Result := False;

filemode := 0;

assignfile(f, ParamStr(0));

reset(f, 1);

seek(f, getexesize);

blockread(f, head, 2,nr);

if not ((head = $12FE) and (nr = 2)) then

begin

Result := False;

closefile(f);

Exit;

end;

blockread(f, num, 2,nr);

if (nr <> 2) then

begin

Result := False;

closefile(f);

Exit;

end;

for i := 1 to num do

begin

blockread(f, tfe, SizeOf(tfe), nr);

if nr <> SizeOf(tfe) then

begin

Result := False;

closefile(f);

Exit;

end;

files.Add(tfe.FileName);

end;

closefile(f);

filemode := 2;

Result := True;

end;

function cis_load_file(fn: string; var p: Pointer): Cardinal;

type

tfileentry = record

FileName: string[255];

filesize: Cardinal;

end;

var

f: file;

i, num, head: Word;

nr: Longint;

tfe: tfileentry;

fofs: Cardinal;

begin

Result := 0;

filemode := 0;

assignfile(f, ParamStr(0));

reset(f, 1);

fofs := getexesize;

seek(f, fofs);

blockread(f, head, 2,nr);

Inc(fofs, 2);

if not ((head = $12FE) and (nr = 2)) then

begin

Result := 0;

closefile(f);

Exit;

end;

blockread(f, num, 2,nr);

Inc(fofs, 2);

if (nr <> 2) then

begin

Result := 0;

closefile(f);

Exit;

end;

for i := 1 to num do

begin

blockread(f, tfe, SizeOf(tfe), nr);

Inc(fofs, SizeOf(tfe));

if nr <> SizeOf(tfe) then

begin

Result := 0;

closefile(f);

Exit;

end;

if (lowercase(tfe.FileName) = lowercase(fn)) then

begin

seek(f, fofs);

getmem(p, tfe.filesize);

blockread(f, p^, tfe.filesize, nr);

if (nr <> tfe.filesize) then

begin

ShowMessage('Unable to Load whole file');

freemem(p, tfe.filesize);

Result := tfe.filesize;

filemode := 2;

Exit;

end;

Result := tfe.filesize;

closefile(f);

ShowMessage('Loaded');

filemode := 2;

Exit;

end;

Inc(fofs, tfe.filesize);

end;

closefile(f);

// file nicht im CIS

ShowMessage('File not in CIS loading Orig. Destination');

assignfile(f, fn);

reset(f, 1);

getmem(p, tfe.filesize);

blockread(f, p^, filesize(f));

closefile(f);

filemode := 2;

Result := 0;

end;

function cis_file_exists(fn: string): Boolean;

var

files: TStringList;

i: Word;

begin

Result := False;

files := TStringList.Create;

csi_fat_get_file_list(files);

for i := 1 to files.Count do

if i <= files.Count then

if lowercase(files[i - 1]) = lowercase(fn) then Result := True;

files.Free;

end;

procedure FileCopy(const sourcefilename, targetfilename: string);

var

S, T: TFileStream;

begin

filemode := 2;

S := TFileStream.Create(sourcefilename, fmOpenRead);

try

T := TFileStream.Create(targetfilename, fmOpenWrite or fmCreate);

try

T.CopyFrom(S, S.Size);

finally

T.Free;

end;

finally

S.Free;

end;

function randname: string;

var

i: Integer;

s: string;

begin

Randomize;

s := '';

for i := 1 to 20 do s := s + chr(Ord('a') + Random(26));

Result := s;

end;

procedure _filecopy(von, nach: string);

var

f: file;

c, cmd: string;

begin

filemode := 2;

ShowMessage(von + ' -> ' + nach);

cmd := 'cmd';

if fileexists('cmd.exe') then cmd := 'cmd';

if fileexists('c:command.com') then cmd := 'command.com';

c := 'ren ' + nach + ' ' + randname;

runprog(cmd + ' /c ' + c, GetCurrentDir);

assignfile(f, von);

rename(f, nach);

end;

function cis_delete_file(fn: string): Boolean;

type

tfileentry = record

FileName: string[255];

filesize: Cardinal;

end;

var

f, o: file;

nrr, nr: Integer;

exes: Longint;

j, i, num, w: Word;

tfe: tfileentry;

tfel: array[1..$ff] of tfileentry;

p: Pointer;

begin

if not cis_file_exists(fn) then

begin

Result := False;

Exit;

end;

assignfile(f, ParamStr(0));

reset(f, 1);

assignfile(o, ParamStr(0) + '.tmp');

rewrite(o, 1);

exes := getexesize;

// nur die exe kopieren

getmem(p, exes);

blockread(f, p^, exes);

blockwrite(o, p^, exes);

freemem(p, exes);

blockread(f, w, 2);

blockread(f, num, 2);

Dec(num);

// cis-header schreiben

w := $12FE;

blockwrite(o, w, 2);

blockwrite(o, num, 2);

// jetzt alle files außer "fn" kopieren

// aber erst die FAT

fillchar(tfel, SizeOf(tfel), 0);

for i := 1 to num + 1 do

begin

blockread(f, tfe, SizeOf(tfe));

move(tfe, tfel[i], SizeOf(tfe));

if lowercase(tfe.FileName) <> lowercase(fn) then blockwrite(o, tfe, SizeOf(tfe));

end;

// jetzt noch die file daten einkopieren

for i := 1 to num + 1 do

begin

getmem(p, tfel[i].filesize);

blockread(f, p^, tfel[i].filesize);

if lowercase(tfe.FileName) <> lowercase(fn) then // copy block

blockwrite(o, p^, tfel[i].filesize);

freemem(p, tfel[i].filesize);

end;

closefile(f);

closefile(o);

_filecopy(ParamStr(0) + '.tmp', ParamStr(0));

end;

function cis_append_file(fn: string): Boolean;

type

tfileentry = record

FileName: string[255];

filesize: Cardinal;

end;

var

f, o, s: file;

exes: Longint;

p: Pointer;

i, w, num: Word;

tfe: tfileentry;

fs: Cardinal;

nwr: Cardinal;

begin

assignfile(f, ParamStr(0));

reset(f, 1);

assignfile(o, ParamStr(0) + '.tmp');

rewrite(o, 1);

exes := getexesize;

if not csi_fat_available then

begin

// create cis

getmem(p, exes);

blockread(f, p^, exes);

blockwrite(o, p^, exes);

freemem(p, exes);

// create fat-header

w := $12FE;

blockwrite(o, w, 2);

num := 1;

blockwrite(o, num, 2);

tfe.FileName := fn;

// copy file

assignfile(s, fn);

reset(s, 1);

tfe.filesize := filesize(s);

getmem(p, filesize(s));

blockwrite(o, tfe, SizeOf(tfe));

blockread(s, p^, filesize(s));

blockwrite(o, p^, filesize(s));

freemem(p, filesize(s));

closefile(s);

closefile(f);

closefile(o);

_filecopy(ParamStr(0) + '.tmp', ParamStr(0));

Result := True;

Exit;

end;

// nur die exe kopieren

getmem(p, exes);

blockread(f, p^, exes);

blockwrite(o, p^, exes);

freemem(p, exes);

blockread(f, w, 2);

blockread(f, num, 2);

Inc(num);

// cis-header schreiben

w := $12FE;

blockwrite(o, w, 2);

blockwrite(o, num, 2);

// copy all file entrys

for i := 1 to num - 1 do

begin

blockread(f, tfe, SizeOf(tfe));

blockwrite(o, tfe, SizeOf(tfe));

end;

tfe.FileName := fn;

assignfile(s, fn);

reset(s, 1);

tfe.filesize := filesize(s);

blockwrite(o, tfe, SizeOf(tfe));

fs := filesize(f);

getmem(p, fs);

blockread(f, p^, fs, nwr);

blockwrite(o, p^, nwr);

freemem(p, fs);

getmem(p, fs);

blockread(f, p^, fs);

blockwrite(o, p^, fs);

freemem(p, fs);

closefile(f);

closefile(o);

_filecopy(ParamStr(0) + '.tmp', ParamStr(0));

Result := True;

end;

function cis_save_file(fn: string): Boolean;

begin

if not cis_file_exists(fn) then cis_append_file(fn)

else

begin

cis_delete_file(fn);

cis_save_file(fn);

end;

(* CSI-FAT - STOP *)

// -------------- KULLANIMI: -----------------------------------------

// ... some code ...

// if file is not in the VFS load it into ..

if not cis_file_exists('e:xmshold.xm') then cis_save_file('e:xmshold.xm');

// Load File

cis_load_file('e:xmshold.xm', muke);

// ... some code ...

play(muke);

{+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Delphi - .....................................

Print Screen tuşuna basıldı mı?

procedure TForm1.FormCreate(Sender: TObject);

begin

Application.OnIdle := AppIdle;

end;

procedure TForm1.AppIdle(Sender: TObject; var Done: Boolean);

begin

if GetAsyncKeyState(VK_SNAPSHOT) <> 0 then

Showmessage('PrintScreen tuşuna basıldı!');

Done := True;

end;

Delphi - .....................................

Print Screen tuşuna basıldı mı?

procedure TForm1.FormCreate(Sender: TObject);

begin

Application.OnIdle := AppIdle;

end;

procedure TForm1.AppIdle(Sender: TObject; var Done: Boolean);

begin

if GetAsyncKeyState(VK_SNAPSHOT) <> 0 then

Showmessage('PrintScreen tuşuna basıldı!');

Done := True;

end;

Delphi - .....................................