1. how to eject and close CD-Drive?
2. Moving from VB to Delphi
3. sscanf in delphi?
4. Supporting Cut Copy Paste
5. Multiple icons in a Delphi exe?
6. Credit card verification
7. Searching text in a textfile
8. Cool tip for hints on status bars
9. Calling a Procedure with it's name in a variable

how to eject and close CD-Drive?

From: Christian Piene Gundersen <j.c.p.gundersen@jusstud.uio.no>

ClaWenkel wrote:
>
> Is there any API command in Delphi2 to eject AND CLOSE the CD-ROM Drive
> physically e.g. by clicking on a button? I don't want to use the
> TMediaPlayer component (which can only eject...)
> thanks in advance, ClaWenkel

To open the CD-ROM:

        mciSendString('Set cdaudio door open wait', nil, 0, handle); 

To close the CD-ROM:

        mciSendString('Set cdaudio door closed wait', nil, 0, handle); 

Remember to include the MMSystem unit in your uses clause.

Moving from VB to Delphi

The Graphical Gnome <rdb@ktibv.nl>

Borland has a page describing the differences between Delphi and VB. It can be found at

http://netserv.borland.com/delphi/papers/vb2dl/compon.html

sscanf in delphi?

From: canalrun@vcomm.net (Barry)

unit Scanf;

interface
uses SysUtils;

type
  EFormatError = class(ExCeption);


  function Sscanf(const s: string; const fmt : string;
                      const Pointers : array of Pointer) : Integer;
implementation

{ Sscanf parses an input string. The parameters ...
    s - input string to parse
    fmt - 'C' scanf-like format string to control parsing
      %d - convert a Long Integer
      %f - convert an Extended Float
      %s - convert a string (delimited by spaces)
      other char - increment s pointer past "other char"
      space - does nothing
    Pointers - array of pointers to have values assigned

    result - number of variables actually assigned

    for example with ...
      Sscanf('Name. Bill   Time. 7:32.77   Age. 8',
             '. %s . %d:%f . %d', [@Name, @hrs, @min, @age]);

    You get ...
      Name = Bill  hrs = 7  min = 32.77  age = 8                }

function Sscanf(const s: string; const fmt : string;
                      const Pointers : array of Pointer) : Integer;
var
  i,j,n,m : integer;
  s1      : string;
  L       : LongInt;
  X       : Extended;

  function GetInt : Integer;
  begin
    s1 := '';
    while (s[n] = ' ')  and (Length(s) > n) do inc(n);
    while (s[n] in ['0'..'9', '+', '-'])
      and (Length(s) >= n) do begin
      s1 := s1+s[n];
      inc(n);
    end;
    Result := Length(s1);
  end;

  function GetFloat : Integer;
  begin
    s1 := '';
    while (s[n] = ' ')  and (Length(s) > n) do inc(n);
    while (s[n] in ['0'..'9', '+', '-', '.', 'e', 'E'])
      and (Length(s) >= n) do begin
      s1 := s1+s[n];
      inc(n);
    end;
    Result := Length(s1);
  end;

  function GetString : Integer;
  begin
    s1 := '';
    while (s[n] = ' ')  and (Length(s) > n) do inc(n);
    while (s[n] <> ' ') and (Length(s) >= n) do
    begin
      s1 := s1+s[n];
      inc(n);
    end;
    Result := Length(s1);
  end;

  function ScanStr(c : Char) : Boolean;
  begin
    while (s[n] <> c) and (Length(s) > n) do inc(n);
    inc(n);

    If (n <= Length(s)) then Result := True
    else Result := False;
  end;

  function GetFmt : Integer;
  begin
    Result := -1;

    while (TRUE) do begin
      while (fmt[m] = ' ') and (Length(fmt) > m) do inc(m);
      if (m >= Length(fmt)) then break;

      if (fmt[m] = '%') then begin
        inc(m);
        case fmt[m] of
          'd': Result := vtInteger;
          'f': Result := vtExtended;
          's': Result := vtString;
        end;
        inc(m);
        break;
      end;

      if (ScanStr(fmt[m]) = False) then break;
      inc(m);
    end;
  end;

begin
  n := 1;
  m := 1;
  Result := 0;

  for i := 0 to High(Pointers) do begin
    j := GetFmt;

    case j of
      vtInteger : begin
        if GetInt > 0 then begin
          L := StrToInt(s1);
          Move(L, Pointers[i]^, SizeOf(LongInt));
          inc(Result);
        end
        else break;
      end;

      vtExtended : begin
        if GetFloat > 0 then begin
          X := StrToFloat(s1);
          Move(X, Pointers[i]^, SizeOf(Extended));
          inc(Result);
        end
        else break;
      end;

      vtString : begin
        if GetString > 0 then begin
          Move(s1, Pointers[i]^, Length(s1)+1);
          inc(Result);
        end
        else break;
      end;

      else break;
    end;
  end;
end;

end.

Supporting Cut Copy Paste

From: "Shejchenko Andrij" <andrij@dep01.niiit.kiev.ua>

procedure TMainForm.EditUndo(Sender: TObject);
var Mes:TWMUndo;
begin
     Mes.Msg:=WM_UNDO;
     Screen.ActiveControl.Dispatch(Mes);
end;

procedure TMainForm.EditCut(Sender: TObject);
var Mes:TWMCut;
begin
     Mes.Msg:=WM_CUT;
     Screen.ActiveControl.Dispatch(Mes);
end;

procedure TMainForm.EditCopy(Sender: TObject);
var Mes:TWMCopy;
begin
     Mes.Msg:=WM_COPY;
     Screen.ActiveControl.Dispatch(Mes);
end;

procedure TMainForm.EditPaste(Sender: TObject);
var Mes:TWMPaste;
begin
     Mes.Msg:=WM_PASTE;
     Screen.ActiveControl.Dispatch(Mes);
end;

Multiple icons in a Delphi exe?

Does anyone know how to get Delphi to place mutliple icons into one
executable? ie so that when you set up a file type and browse your Delphi
compiled application you get a number of icons, not just the single one
you'd get by specifying an icon under Project|Options|Application|Icon 

Credit card verification

unit Creditc;

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

Credit Card Number Validator Unit for Delphi

Version: 1.1
Date: December 20, 1996

This unit is based on the public domain program ccard by Peter Miller.
It is released to the public for free of charge use, but the author
reserves all rights.

copyright 1996 by Shawn Wilson Harvell ( shawn@inet.net )

usage:

Add this unit to the uses clause of any unit that needs access to the
validation function.

IsValidCreditCardNumber( CardNumber, ReturnMessage ) returns Boolean

   for example, use it in an if statement that Messages user if invalid.

CardNumber is a string containing the number that you want to validate
ReturnMessage is a string where the function can place any messages it
may return ( meaning that it will overwrite whatever is in it )

returns true if valid, false otherwise.

dashes and space in the input value are taken care of by the function,
if other characters are possible, you may wish to remove them as well.
The function RemoveChar will take care of this quite easily, simply
pass the input string and the char you wish to delete.

Users are free to modify this unit for their own use, but in
distributing you should advise all users of the changes made.

Use this unit at your own risk, it does not come with any warranties
either express or implied.  Damages resulting from the use of this
unit are the sole responsibility of the user.

This should work as is for Delphi versions 1 and 2, some slight
modifications may be necessary for Turbo Pascal ( mainly due to use to
conversion functions from the SysUtils unit ).

If you do find this useful, have any comments or suggestions, please
drop the author an email at shawn@inet.net

Revision History

version 1.1 -- December 20, 1996
blooper with Discover cards, added their length mask to the "database"

version 1.0 -- October 26, 1996
initial release

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


interface

uses SysUtils;

function IsValidCreditCardNumber( CardNumber: String; var MessageText: String ): Boolean;


implementation

const
   CardPrefixes: array[ 1..19 ] of string  =
                 ( '2014', '2149', '300', '301', '302',
                   '303', '304', '305', '34', '36', '37',
                   '38', '4', '51', '52', '53', '54', '55', '6011' );

   CardTypes: array[ 1..19 ] of String =
              ( 'enRoute',
                'enRoute',
                'Diner Club/Carte Blanche',
                'Diner Club/Carte Blanche',
                'Diner Club/Carte Blanche',
                'Diner Club/Carte Blanche',
                'Diner Club/Carte Blanche',
                'Diner Club/Carte Blanche',
                'American Express',
                'Diner Club/Carte Blanche',
                'American Express',
                'Diner Club/Carte Blanche',
                'Visa',
                'MasterCard',
                'MasterCard',
                'MasterCard',
                'MasterCard',
                'MasterCard',
                'Discover' );


function RemoveChar(const Input: String; DeletedChar: Char): String;
var
  Index: Word;                    { counter variable                              }
begin
  { all this function does is iterate through string looking for char, if found   }
  { it deletes it                                                                 }
  Result := Input;
  for Index := Length( Result ) downto 1 do
    if Result[ Index ] = DeletedChar then Delete( Result, Index, 1 );
end;

function ShiftMask( Input: Integer ): Integer;
begin
   { simply a wrapper for this left bit shift operation                           }
   result := ( 1 shl ( Input - 12 ) );
end;

function ConfirmChecksum( CardNumber: String ): Boolean;
var
   CheckSum: Integer;             { Holds the value of the operation              }
   Flag: Boolean;                 { used to indicate when ready                   }
   Counter: Integer;              { index counter                                 }
   PartNumber: String;            { used to extract each digit of number          }
   Number: Integer;               { used to convert each digit to integer         }
begin

   {**************************************************************************
   This is probably the most confusing part of the code you will see, I know
   that it is some of the most confusing I have ever seen.  Basically, this
   function is extracting each digit of the number and subjecting it to the
   checksum formula established by the credit card companies.  It works from
   the end to the front.
   **************************************************************************}

   { get the starting value for our counter }
   Counter := Length( CardNumber  );
   CheckSum := 0;
   PartNumber := '';
   Number := 0;
   Flag := false;

   while ( Counter >= 1 ) do
   begin
      { get the current digit }
      PartNumber :=  Copy( CardNumber, Counter, 1 );
      Number := StrToInt( PartNumber ); { convert to integer }
      if ( Flag ) then { only do every other digit }
      begin
         Number := Number * 2;
         if ( Number >= 10 ) then Number := Number - 9;
      end;
      CheckSum := CheckSum + Number;

      Flag := not( Flag );

      Counter := Counter - 1;
   end;

   result := ( ( CheckSum mod 10 ) = 0 );
end;

function GetMask( CardName: String  ): Integer;
begin
   { the default case }
   result := 0;

   if ( CardName = 'MasterCard' ) then result := ShiftMask( 16 );
   if ( CardName = 'Visa' ) then result := ( ShiftMask( 13 ) or ShiftMask( 16 ) );
   if ( CardName = 'American Express' ) then result := ShiftMask( 15 );
   if ( CardName = 'Diner Club/Carte Blanche' ) then result := ShiftMask( 14 );
   if ( CardName = 'Discover' ) then result := ShiftMask( 16 );

end;

function IsValidCreditCardNumber( CardNumber: String; var MessageText: String ): Boolean;
var
   StrippedNumber: String;        { used to hold the number bereft of extra chars }
   Index: Integer;                { general purpose counter for loops, etc        }
   TheMask: Integer;              { number we will use for the mask               }
   FoundIt: Boolean;              { used to indicate when something is found      }
   CardName: String;              { stores the name of the type of card           }
   PerformChecksum: Boolean;      { the enRoute type of card doesn't get it       }
begin

   { first, get rid of spaces, dashes }
   StrippedNumber := RemoveChar( CardNumber, ' ' );
   StrippedNumber := RemoveChar( StrippedNumber, '-' );

   { if the string was zero length, then OK too }
   if ( StrippedNumber = '' ) then
   begin
      result := true;
      exit;
   end;


   { initialize return variables }
   MessageText := '';
   result := true;

   { set our flag variable }
   FoundIt := false;

   { check for invalid characters right off the bat }
   for Index := 1 to Length( StrippedNumber ) do
   begin
      case StrippedNumber[ Index ] of
         '0'..'9': FoundIt := FoundIt;   { non op in other words }
      else
         MessageText := 'Invalid Characters in Input';
         result := false;
         exit;
      end;
   end;

   { now let's determine what type of card it is }
   for Index := 1 to 19 do
   begin
      if ( Pos( CardPrefixes[ Index ], StrippedNumber ) = 1 ) then
      begin
         { we've found the right one }
         FoundIt := true;
         CardName := CardTypes[ Index ];
         TheMask := GetMask( CardName );
      end;
   end;

   { if we didn't find it, indicates things are already ary }
   if ( not FoundIt ) then
   begin
      CardName := 'Unknown Card Type';
      TheMask := 0;
      MessageText := 'Unknown Card Type ';
      result := false;
      exit;
   end;

   { check the length }
   if ( ( Length( StrippedNumber ) > 28 ) and result ) then
   begin
      MessageText := 'Number is too long ';
      result := false;
      exit;
   end;


   { check the length }
   if ( ( Length( StrippedNumber ) < 12 ) or
    ( ( shiftmask( length( strippednumber ) ) and themask ) = 0 ) ) then
   begin
      messagetext := 'number length incorrect';
      result := false;
      exit;
   end;

   { check the checksum computation }
   if ( cardname = 'enroute' ) then
      performchecksum := false
   else
      performchecksum := true;

   if ( performchecksum and ( not confirmchecksum( strippednumber ) ) ) then
   begin
      messagetext := 'bad checksum';
      result := false;
      exit;
   end;

   { if result is still true, then everything is ok }
   if ( result ) then
      messagetext := 'number ok: card type: ' + cardname;

   { if the string was zero length, then ok too }
   if ( strippednumber = '' ) then
      result := true;

end;

end.

Searching text in a textfile

Anyone knows which is the best way (speed) to look for a string in a
textFile.

unit BMSearch;


(* -------------------------------------------------------------------
   Boyer-Moore string searching.

   This is one of the fastest string search algorithms.
   See a description in:

     R. Boyer and S. Moore.
     A fast string searching algorithm.
     Communications of the ACM 20, 1977, Pags 762-772
------------------------------------------------------------------- *)


interface

type
{$ifdef WINDOWS}
   size_t = Word;
{$else}
   size_t = LongInt;
{$endif}

type
   TTranslationTable = array[char] of char;  { translation table }

   TSearchBM = class(TObject)
   private
      FTranslate  : TTranslationTable;     { translation table }
      FJumpTable  : array[char] of Byte;   { Jumping table }
      FShift_1    : integer;
      FPattern    : pchar;
      FPatternLen : size_t;

   public
      procedure Prepare( Pattern: pchar; PatternLen: size_t; IgnoreCase: Boolean );
      procedure PrepareStr( const Pattern: string; IgnoreCase: Boolean );

      function  Search( Text: pchar; TextLen: size_t ): pchar;
      function  Pos( const S: string ): integer;
   end;




implementation


uses  SysUtils;



(* -------------------------------------------------------------------
   Ignore Case Table Translation
------------------------------------------------------------------- *)

procedure CreateTranslationTable( var T: TTranslationTable; IgnoreCase: Boolean );
var
   c: char;
begin
   for c := #0 to #255 do
       T[c] := c;

   if not IgnoreCase then
      exit;
      
   for c := 'a' to 'z' do
      T[c] := UpCase(c);

   { Mapping all acented characters to their uppercase equivalent }
   
   T['┴'] := 'A';
   T['└'] := 'A';
   T['─'] := 'A';
   T['┬'] := 'A';

   T['ß'] := 'A';
   T['α'] := 'A';
   T['Σ'] := 'A';
   T['Γ'] := 'A';

   T['╔'] := 'E';
   T['╚'] := 'E';
   T['╦'] := 'E';
   T['╩'] := 'E';

   T['Θ'] := 'E';
   T['Φ'] := 'E';
   T['δ'] := 'E';
   T['Ω'] := 'E';

   T['═'] := 'I';
   T['╠'] := 'I';
   T['╧'] := 'I';
   T['╬'] := 'I';

   T['φ'] := 'I';
   T['∞'] := 'I';
   T['∩'] := 'I';
   T['ε'] := 'I';

   T['╙'] := 'O';
   T['╥'] := 'O';
   T['╓'] := 'O';
   T['╘'] := 'O';

   T['≤'] := 'O';
   T['≥'] := 'O';
   T['÷'] := 'O';
   T['⌠'] := 'O';

   T['┌'] := 'U';
   T['┘'] := 'U';
   T['▄'] := 'U';
   T['█'] := 'U';

   T['·'] := 'U';
   T['∙'] := 'U';
   T['ⁿ'] := 'U';
   T['√'] := 'U';

   T['±'] := '╤';
end;



(* -------------------------------------------------------------------
   Preparation of the jumping table
------------------------------------------------------------------- *)

procedure TSearchBM.Prepare( Pattern: pchar; PatternLen: size_t;
                             IgnoreCase: Boolean );
var
   i: integer;
   c, lastc: char;
begin
   FPattern := Pattern;
   FPatternLen := PatternLen;

   if FPatternLen < 1 then
      FPatternLen := strlen(FPattern);

   { This algorythm is based in a character set of 256 }

   if FPatternLen > 256 then
      exit;


   { 1. Preparing translating table }

   CreateTranslationTable( FTranslate, IgnoreCase);


   { 2. Preparing jumping table }

   for c := #0 to #255 do
      FJumpTable[c] := FPatternLen;

   for i := FPatternLen - 1 downto 0 do begin
      c := FTranslate[FPattern[i]];
      if FJumpTable[c] >= FPatternLen - 1 then
         FJumpTable[c] := FPatternLen - 1 - i;
   end;

   FShift_1 := FPatternLen - 1;
   lastc := FTranslate[Pattern[FPatternLen - 1]];

   for i := FPatternLen - 2 downto 0 do
      if FTranslate[FPattern[i]] = lastc  then begin
         FShift_1 := FPatternLen - 1 - i;
         break;
      end;

   if FShift_1 = 0 then
      FShift_1 := 1;
end;


procedure TSearchBM.PrepareStr( const Pattern: string; IgnoreCase: Boolean );
var
   str: pchar;
begin
   if Pattern <> '' then begin
{$ifdef Windows}
      str := @Pattern[1];
{$else}
      str := pchar(Pattern);
{$endif}

      Prepare( str, Length(Pattern), IgnoreCase);
   end;
end;



{ Searching Last char & scanning right to left }

function TSearchBM.Search( Text: pchar; TextLen: size_t ): pchar;
var
   shift, m1, j: integer;
   jumps: size_t;
begin
   result := nil;
   if FPatternLen > 256 then
      exit;

   if TextLen < 1 then
      TextLen := strlen(Text);


   m1 := FPatternLen - 1;
   shift := 0;
   jumps := 0;

   { Searching the last character }

   while jumps <= TextLen do begin
      Inc( Text, shift);
      shift := FJumpTable[FTranslate[Text^]];
      while shift <> 0 do begin
          Inc( jumps, shift);
          if jumps > TextLen then
             exit;

          Inc( Text, shift);
          shift := FJumpTable[FTranslate[Text^]];
      end;

      { Compare right to left FPatternLen - 1 characters }

      if jumps >= m1 then begin
         j := 0;
         while FTranslate[FPattern[m1 - j]] = FTranslate[(Text - j)^] do begin
            Inc(j);
            if j = FPatternLen then begin
               result := Text - m1;
               exit;
            end;
         end;
      end;

      shift := FShift_1;
      Inc( jumps, shift);
   end;
end;


function TSearchBM.Pos( const S: string ): integer;
var
   str, p: pchar;
begin
   result := 0;
   if S <> '' then begin
{$ifdef Windows}
      str := @S[1];
{$else}
      str := pchar(S);
{$endif}

      p := Search( str, Length(S));
      if p <> nil then
         result := 1 + p - str;
   end;
end;

end.

Cool tip for hints on status bars

I just figured out how to have the status bars on multiple forms display hints correctly with minimal coding. There have been a couple of solutions out there, but you had to code for each form (as far as I have seen anyway).

Step 1:

Place a TStatusBar on every form you want hints on. Set the SimplePanel property to True, and give them all the same name (I use SBStatus). See the comment I put in Step 4 regarding the name.

Step 2:

Assign all the hints as you want them. Don't forget the '|' if you want long hints.

Step 3:

In your startup form put this line in the FormCreate

Application.OnHint := DisplayHint;

Create this procedure. Please take note of the comments.

procedure TFrmMain.DisplayHint(Sender: TObject);
var
  Counter, NumComps: integer;
begin
  with Screen.ActiveForm do
  begin
    NumComps := ControlCount - 1;
    for Counter := 0 to NumComps do
{SBStatus is what I call all of my status bars.  Change this as needed.}
      if (TControl(Controls[Counter]).Name = 'SBStatus') then
      begin
        if (Application.Hint = '') then
{ConWorkingName is a constant that use.  You can replace it with anything.}
          TStatusBar(Controls[Counter]).SimpleText := ConWorkingName
        else
          TStatusBar(Controls[Counter]).SimpleText := Application.Hint;
        break;
      end;
  end;
end; {DisplayHint}

That's all you have to do. If you want any other forms to have hints, simply whack a TStatusBar on them and set the hints. I hope everyone likes this.

Calling a Procedure with it's name in a variable

> Calling a Procedure with it's name in a variable
> How can I call a procedure whose name comes from a table, list, etc.?
> In other words, based on the environment I want to load a procedure name
> into a variable and call it.  What would be the instruction?

unit ProcDict;

interface

type MyProc = procedure (s : String);

procedure RegisterProc(procName : String; proc : MyProc);
procedure ExecuteProc(procName : String; arg : String);

implementation

uses Classes;
var ProcDict : TStringList;

procedure RegisterProc(procName : String; proc : MyProc);
begin
   ProcDict.AddObject(procName, TObject(@proc));
end;

procedure ExecuteProc(procName : String; arg : String);
var
   index : Integer;
begin
   index := ProcDict.IndexOf(ProcName);
   if index >= 0 then
      MyProc(ProcDict.objects[index])(arg);
// Missing error reporting
end;

initialization
   ProcDict := TStringList.Create;
   ProcDict.Sorted := true;

finalization
   ProcDict.Free;

end.