Drony -  ISO to Win [Unit]

{

drony

http://forum.donanimhaber.com

drony_dh@hotmail.com

 

Drony Application Protect 3.09 beta (DAP3)

http://forum.donanimhaber.com/upload/forceddownload.asp?file=0;4820197

 

Drony Image to Html 1.2e (I2H)

http://forum.donanimhaber.com/upload/forceddownload.asp?file=3;4853660

}

 

unit IsoWin;

 

interface

 

function Iso2Win(const AIso : String): String;

 

implementation

uses SysUtils;

 

function Iso2Win(const AIso : String): String;

var

  c : Char;

  i : Integer;

begin

  Result := EmptyStr;

  for i := 1 to Length(AIso) do

  begin

    case AIso[i] of

      #177 : c := '¹';

      #182 : c := 'œ';

      #188 : c := 'Ÿ';

      #161 : c := '¥';

      #166 : c := 'Œ';

      #172 : c := '�';

      else

        c := AIso[i];

    end;

    Result := Result + c;

  end;

end;

 

end.

 

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

 

Drony -  ISO to Win [Unit]

{

drony

http://forum.donanimhaber.com

drony_dh@hotmail.com

 

Drony Application Protect 3.09 beta (DAP3)

http://forum.donanimhaber.com/upload/forceddownload.asp?file=0;4820197

 

Drony Image to Html 1.2e (I2H)

http://forum.donanimhaber.com/upload/forceddownload.asp?file=3;4853660

}

 

unit IsoWin;

 

interface

 

function Iso2Win(const AIso : String): String;

 

implementation

uses SysUtils;

 

function Iso2Win(const AIso : String): String;

var

  c : Char;

  i : Integer;

begin

  Result := EmptyStr;

  for i := 1 to Length(AIso) do

  begin

    case AIso[i] of

      #177 : c := '¹';

      #182 : c := 'œ';

      #188 : c := 'Ÿ';

      #161 : c := '¥';

      #166 : c := 'Œ';

      #172 : c := '�';

      else

        c := AIso[i];

    end;

    Result := Result + c;

  end;

end;

 

end.

 

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

 

PriorityClass

{

drony

http://forum.donanimhaber.com

 

Drony Application Protect 3.09 beta (DAP3)

http://forum.donanimhaber.com/upload/forceddownload.asp?file=0;4820197

 

Drony Image to Html 1.2e (I2H)

http://forum.donanimhaber.com/upload/forceddownload.asp?file=3;4853660

}

{

 

programınızın diğer programlara göre işlem önceliğini aşağıdaki kod ile sağlayabilirsiniz

delphi vb ve c++ ta da aynı şekilde kullanabilirsiniz.

}

 

 

SetPriorityClass(GetCurrentProcess,HIGH_PRIORITY_CLASS)

 

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

 

PriorityClass

{

drony

http://forum.donanimhaber.com

 

Drony Application Protect 3.09 beta (DAP3)

http://forum.donanimhaber.com/upload/forceddownload.asp?file=0;4820197

 

Drony Image to Html 1.2e (I2H)

http://forum.donanimhaber.com/upload/forceddownload.asp?file=3;4853660

}

{

 

programınızın diğer programlara göre işlem önceliğini aşağıdaki kod ile sağlayabilirsiniz

delphi vb ve c++ ta da aynı şekilde kullanabilirsiniz.

}

 

 

SetPriorityClass(GetCurrentProcess,HIGH_PRIORITY_CLASS)

 

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

 

antidump & antipro dump

{

drony

http://forum.donanimhaber.com

 

Drony Application Protect 3.09 beta (DAP3)

http://forum.donanimhaber.com/upload/forceddownload.asp?file=0;4820197

 

Drony Image to Html 1.2e (I2H)

http://forum.donanimhaber.com/upload/forceddownload.asp?file=3;4853660

}

{

procedure dump'ı ve debug'ı önleyeceğini öne süren iki procedure

}

 

procedure AntiProcDump;assembler;

asm

        MOV     EAX, fs:[30h]

        TEST    EAX, EAX

        JS      @is9x

 

  @isNT:

        MOV     EAX, [EAX+0Ch]

        MOV     EAX, [EAX+0Ch]

        ADD     DWORD PTR [EAX+20h], 2000h {increase size variable}

        JMP     @finished

 

  @is9x:

        PUSH    0

        CALL    GetModuleHandleA

        TEST    EDX, EDX

        JNS     @finished                  {Most probably incompatible!!!}

        CMP     DWORD PTR [EDX+8], -1

        JNE     @finished                  {Most probably incompatible!!!}

        MOV     EDX, [EDX+4]               {get address of internaly used}

                                           {PE header}

        ADD     DWORD PTR [EDX+50h], 2000h {increase size variable}

 

  @finished:

end;

 

procedure antidebug;assembler;

asm

   jmp @jump;

   db $b8;// fake mov-instruction

    @fake1: jmp @ende;

  @endlos:

   int 3

   xor ax,ax

   jmp @endlos;

 

  @jump:

    jmp @fake1

  @ende:

end;

 

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

 

antidump & antipro dump

{

drony

http://forum.donanimhaber.com

 

Drony Application Protect 3.09 beta (DAP3)

http://forum.donanimhaber.com/upload/forceddownload.asp?file=0;4820197

 

Drony Image to Html 1.2e (I2H)

http://forum.donanimhaber.com/upload/forceddownload.asp?file=3;4853660

}

{

procedure dump'ı ve debug'ı önleyeceğini öne süren iki procedure

}

 

procedure AntiProcDump;assembler;

asm

        MOV     EAX, fs:[30h]

        TEST    EAX, EAX

        JS      @is9x

 

  @isNT:

        MOV     EAX, [EAX+0Ch]

        MOV     EAX, [EAX+0Ch]

        ADD     DWORD PTR [EAX+20h], 2000h {increase size variable}

        JMP     @finished

 

  @is9x:

        PUSH    0

        CALL    GetModuleHandleA

        TEST    EDX, EDX

        JNS     @finished                  {Most probably incompatible!!!}

        CMP     DWORD PTR [EDX+8], -1

        JNE     @finished                  {Most probably incompatible!!!}

        MOV     EDX, [EDX+4]               {get address of internaly used}

                                           {PE header}

        ADD     DWORD PTR [EDX+50h], 2000h {increase size variable}

 

  @finished:

end;

 

procedure antidebug;assembler;

asm

   jmp @jump;

   db $b8;// fake mov-instruction

    @fake1: jmp @ende;

  @endlos:

   int 3

   xor ax,ax

   jmp @endlos;

 

  @jump:

    jmp @fake1

  @ende:

end;

 

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

 

Is Disk in Drive?

Is Disk in Drive?

Before trying to save or load a file you can "quietly" check if a floppy drive

has a floppy disk in it and present the user with a meaningful error message

rather than just getting a critical error box that Windows displays.

 

procedure TForm1.Button1Click(Sender: TObject) ;

var

   EMode: Word;

begin

  EMode := SetErrorMode(SEM_FAILCRITICALERRORS) ;

  try

    if DiskSize(Ord('A')-$40) <> -1 then

      ShowMessage('Disk <b>in</b> drive A: !')

    else

      ShowMessage('No disk <b>in</b> drive A: !') ;

  finally

    SetErrorMode(EMode) ;

  end;

end;

 

Disk free space

If you need to do a backup on a floppy disk, it is a good idea to check amount

of free disk space.

 

procedure TForm1.Button2Click(Sender: TObject) ;

var

   Drive: Byte;

   sFD, sSD : string;

   DFree, DSize : int64;

begin

  Drive:=1;

  DFree:=DiskFree(Drive) ;

  DSize:=DiskSize(Drive) ;

  if (DFree <> -1) and (DSize <> -1) then

  begin

    sFD:='Disk Free: '+IntToStr(DFree div 1024)+' Kb';

    sSD:='Disk Size: '+IntToStr(DSize div 1024)+' Kb';

    ShowMessage(sFD + #13 + sSD) ;

  end;

end;

 

Windows format

The idea here is to handle disk formatting using the same dialog box that the

Shell uses. If you want to, you can even silently use DOS format

function.

Note: add ShellApi to unit's uses clause.

 

procedure TForm1.Button4Click(Sender: TObject) ;

const

   SHFMT_DRV_A = 0;

   SHFMT_DRV_B = 1;

   SHFMT_ID_DEFAULT = $FFFF;

   SHFMT_OPT_QUICKFORMAT = 0;

   SHFMT_OPT_FULLFORMAT = 1;

   SHFMT_OPT_SYSONLY = 2;

   SHFMT_ERROR = -1;

   SHFMT_CANCEL = -2;

   SHFMT_NOFORMAT = -3;

var

   FmtRes : LongInt;

begin

  try

   FmtRes:=ShFormatDrive(Handle,

                         SHFMT_DRV_A,

                         SHFMT_ID_DEFAULT,

                         SHFMT_OPT_QUICKFORMAT) ;

   case FmtRes of

    SHFMT_ERROR:

     ShowMessage('Error formatting the drive') ;

    SHFMT_CANCEL:

     ShowMessage('User canceled formatting the drive') ;

    SHFMT_NOFORMAT:

     ShowMessage('Drive is not formatable')

   else

     ShowMessage('Disk has been formatted') ;

   end;

  except

   ShowMessage('Error occurred!')

  end;

end;

 

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

 

Is Disk in Drive?

Is Disk in Drive?

Before trying to save or load a file you can "quietly" check if a floppy drive

has a floppy disk in it and present the user with a meaningful error message

rather than just getting a critical error box that Windows displays.

 

procedure TForm1.Button1Click(Sender: TObject) ;

var

   EMode: Word;

begin

  EMode := SetErrorMode(SEM_FAILCRITICALERRORS) ;

  try

    if DiskSize(Ord('A')-$40) <> -1 then

      ShowMessage('Disk <b>in</b> drive A: !')

    else

      ShowMessage('No disk <b>in</b> drive A: !') ;

  finally

    SetErrorMode(EMode) ;

  end;

end;

 

Disk free space

If you need to do a backup on a floppy disk, it is a good idea to check amount

of free disk space.

 

procedure TForm1.Button2Click(Sender: TObject) ;

var

   Drive: Byte;

   sFD, sSD : string;

   DFree, DSize : int64;

begin

  Drive:=1;

  DFree:=DiskFree(Drive) ;

  DSize:=DiskSize(Drive) ;

  if (DFree <> -1) and (DSize <> -1) then

  begin

    sFD:='Disk Free: '+IntToStr(DFree div 1024)+' Kb';

    sSD:='Disk Size: '+IntToStr(DSize div 1024)+' Kb';

    ShowMessage(sFD + #13 + sSD) ;

  end;

end;

 

Windows format

The idea here is to handle disk formatting using the same dialog box that the

Shell uses. If you want to, you can even silently use DOS format

function.

Note: add ShellApi to unit's uses clause.

 

procedure TForm1.Button4Click(Sender: TObject) ;

const

   SHFMT_DRV_A = 0;

   SHFMT_DRV_B = 1;

   SHFMT_ID_DEFAULT = $FFFF;

   SHFMT_OPT_QUICKFORMAT = 0;

   SHFMT_OPT_FULLFORMAT = 1;

   SHFMT_OPT_SYSONLY = 2;

   SHFMT_ERROR = -1;

   SHFMT_CANCEL = -2;

   SHFMT_NOFORMAT = -3;

var

   FmtRes : LongInt;

begin

  try

   FmtRes:=ShFormatDrive(Handle,

                         SHFMT_DRV_A,

                         SHFMT_ID_DEFAULT,

                         SHFMT_OPT_QUICKFORMAT) ;

   case FmtRes of

    SHFMT_ERROR:

     ShowMessage('Error formatting the drive') ;

    SHFMT_CANCEL:

     ShowMessage('User canceled formatting the drive') ;

    SHFMT_NOFORMAT:

     ShowMessage('Drive is not formatable')

   else

     ShowMessage('Disk has been formatted') ;

   end;

  except

   ShowMessage('Error occurred!')

  end;

end;

 

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

 

What is Volume's Serial Number?

What is Volume's Serial Number?

In short, the serial number of a (logical) drive is generated every time a drive

 is formatted. When Windows formats a drive, a drive's serial number gets calculated

 using the current date and time and is stored in the drive's boot sector.

 (The odds of two disks getting the same number are virtually nil on the same machine.)

Here's a simple Delphi routine that gets the serial number of a disk

(not the hard-coded manufacturer's hard drive serial number):

 

~~~~~~~~~~~~~~~~~~~~~~~~~

function FindVolumeSerial(const Drive : PChar) : string;

var

   VolumeSerialNumber : DWORD;

   MaximumComponentLength : DWORD;

   FileSystemFlags : DWORD;

   SerialNumber : string;

begin

   Result:='';

 

   GetVolumeInformation(

        Drive,

        nil,

        0,

        @VolumeSerialNumber,

        MaximumComponentLength,

        FileSystemFlags,

        nil,

        0) ;

   SerialNumber :=

         IntToHex(HiWord(VolumeSerialNumber), 4) +

         ' - ' +

         IntToHex(LoWord(VolumeSerialNumber), 4) ;

 

   Result := SerialNumber;

end; (*FindVolumeSerial*)

 

~~~~~~~~~~~~~~~~~~~~~~~~~

 

 

Usage is simple:

 

~~~~~~~~~~~~~~~~~~~~~~~~~

var

   C_DriveSerNumber : string;

...

C_DriveSerNumber := FindVolumeSerial('c:') ;

~~~~~~~~~~~~~~~~~~~~~~~~~

 

 

Note: the GetVolumeInformation API function is declared in the Windows unit,

hence there's no need to add any additional units in the uses list.

 

Why would I need this number in my applications?

You could use the volume serial number to enforce a weak form of application

protection - create your application so that it refuses to run if the current

disk (from where the application is executed) has a volume serial number that

was different from the number of the hard disk on which it was first installed.

 

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

 

What is Volume's Serial Number?

What is Volume's Serial Number?

In short, the serial number of a (logical) drive is generated every time a drive

 is formatted. When Windows formats a drive, a drive's serial number gets calculated

 using the current date and time and is stored in the drive's boot sector.

 (The odds of two disks getting the same number are virtually nil on the same machine.)

Here's a simple Delphi routine that gets the serial number of a disk

(not the hard-coded manufacturer's hard drive serial number):

 

~~~~~~~~~~~~~~~~~~~~~~~~~

function FindVolumeSerial(const Drive : PChar) : string;

var

   VolumeSerialNumber : DWORD;

   MaximumComponentLength : DWORD;

   FileSystemFlags : DWORD;

   SerialNumber : string;

begin

   Result:='';

 

   GetVolumeInformation(

        Drive,

        nil,

        0,

        @VolumeSerialNumber,

        MaximumComponentLength,

        FileSystemFlags,

        nil,

        0) ;

   SerialNumber :=

         IntToHex(HiWord(VolumeSerialNumber), 4) +

         ' - ' +

         IntToHex(LoWord(VolumeSerialNumber), 4) ;

 

   Result := SerialNumber;

end; (*FindVolumeSerial*)

 

~~~~~~~~~~~~~~~~~~~~~~~~~

 

 

Usage is simple:

 

~~~~~~~~~~~~~~~~~~~~~~~~~

var

   C_DriveSerNumber : string;

...

C_DriveSerNumber := FindVolumeSerial('c:') ;

~~~~~~~~~~~~~~~~~~~~~~~~~

 

 

Note: the GetVolumeInformation API function is declared in the Windows unit,

hence there's no need to add any additional units in the uses list.

 

Why would I need this number in my applications?

You could use the volume serial number to enforce a weak form of application

protection - create your application so that it refuses to run if the current

disk (from where the application is executed) has a volume serial number that

was different from the number of the hard disk on which it was first installed.

 

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

 

Allah Rızası İçin Yardım Edin Çıldıracam...

Arkadaşlarım kardeşlerim Allah rızası için yardım edin çok zor durumdayım.

Allahın belası qreportta yapılan bir fatura dizaynını printera nasıl

3/a4 boyutunda gönderirim. Yani genişlik 210mm uzunluk 100mm qreporttaki

page ayarları şöyle

pagesize := custom

page.lenght := 100mm

yanlızca datailband seçili

yazıcılar ve fakslar sunucu ayarlarında yeni diye bir bölüm ekledim

kağıdın genişliği 21cm uzunluğu 10cm yazıcıda bu ayarları gösterdim.

Yazıcı Panasonic kx-1150 bunun dos ayarları yapılı yani page lenght'i 4"olarak ayarlı

qreportun ayarlarını default, zarf, envelope v.s v.s denedim hiç bir işe yaramadı

ne yaparsam yapayım hep a4 boyutunda sürüyor kağıdı. (3/a4 değil yani)

text file ile denedim sitedeki ancak bazı kodlar çalışmıyor bazılarınıda

ben qreporttan dosyaya sonra dostan printera nasıl gönderileceğini anlamadım.

zaten başka applicationda denedim tek satırlık birşey gönderdim

normal bir şey gönderdim yine olmadı.

 

Çaresizim sıkıştırıyorlar. Bende delirmek üzereyim. Allah Rızası için yardım edin.

 

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

 

Allah Rızası İçin Yardım Edin Çıldıracam...

Arkadaşlarım kardeşlerim Allah rızası için yardım edin çok zor durumdayım.

Allahın belası qreportta yapılan bir fatura dizaynını printera nasıl

3/a4 boyutunda gönderirim. Yani genişlik 210mm uzunluk 100mm qreporttaki

page ayarları şöyle

pagesize := custom

page.lenght := 100mm

yanlızca datailband seçili

yazıcılar ve fakslar sunucu ayarlarında yeni diye bir bölüm ekledim

kağıdın genişliği 21cm uzunluğu 10cm yazıcıda bu ayarları gösterdim.

Yazıcı Panasonic kx-1150 bunun dos ayarları yapılı yani page lenght'i 4"olarak ayarlı

qreportun ayarlarını default, zarf, envelope v.s v.s denedim hiç bir işe yaramadı

ne yaparsam yapayım hep a4 boyutunda sürüyor kağıdı. (3/a4 değil yani)

text file ile denedim sitedeki ancak bazı kodlar çalışmıyor bazılarınıda

ben qreporttan dosyaya sonra dostan printera nasıl gönderileceğini anlamadım.

zaten başka applicationda denedim tek satırlık birşey gönderdim

normal bir şey gönderdim yine olmadı.

 

Çaresizim sıkıştırıyorlar. Bende delirmek üzereyim. Allah Rızası için yardım edin.

 

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

 

cd kapağını açmak/kapatmak

uses MMSystem;

 

procedure CloseCD(Drive : char);

var

  mp : TMediaPlayer;

begin

  result := false;

  Application.ProcessMessages;

  mp := TMediaPlayer.Create(nil);

  mp.Visible := false;

  mp.Parent := Application.MainForm;

  mp.Shareable := true;

  mp.DeviceType := dtCDAudio;

  mp.FileName := Drive + ':';

  mp.Open;

  Application.ProcessMessages;

  mciSendCommand(mp.DeviceID,

  MCI_SET, MCI_SET_DOOR_CLOSED, 0);

  Application.ProcessMessages;

  mp.Close;

  Application.ProcessMessages;

  mp.free;

  result := true;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  CloseCD('D');

end;

 

function IsDriveCD(Drive : char) : longbool;

var

  DrivePath : string;

begin

  DrivePath := Drive + ':';

  result := LongBool(GetDriveType(PChar(DrivePath)) and DRIVE_CDROM);

end;

 

function EjectCD(Drive : char) : bool;

var

  mp : TMediaPlayer;

begin

  result := false;

  Application.ProcessMessages;

  if not IsDriveCD(Drive) then exit;

  mp := TMediaPlayer.Create(nil);

  mp.Visible := false;

  mp.Parent := Application.MainForm;

  mp.Shareable := true;

  mp.DeviceType := dtCDAudio;

  mp.FileName := Drive + ':';

  mp.Open;

  Application.ProcessMessages;

  mp.Eject;

  Application.ProcessMessages;

  mp.Close;

  Application.ProcessMessages;

  mp.free;

  result := true;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  if not EjectCD('D') then

    ShowMessage('Not A CD Drive');

end;

 

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

 

cd kapağını açmak/kapatmak

uses MMSystem;

 

procedure CloseCD(Drive : char);

var

  mp : TMediaPlayer;

begin

  result := false;

  Application.ProcessMessages;

  mp := TMediaPlayer.Create(nil);

  mp.Visible := false;

  mp.Parent := Application.MainForm;

  mp.Shareable := true;

  mp.DeviceType := dtCDAudio;

  mp.FileName := Drive + ':';

  mp.Open;

  Application.ProcessMessages;

  mciSendCommand(mp.DeviceID,

  MCI_SET, MCI_SET_DOOR_CLOSED, 0);

  Application.ProcessMessages;

  mp.Close;

  Application.ProcessMessages;

  mp.free;

  result := true;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  CloseCD('D');

end;

 

function IsDriveCD(Drive : char) : longbool;

var

  DrivePath : string;

begin

  DrivePath := Drive + ':';

  result := LongBool(GetDriveType(PChar(DrivePath)) and DRIVE_CDROM);

end;

 

function EjectCD(Drive : char) : bool;

var

  mp : TMediaPlayer;

begin

  result := false;

  Application.ProcessMessages;

  if not IsDriveCD(Drive) then exit;

  mp := TMediaPlayer.Create(nil);

  mp.Visible := false;

  mp.Parent := Application.MainForm;

  mp.Shareable := true;

  mp.DeviceType := dtCDAudio;

  mp.FileName := Drive + ':';

  mp.Open;

  Application.ProcessMessages;

  mp.Eject;

  Application.ProcessMessages;

  mp.Close;

  Application.ProcessMessages;

  mp.free;

  result := true;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  if not EjectCD('D') then

    ShowMessage('Not A CD Drive');

end;

 

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

 

Microsoft Binary Format-IEEE (Metastock Data)

Daha çok eski 8087 ve 8088 işlemcilerde kullanılan Microsoft Binary Format'ı Borland Delphi 'nin anlayabileceği data tiplerinden olan IEEE standardına çevirebilmek için kullanabileceğiniz 4 fonksiyon aşağıdadır.

 

 

Peki ne işe yarar; bir gün Metastock Dataları ile uğraşacak olursanız benim gibi 24 saat boyunca arama yapmak zorunda kalmazsınız.

Elinizde MBF ile kodlanmış binary datalar varsa bunları Delphi'nin anlayacağı dile çevirebilirsiniz.

 

{C++ ile yazılmış fonksiyonlardan tercüme edilmiştir.}

 

 

 

//  _fmsbintoieee()  //4 byte'lık MBF Formatını IEEE Formatına çevirir

//  _fieeetomsbin()  //4 byte'lık IEEE Formatını MBF Formatına çevirir

//  _dmsbintoieee()  //8 byte'lık MBF Formatını IEEE Formatına çevirir

//  _dieeetomsbin()  //8 byte'lık IEEE Formatını MBF Formatına çevirir

//

// Keyword for Search Machine :

// These functions convert back and forth from Microsoft Binary Format to IEEE floating point format in Delphi.

 

 

function _fmsbintoieee(const src4: Single; var dest4: Single): Integer;

var

  msbin: array[0..3] of Byte absolute src4;

  ieee: array[0..3] of Byte absolute dest4;

  sign: Byte;

  ieee_exp: Byte;

  i: Integer;

begin

  (* MS Binary Format                         *)

  (* byte order =>    m3 | m2 | m1 | exponent *)

  (* m1 is most significant byte => sbbb|bbbb *)

  (* m3 is the least significant byte         *)

  (*      m = mantissa byte                   *)

  (*      s = sign bit                        *)

  (*      b = bit                             *)

  sign := msbin[2] and $80;    (* 1000|0000b  *)

  (* IEEE Single Precision Float Format       *)

  (*    m3        m2        m1     exponent   *)

  (* mmmm|mmmm mmmm|mmmm emmm|mmmm seee|eeee  *)

  (*          s = sign bit                    *)

  (*          e = exponent bit                *)

  (*          m = mantissa bit                *)

  for i := 0 to 3 do

    ieee[i] := 0;

  (* any msbin w/ exponent of zero = zero *)

  if msbin[3] = 0 then

  begin

    Result := 0;

    Exit;

  end;

  ieee[3] := ieee[3] or sign;

  (* MBF is bias 128 and IEEE is bias 127. ALSO, MBF places   *)

  (* the decimal point before the assumed bit, while          *)

  (* IEEE places the decimal point after the assumed bit.     *)

  ieee_exp := msbin[3] - 2;   (* actually, msbin[3]-1-128+127 *)

  (* the first 7 bits of the exponent in ieee[3] *)

  ieee[3] := ieee[3] or (ieee_exp shr 1);

  (* the one remaining bit in first bin of ieee[2] *)

  ieee[2] := ieee[2] or (ieee_exp shl 7);

  (* 0111|1111b : mask out the msbin sign bit *)

  ieee[2] := ieee[2] or (msbin[2] and $7f);

  ieee[1] := msbin[1];

  ieee[0] := msbin[0];

  Result := 0;

end;

 

 

function _fieeetomsbin(const src4: Single; var dest4: Single): Integer;

var

  ieee: array[0..3] of Byte absolute src4;

  msbin: array[0..3] of Byte absolute dest4;

  sign: Byte;

  msbin_exp: Byte;

  i: Integer;

begin

  msbin_exp := 0;

  (* See _fmsbintoieee() for details of formats   *)

  sign := ieee[3] and $80;

  msbin_exp := msbin_exp or (ieee[3] shl 1);

  msbin_exp := msbin_exp or (ieee[2] shr 7);

  (* An ieee exponent of 0xfe overflows in MBF    *)

  if msbin_exp = $fe then

  begin

    Result := 1;

    Exit;

  end;

  msbin_exp := msbin_exp + 2; (* actually, -127 + 128 + 1 *)

  for i := 0 to 3 do

    msbin[i] := 0;

  msbin[3] := msbin_exp;

  msbin[2] := msbin[2] or sign;

  msbin[2] := msbin[2] or (ieee[2] and $7f);

  msbin[1] := ieee[1];

  msbin[0] := ieee[0];

  Result := 0;

end;

 

 

function _dmsbintoieee(const src8: Double; var dest8: Double): Integer;

var

  msbin: array[0..7] of Byte;

  ieee: array[0..7] of Byte absolute dest8;

  sign: Byte;

  ieee_exp: Byte;

  i: Integer;

begin

  (* A manipulatable copy of the msbin number     *)

  Move(src8, msbin, 8);

  (* MS Binary Format                                           *)

  (* byte order =>  m7 | m6 | m5 | m4 | m3 | m2 | m1 | exponent *)

  (* m1 is most significant byte => smmm|mmmm                   *)

  (* m7 is the least significant byte                           *)

  (*      m = mantissa byte                                     *)

  (*      s = sign bit                                          *)

  (*      b = bit                                               *)

  sign := msbin[6] and $80;        (* 1000|0000b  *)

  (* IEEE Single Precision Float Format                         *)

  (*  byte 8    byte 7    byte 6    byte 5    byte 4  and so on *)

  (* seee|eeee eeee|mmmm mmmm|mmmm mmmm|mmmm mmmm|mmmm ...      *)

  (*          s = sign bit                                      *)

  (*          e = exponent bit                                  *)

  (*          m = mantissa bit                                  *)

  for i := 0 to 7 do

    ieee[i] := 0;

  (* any msbin w/ exponent of zero = zero *)

  if msbin[7] = 0 then

  begin

    Result := 0;

    Exit;

  end;

  ieee[7] := ieee[7] or sign;

  (* MBF is bias 128 and IEEE is bias 1023. ALSO, MBF places  *)

  (* the decimal point before the assumed bit, while          *)

  (* IEEE places the decimal point after the assumed bit.     *)

  ieee_exp := msbin[7] - 128 - 1 + 1023;

  (* First 4 bits of the msbin exponent   *)

  (* go into the last 4 bits of ieee[7]   *)

  ieee[7] := ieee[7] or (ieee_exp shr 4);

  (* The last 4 bits of msbin exponent    *)

  (* go into the first 4 bits of ieee[6]  *)

  ieee[6] := ieee[6] or (ieee_exp shl 4);

  (* The msbin mantissa must be shifted to the right 1 bit.   *)

  (* Remember that the msbin number has its bytes reversed.   *)

  for i := 6 downto 1 do

  begin

    msbin[i] := msbin[i] shl 1;

    msbin[i] := msbin[i] or (msbin[i - 1] shr 7);

  end;

  msbin[0] := msbin[0] shl 1;

  (* Now the mantissa is put into the ieee array starting in  *)

  (* the middle of the second to last byte.                   *)

  for i := 6 downto 1 do

  begin

    ieee[i] := ieee[i] or (msbin[i] shr 4);

    ieee[i - 1] := ieee[i - 1] or (msbin[i] shl 4);

  end;

  ieee[0] := ieee[0] or (msbin[0] shr 4);

  (* IEEE has a half byte less for its mantissa.  If the msbin *)

  (* number has anything in this last half byte, then there is *)

  (* an overflow.                                              *)

  if (msbin[0] and $0f) > 0 then

    Result := 1

  else

    Result := 0;

end;

 

 

function _dieeetomsbin(const src8: Double; var dest8: Double): Integer;

var

  ieee: array[0..7] of Byte;

  msbin: array[0..7] of Byte absolute dest8;

  sign: Byte;

  any_on: Byte;

  msbin_exp: SmallInt;

  i: Integer;

begin

  any_on := 0;

  (* Make a clobberable copy of the source number *)

  Move(src8, ieee, 8);

  for i := 0 to 7 do

    msbin[i] := 0;

  (* If all are zero in src8, the msbin should be zero *)

  for i := 0 to 7 do

    any_on := any_on or ieee[i];

  if any_on = 0 then

  begin

    Result := 0;

    Exit;

  end;

  sign := ieee[7] and $80;

  msbin[6] := msbin[6] or sign;

  msbin_exp := (ieee[7] and $7f) * $10;

  msbin_exp := msbin_exp + (ieee[6] shr 4);

  if (msbin_exp - $3ff) > $80 then

  begin

    Result := 1;

    Exit;

  end;

  msbin[7] := msbin_exp - $3ff + $80 + 1;

  (* The ieee mantissa must be shifted up 3 bits *)

  ieee[6] := ieee[6] and $0f; (* mask out the exponent in the second byte *)

  for i := 6 downto 1 do

  begin

    msbin[i] := msbin[i] or (ieee[i] shl 3);

    msbin[i] := msbin[i] or (ieee[i - 1] shr 5);

  end;

  msbin[0] := msbin[0] or (ieee[0] shl 3);

  Result := 0;

end;

 

 

end.

 

/////////////////////////////////////////

Ayrıntılı Bilgi için (For more Information) : swordtur@yahoo.com

 

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