home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / WINDOWS / PROGRAM / SNDEX.ZIP / VBSNDEX.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-10-15  |  1.5 KB  |  63 lines
  1. library VBSNDEX;
  2.  
  3. uses Strings;
  4.  
  5.  
  6. {This is how to declare the LP2STR function in TPW}
  7. function LP2STR (pb:PChar;cbLen:Integer):Pointer;Far;
  8.     External 'VBPOINT' index 2;
  9.  
  10.  
  11. function Soundex (Source:Pchar): Pointer;export;
  12.  
  13. const
  14.     Work: array [0..4] of char = '0000';
  15.    SS: array [0..17] of char = 'BFPVCGJKQSXZDTLMNR';
  16.    RS: array [0..17] of char = '111122222222334556';
  17.  
  18. var
  19.     Result: pchar;
  20.    SPos, DPos, RPos: integer;
  21.    PCode: Char;
  22. begin
  23.     Result := StrNew (Work);
  24.    Result[0] := UpCase (Source[0]);
  25.    DPos := 1;
  26.    SPos := 1;
  27.    PCode := #0;
  28.    while (DPos < 4) AND (Source [SPos] <> #0) do
  29.        begin
  30.           RPos := StrScan (SS, UpCase (Source[SPos])) - SS;
  31.          if RPos > 0 then
  32.              begin
  33.                 if RS [RPos] <> PCode then
  34.                      begin
  35.                         Result[DPos] := RS [RPos];
  36.                         PCode := RS [RPos];
  37.                         Inc (DPos);
  38.                   end;
  39.             end
  40.          else
  41.             PCode := #0;
  42.              Inc (SPos);
  43.       end;
  44.  
  45.    {This is the operative bit.  Result now contains a
  46.     long pointer to a string (LPSTR).  We pass this
  47.     address and a byte count to LP2STR which creates a
  48.     Visual Basic language string (HLSTR) and returns the
  49.     handle to use here.  We assign that handle as our
  50.     function result and then destroy our copy of the
  51.     string.  Easy, right?}
  52.  
  53.    Soundex := LP2STR (Result, 4);
  54.    StrDispose (Result);
  55. end;
  56.  
  57.  
  58. exports
  59.     SOUNDEX resident;
  60.  
  61. begin
  62. end.
  63.