çok acil 2 sorunum var lütfen yardım

aşağıdaki kodda ne hata var çözemedim.

hesaplamada edit6 da sorun yok ama edit5 ile ilgili rakamlardan hesaplamada

kullanılan rakamlardan ( DModules.SiparisSatdb.FieldByName('nfstokmaliyet').Asinteger; )

olan kuruşlu olursa çakılıyor ve exception class Econverterror with message "20,15" is not valid integer value hatası veriyor

ama bir türlü string yapamadım ve hatayı geçemedim. yardımcı olurmusunuz??

**********************

 

var

  toplam:integer;

begin

  toplam:= 0;

  DModules.SiparisSatdb.First;

  While not DModules.SiparisSatdb.eof Do

  begin

    toplam:=toplam+DModules.SiparisSatdb.FieldByName('nfstokmaliyet').Asinteger;

    DModules.SiparisSatdb.Next ;

  end;

  edit5.text:= IntToStr(toplam);

  edit6.text:= dmodules.SiparisdbNETTOTAL.AsString;

  end;

 

************************************************************

 

birde bir adet dbgrid im var burada 2 kolonum mevcut. biri birimmaliyet diğeri miktar.

 

ikisini çarptırıp diğer bir kolona yazdıramıyorum. aşağıdaki kodla bir edit5.text adlı alana yazdırdım ama birden çok satır

 

olduğu için gride yazdırmam lazımki her satırın karşısına yazsın . ve aynı kuruş problemi orada da oluyor

 

maliyetteki rakam kuruşsuz olursa çalışıyor kuruşlu olursa çakılıyor.

 

  var

  Stoplam:integer;

 begin

  stoplam:= stoplam;

  DModules.SiparisSatdb.First;

  While not DModules.SiparisSatdb.eof Do

  begin

    stoplam :=DModules.SiparisSatdb.FieldByName('AMOUNT').Asinteger* DModules.SiparisSatdb.FieldByName('nfstokmaliyet').Asinteger;

    DModules.SiparisSatdb.Next;

  end;

  edit5.text:= inttostr  (stoplam);

 

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

 

çok acil 2 sorunum var lütfen yardım

aşağıdaki kodda ne hata var çözemedim.

hesaplamada edit6 da sorun yok ama edit5 ile ilgili rakamlardan hesaplamada

kullanılan rakamlardan ( DModules.SiparisSatdb.FieldByName('nfstokmaliyet').Asinteger; )

olan kuruşlu olursa çakılıyor ve exception class Econverterror with message "20,15" is not valid integer value hatası veriyor

ama bir türlü string yapamadım ve hatayı geçemedim. yardımcı olurmusunuz??

**********************

 

var

  toplam:integer;

begin

  toplam:= 0;

  DModules.SiparisSatdb.First;

  While not DModules.SiparisSatdb.eof Do

  begin

    toplam:=toplam+DModules.SiparisSatdb.FieldByName('nfstokmaliyet').Asinteger;

    DModules.SiparisSatdb.Next ;

  end;

  edit5.text:= IntToStr(toplam);

  edit6.text:= dmodules.SiparisdbNETTOTAL.AsString;

  end;

 

************************************************************

 

birde bir adet dbgrid im var burada 2 kolonum mevcut. biri birimmaliyet diğeri miktar.

 

ikisini çarptırıp diğer bir kolona yazdıramıyorum. aşağıdaki kodla bir edit5.text adlı alana yazdırdım ama birden çok satır

 

olduğu için gride yazdırmam lazımki her satırın karşısına yazsın . ve aynı kuruş problemi orada da oluyor

 

maliyetteki rakam kuruşsuz olursa çalışıyor kuruşlu olursa çakılıyor.

 

  var

  Stoplam:integer;

 begin

  stoplam:= stoplam;

  DModules.SiparisSatdb.First;

  While not DModules.SiparisSatdb.eof Do

  begin

    stoplam :=DModules.SiparisSatdb.FieldByName('AMOUNT').Asinteger* DModules.SiparisSatdb.FieldByName('nfstokmaliyet').Asinteger;

    DModules.SiparisSatdb.Next;

  end;

  edit5.text:= inttostr  (stoplam);

 

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

 

sql server alter columns

if not exists (select * from syscolumns

  where id=object_id('Employees') and name='MaidenName')

    alter table Employees add MaidenName varchar(64) NULL

    GO

 

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

 

sql server alter columns

if not exists (select * from syscolumns

  where id=object_id('Employees') and name='MaidenName')

    alter table Employees add MaidenName varchar(64) NULL

    GO

 

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

 

...shutdown a computer through a network connection?

unit shutdown;

 

interface

 

uses

  Windows,

  StdCtrls;

 

procedure shut(system, nachricht: string; force, reboot: Boolean; countdown: Integer);

procedure abortshut(system: string);

 

implementation

 

const

  SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';

var

  hdlg: DWORD = 0;

 

procedure shut(system, nachricht: string; force, reboot: Boolean; countdown: Integer);

var

  otoken, hToken: THandle;

  tp: TTokenPrivileges;

  h: DWORD;

begin

  OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES, hToken);

  otoken := htoken;

  LookupPrivilegeValue(nil, SE_SHUTDOWN_NAME, tp.Privileges[0].luid);

  tp.privilegecount := 1;

  tp.privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

  h := 0;

  AdjustTokenPrivileges(hToken, False, tp, 0, PTokenPrivileges(nil)^, h);

  InitiateSystemShutdown(PChar(system), PChar(nachricht), countdown, force, reboot);

  tp.privilegecount := 1;

  tp.privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

  h := 0;

  AdjustTokenPrivileges(oToken, False, tp, 0, PTokenPrivileges(nil)^, h);

  CloseHandle(hToken);

end;

 

procedure abortshut(system: string);

var

  hToken: THandle;

  tp: TTokenPrivileges;

  h: DWORD;

begin

  OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES, hToken);

  LookupPrivilegeValue(PChar(system), SE_SHUTDOWN_NAME, tp.Privileges[0].luid);

  tp.privilegecount := 1;

  tp.privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

  h := 0;

  AdjustTokenPrivileges(hToken, False, tp, 0, PTokenPrivileges(nil)^, h);

  CloseHandle(hToken);

  abortSystemShutdown(PChar(system));

end;

 

end.

 

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

 

...shutdown a computer through a network connection?

unit shutdown;

 

interface

 

uses

  Windows,

  StdCtrls;

 

procedure shut(system, nachricht: string; force, reboot: Boolean; countdown: Integer);

procedure abortshut(system: string);

 

implementation

 

const

  SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';

var

  hdlg: DWORD = 0;

 

procedure shut(system, nachricht: string; force, reboot: Boolean; countdown: Integer);

var

  otoken, hToken: THandle;

  tp: TTokenPrivileges;

  h: DWORD;

begin

  OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES, hToken);

  otoken := htoken;

  LookupPrivilegeValue(nil, SE_SHUTDOWN_NAME, tp.Privileges[0].luid);

  tp.privilegecount := 1;

  tp.privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

  h := 0;

  AdjustTokenPrivileges(hToken, False, tp, 0, PTokenPrivileges(nil)^, h);

  InitiateSystemShutdown(PChar(system), PChar(nachricht), countdown, force, reboot);

  tp.privilegecount := 1;

  tp.privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

  h := 0;

  AdjustTokenPrivileges(oToken, False, tp, 0, PTokenPrivileges(nil)^, h);

  CloseHandle(hToken);

end;

 

procedure abortshut(system: string);

var

  hToken: THandle;

  tp: TTokenPrivileges;

  h: DWORD;

begin

  OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES, hToken);

  LookupPrivilegeValue(PChar(system), SE_SHUTDOWN_NAME, tp.Privileges[0].luid);

  tp.privilegecount := 1;

  tp.privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

  h := 0;

  AdjustTokenPrivileges(hToken, False, tp, 0, PTokenPrivileges(nil)^, h);

  CloseHandle(hToken);

  abortSystemShutdown(PChar(system));

end;

 

end.

 

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

 

...monitor a harddrive with S.M.A.R.T?

.... }

 

type

  TSmartData = array[0..527] of Byte;

 

{ .... }

 

procedure GetSmartData(var Data: TSmartData);

var

  hdrive: Cardinal;

  dwBytesReturned: DWORD;

  ipar: array[0..31] of Byte;

  opar: TSmartData;

begin

  ipar[0]  := 0;

  ipar[1]  := $02;

  ipar[2]  := 0;

  ipar[3]  := 0;

  ipar[4]  := $d0;

  ipar[5]  := $01;

  ipar[6]  := $01;

  ipar[7]  := $4f;

  ipar[8]  := $c2;

  ipar[9]  := $a0;

  ipar[10] := $b0;

  ipar[11] := 0;

  ipar[12] := 0;

  ipar[13] := 0;

  ipar[14] := 0;

  ipar[15] := 0;

  ipar[16] := $8c;

  ipar[17] := $fd;

  ipar[18] := $14;

  ipar[19] := 0;

  ipar[20] := 0;

  ipar[21] := $02;

  ipar[22] := 0;

  ipar[23] := 0;

  ipar[24] := $03;

  ipar[25] := 0;

  ipar[26] := 0;

  ipar[27] := 0;

  ipar[28] := $03;

  ipar[29] := 0;

  ipar[30] := 0;

  ipar[31] := 0;

 

  // Get first harddrive

  hdrive   := CreateFile(PChar('.PhysicalDrive0'), 3221225472, 3, nil, 3, 0, 0);

  DeviceIoControl(hdrive, $0007C088, @ipar, 32, @opar, 528, dwBytesReturned, nil);

  CloseHandle(hdrive);

  Data := opar;

end;

 

procedure TForm1.FormCreate(Sender: TObject);

begin

  StringGrid1.Cells[0, 0]  := 'Description';

  StringGrid1.Cells[1, 0]  := 'Value';

  StringGrid1.Cells[0, 1]  := 'Spin Up Time';

  StringGrid1.Cells[0, 2]  := 'Start/Stop Count';

  StringGrid1.Cells[0, 3]  := 'Reallocated Sectors Count';

  StringGrid1.Cells[0, 4]  := 'Read Channel Margin';

  StringGrid1.Cells[0, 5]  := 'Seek Error Rate';

  StringGrid1.Cells[0, 6]  := 'Seek Time Performance';

  StringGrid1.Cells[0, 7]  := 'Power-On Minutes';

  StringGrid1.Cells[0, 8]  := 'Spin Retry Count';

  StringGrid1.Cells[0, 9]  := 'Recalibration Retries';

  StringGrid1.Cells[0, 10] := 'Device Power Cycle Count';

  StringGrid1.Cells[0, 11] := 'Load/Unload Cycle Count';

  StringGrid1.Cells[0, 12] := 'Temperature';

  StringGrid1.Cells[0, 13] := 'Reallocation Event Count';

  StringGrid1.Cells[0, 14] := 'Current Pending Sector Count';

  StringGrid1.Cells[0, 15] := 'Uncorrectable Sector Count';

  StringGrid1.Cells[0, 16] := 'UDMA CRC Error Count';

  StringGrid1.Cells[0, 17] := 'Write Error Rate';

 

  Timer1.Interval := 700;

  Timer1.Enabled := True;

end;

 

procedure TForm1.Timer1Timer(Sender: TObject);

var

  smartdatavar: TSmartData;

begin

  getsmartdata(smartdatavar);

 

  StringGrid1.Cells[1, 1]  := IntToStr(smartdatavar[24] * 256 + smartdatavar[23]);

  StringGrid1.Cells[1, 2]  := IntToStr(smartdatavar[36] * 256 + smartdatavar[35]);

  StringGrid1.Cells[1, 3]  := IntToStr(smartdatavar[48] * 256 + smartdatavar[47]);

  StringGrid1.Cells[1, 4]  := IntToStr(smartdatavar[60] * 256 + smartdatavar[59]);

  StringGrid1.Cells[1, 5]  := IntToStr(smartdatavar[72] * 256 + smartdatavar[71]);

  StringGrid1.Cells[1, 6]  := IntToStr(smartdatavar[84] * 256 + smartdatavar[83]);

  StringGrid1.Cells[1, 7]  := IntToStr(smartdatavar[96] * 256 + smartdatavar[95]);

  StringGrid1.Cells[1, 8]  := IntToStr(smartdatavar[108] * 256 + smartdatavar[107]);

  StringGrid1.Cells[1, 9]  := IntToStr(smartdatavar[120] * 256 + smartdatavar[119]);

  StringGrid1.Cells[1, 10] := IntToStr(smartdatavar[132] * 256 + smartdatavar[131]);

  StringGrid1.Cells[1, 11] := IntToStr(smartdatavar[156] * 256 + smartdatavar[155]);

  StringGrid1.Cells[1, 12] := IntToStr(smartdatavar[168] * 256 + smartdatavar[167]);

  StringGrid1.Cells[1, 13] := IntToStr(smartdatavar[192] * 256 + smartdatavar[191]);

  StringGrid1.Cells[1, 14] := IntToStr(smartdatavar[204] * 256 + smartdatavar[203]);

  StringGrid1.Cells[1, 15] := IntToStr(smartdatavar[216] * 256 + smartdatavar[215]);

  StringGrid1.Cells[1, 16] := IntToStr(smartdatavar[228] * 256 + smartdatavar[227]);

  StringGrid1.Cells[1, 17] := IntToStr(smartdatavar[240] * 256 + smartdatavar[239]);

end;

 

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

 

...monitor a harddrive with S.M.A.R.T?

.... }

 

type

  TSmartData = array[0..527] of Byte;

 

{ .... }

 

procedure GetSmartData(var Data: TSmartData);

var

  hdrive: Cardinal;

  dwBytesReturned: DWORD;

  ipar: array[0..31] of Byte;

  opar: TSmartData;

begin

  ipar[0]  := 0;

  ipar[1]  := $02;

  ipar[2]  := 0;

  ipar[3]  := 0;

  ipar[4]  := $d0;

  ipar[5]  := $01;

  ipar[6]  := $01;

  ipar[7]  := $4f;

  ipar[8]  := $c2;

  ipar[9]  := $a0;

  ipar[10] := $b0;

  ipar[11] := 0;

  ipar[12] := 0;

  ipar[13] := 0;

  ipar[14] := 0;

  ipar[15] := 0;

  ipar[16] := $8c;

  ipar[17] := $fd;

  ipar[18] := $14;

  ipar[19] := 0;

  ipar[20] := 0;

  ipar[21] := $02;

  ipar[22] := 0;

  ipar[23] := 0;

  ipar[24] := $03;

  ipar[25] := 0;

  ipar[26] := 0;

  ipar[27] := 0;

  ipar[28] := $03;

  ipar[29] := 0;

  ipar[30] := 0;

  ipar[31] := 0;

 

  // Get first harddrive

  hdrive   := CreateFile(PChar('.PhysicalDrive0'), 3221225472, 3, nil, 3, 0, 0);

  DeviceIoControl(hdrive, $0007C088, @ipar, 32, @opar, 528, dwBytesReturned, nil);

  CloseHandle(hdrive);

  Data := opar;

end;

 

procedure TForm1.FormCreate(Sender: TObject);

begin

  StringGrid1.Cells[0, 0]  := 'Description';

  StringGrid1.Cells[1, 0]  := 'Value';

  StringGrid1.Cells[0, 1]  := 'Spin Up Time';

  StringGrid1.Cells[0, 2]  := 'Start/Stop Count';

  StringGrid1.Cells[0, 3]  := 'Reallocated Sectors Count';

  StringGrid1.Cells[0, 4]  := 'Read Channel Margin';

  StringGrid1.Cells[0, 5]  := 'Seek Error Rate';

  StringGrid1.Cells[0, 6]  := 'Seek Time Performance';

  StringGrid1.Cells[0, 7]  := 'Power-On Minutes';

  StringGrid1.Cells[0, 8]  := 'Spin Retry Count';

  StringGrid1.Cells[0, 9]  := 'Recalibration Retries';

  StringGrid1.Cells[0, 10] := 'Device Power Cycle Count';

  StringGrid1.Cells[0, 11] := 'Load/Unload Cycle Count';

  StringGrid1.Cells[0, 12] := 'Temperature';

  StringGrid1.Cells[0, 13] := 'Reallocation Event Count';

  StringGrid1.Cells[0, 14] := 'Current Pending Sector Count';

  StringGrid1.Cells[0, 15] := 'Uncorrectable Sector Count';

  StringGrid1.Cells[0, 16] := 'UDMA CRC Error Count';

  StringGrid1.Cells[0, 17] := 'Write Error Rate';

 

  Timer1.Interval := 700;

  Timer1.Enabled := True;

end;

 

procedure TForm1.Timer1Timer(Sender: TObject);

var

  smartdatavar: TSmartData;

begin

  getsmartdata(smartdatavar);

 

  StringGrid1.Cells[1, 1]  := IntToStr(smartdatavar[24] * 256 + smartdatavar[23]);

  StringGrid1.Cells[1, 2]  := IntToStr(smartdatavar[36] * 256 + smartdatavar[35]);

  StringGrid1.Cells[1, 3]  := IntToStr(smartdatavar[48] * 256 + smartdatavar[47]);

  StringGrid1.Cells[1, 4]  := IntToStr(smartdatavar[60] * 256 + smartdatavar[59]);

  StringGrid1.Cells[1, 5]  := IntToStr(smartdatavar[72] * 256 + smartdatavar[71]);

  StringGrid1.Cells[1, 6]  := IntToStr(smartdatavar[84] * 256 + smartdatavar[83]);

  StringGrid1.Cells[1, 7]  := IntToStr(smartdatavar[96] * 256 + smartdatavar[95]);

  StringGrid1.Cells[1, 8]  := IntToStr(smartdatavar[108] * 256 + smartdatavar[107]);

  StringGrid1.Cells[1, 9]  := IntToStr(smartdatavar[120] * 256 + smartdatavar[119]);

  StringGrid1.Cells[1, 10] := IntToStr(smartdatavar[132] * 256 + smartdatavar[131]);

  StringGrid1.Cells[1, 11] := IntToStr(smartdatavar[156] * 256 + smartdatavar[155]);

  StringGrid1.Cells[1, 12] := IntToStr(smartdatavar[168] * 256 + smartdatavar[167]);

  StringGrid1.Cells[1, 13] := IntToStr(smartdatavar[192] * 256 + smartdatavar[191]);

  StringGrid1.Cells[1, 14] := IntToStr(smartdatavar[204] * 256 + smartdatavar[203]);

  StringGrid1.Cells[1, 15] := IntToStr(smartdatavar[216] * 256 + smartdatavar[215]);

  StringGrid1.Cells[1, 16] := IntToStr(smartdatavar[228] * 256 + smartdatavar[227]);

  StringGrid1.Cells[1, 17] := IntToStr(smartdatavar[240] * 256 + smartdatavar[239]);

end;

 

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

 

...use an Exe Internal Virtual File System @ RunTime?

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

 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;

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;

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;

end;

 

(* CSI-FAT - STOP *)

 

// -------------- Howto Use: -----------------------------------------

 

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

 

...use an Exe Internal Virtual File System @ RunTime?

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

 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;

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;

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;

end;

 

(* CSI-FAT - STOP *)

 

// -------------- Howto Use: -----------------------------------------

 

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