Calling conventions and DLLs

Problem/Question/Abstract:

How do I call a method in a DLL written in either C or C++? What do you mean by calling conventions?

Answer:

In Delphi, when we declare a procedure or function, we can specify a convention using one of the directives register, pascal, cdecl, stdcall, and safecall. All these conventions determine the order in which parameters are passed to the procedure/function.

Let me briefly explain what these conventions mean. All the calling conventions make use of stack to pass parameters back and forth except the Register convention.

Register/Pascal

These conventions pass parameters (of procedure/function) from left to right. The leftmost parameter is evaluated and passed first and the rightmost parameter is evaluated and passed last.

And the "Register" calling convention makes use of CPU registers and hence it’s faster than other conventions. When you use this convention, there will not be any stack creation at runtime if the parameters are less than or equal to three. If the parameters are more than three, then the remaining parameters will use the stack.

This "Register" convention is the default in Delphi and it’s the efficient of all because it does not create/use the stack at runtime.

The "Pascal" convention is used for backward compatibility.

The stack cleanup process will be done automatically for all the conventions when the call returns except "Cdecl".

Cdecl/stdcall/safecall

These conventions pass parameters from right to left.  The rightmost parameter is evaluated and passed first
and the leftmost parameter is evaluated and passed last. With this convention, the caller has to remove the parameters from the stack when the call returns. So it's the responsibility of the caller.

Why am I writing these simple things in detail?

Yes. This will be very helpful when you write DLL either in Delphi and access it in Delphi Or accessing a DLL written in other languages.

When you write a function/procedure in a DLL in Delphi, you will be specifying the calling convention for each. Also when you call those functions/procedures from an application through either the static loading or dynamic loading, you need to specify the type of calling convention.

When you call a DLL written in either C or C++, you have to use the "cdecl" convention. Otherwise, you
will end up in "Access violation" problems and sometimes the application may crash. Also the DLL, you are calling, should be on the search path.

I faced a problem in my project just because of this calling convention. In my application, I need to call a method in a C DLL. I copied the DLL into my machine. Then I declared all the methods in the DLL in Delphi and tried to call one of them. When I try to access a method, I got "Access violation"; sometimes the application hung and sometimes the entire application crashed. Finally I looked into the Delphi help and got the solution with the calling convention. So I declared each method in the DLL in Delphi with the "cdecl" directive. It worked fine. So don’t forget to add this directive in each method call from a DLL written in C/C++.

Detect UNIX textfiles

Problem/Question/Abstract:

How to detect if an ASCII textfile uses UNIX or Windows linebreaks?
This function will detect if a textfile is a Windows or UNIX textfile, and while we're at it, let's show two versions of the same function, one beautful and one less beautful.

Answer:

First of all, the reason is because Windows uses CRLF ($0D $0A or #13 #10) and UNIX/Linux uses just LF ($0A or #10) as linebreaks in textfiles.

The need to do it is because when using the Readln procedure it will not work on UNIX files because it cannot detect the linebreak. Instead of seeing your application go crazy it might be a nice thing to detect if it's a UNIX file or not in advance, and then provide the option to convert it if necessary.

The way to detect if it's a UNIX or Windows file is to spot the difference, i.e. to see if a CR char precedes the LF char.

Here is a go at it:

function IsFileUNIX(Filename: string): boolean;
var
  StopRead: boolean;
  F: file of Byte;
  CurB, PrevB: Byte;
begin
  StopRead := False;
  PrevB := 0;
  Result := True;

  AssignFile(F, Filename);
  FileMode := 0; // read only
  Reset(F);

  while (not Eof(F)) and (StopRead = False) do
  begin
    Read(F, CurB);

    // check if $0D precedes $0A
    if CurB = $0A then
    begin
      Result := PrevB <> $0D;
      StopRead := True;
    end;

    PrevB := CurB;
  end;
end;

Well, this function did what I wanted, however, I thought it looked kind of ugly so I began to think a little bit how I may use the same principle, but execute it with fewer statements and make the function a little bit more beautiful.

Simply replacing the while loop with a repeat loop did miracles, here's the second go at it:

function IsFileUNIX2(Filename: string): boolean;
var
  F: file of Byte;
  CurB, PrevB: Byte;
begin
  AssignFile(F, Filename);
  FileMode := 0; // read only
  Reset(F);

  repeat
    PrevB := CurB;
    Read(F, CurB);
  until (CurB = $0A) or (Eof(F));

  // check if $0D precedes $0A
  Result := PrevB <> $0D;
end;

Divide a file into 1.44 mb volumes

Problem/Question/Abstract:

How can i divide a file into 1.44 mb volumes if file size is longer than floppy capacity?

Answer:

const
  MaxSize: Longint = 1440000; //byte

function ExtractFileNames(FileNames: string): string;
var
  S: string;
begin
  S := '';
  while Pos('.', FileNames) > 0 do
  begin
    S := S + Copy(FileNames, 1, Pos('.', FileNames) - 1);
    Delete(FileNames, 1, Pos('.', FileNames));
  end;
  result := S;
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
var
  InFile, OutFile: file;
  CopyBuffer: POINTER; { buffer for copying }
  iRecsOK, iRecsWr, index: Integer;
  sFileName, sFileExt, sFileFullName: string;
  fFileSize: file of Byte;
  Size: LongInt;
begin
  sFileFullName := 'C:\1\1.mp3';
  sFileName := ExtractFileName(sFileFullName);
  sFileExt := ExtractFileExt(sFileName);
  sFileName := ExtractFileNames(sFileName);

  ShowMessage(sFileFullName + #13 + sFilename + #13 + sFileExt);

  if FileExists(sFileFullName) then
  begin
    AssignFile(fFileSize, sFileFullName);
    FileMode := 0; {Set file access to read only }
    Reset(fFileSize);
    Size := FileSize(fFileSize); {Get File Size}
    CloseFile(fFileSize);
    ShowMessage(IntToStr(Size));

    if Size > MaxSize then
    begin {Divide}
      Getmem(CopyBuffer, MaxSize); { allocate the buffer }

      Assignfile(inFile, sFileFullName); //+ '.ZIP');
      Reset(inFile, 1);

      index := 1;
      repeat
        AssignFile(outFile, sFileName + '-' + IntToStr(index) + sFileExt);
        Rewrite(OutFile, 1);
        inc(index);
        BlockRead(InFile, CopyBuffer^, MaxSize, iRecsOK);
        BlockWrite(OutFile, CopyBuffer^, iRecsOK, iRecsWr);
        CloseFile(OutFile);
      until (iRecsOK < MaxSize);
      CloseFile(InFile);
      FreeMem(CopyBuffer, MaxSize); { free the buffer }
      ShowMessage('Done..!');

    end
    else
    begin
      ShowMessage('Do nothing..!');
    end;
  end
  else
    ShowMessage('File: ' + sFileFullName + ' not found');
end;

If you can put it back, you can use DOS copy function;

copy /b file-1.xxx+file-2.xxx+file-3.xxx file.mp3

An Overview of UDP

Problem/Question/Abstract:

What is UDP? How can we use it in Delphi?

Answer:

UDP is an abbreviation for User Datagram Protocol. It&#8217;s nothing but a connectionless transport protocol that runs on TCP/IP&#8217;s IP.

The advantage of this protocol is that it is connectionless. It doesn&#8217;t need any connection before sending data packets to another computer.

The disadvantage is that it provides an unreliable datagram service. That is, the data packets may be duplicated, lost or received in a different order than the one in which they were sent. So the application must handle all those situations robustly.

The receiving program requests a number of bytes (the maximum will be the total number of bytes in the received packet). If less than the full packet is read, then the remainder is discarded. Then the next read is from the next packet. That means the boundaries of the original packet are preserved. For that the application must handle error correction while reading packets.

This UDP is best suited for small, independent requests like requesting a value of a variable etc., If the data is too large to send (i.e many packets of data) and valuable, then UDP is not the preferred protocol to use.

There is a component in Delphi 5 edition for the UDP from NetMasters called NMUDP. That component is similar to use as TclientSocket component.

The comparison of TClientSocket component with NMUDP:

As far as the properties are concerned, here in NMUDP we need to set the LocalPort(it could be any integer greater than zero; but should not be zero) to receive the data sent from the server in addition to the RemoteHost and RemotePort. But actually, the host may not be a remote one. It could be a local machine. (i.e) we can send data packets to the client machine itself and get response back for the testing purposes.

Also we can set the Report Level property to get the status during the transmission.

And as far as the methods are concerned, there is no major difference; you have the ReadStream, ReadBuffer methods as in TClientSocket component.

Regarding the events:

As the event Onclientsocketread in Tclientsocket component, here we can use the key event OnDataReceived to get the data back from the server.

Regarding the boundaries of the data packets, we need to identify the boundaries of the data packets while using either the TclientSocket or the NMUDP component (Which I didn&#8217;t discuss in my previous article &#8216;Making an application a TCP/IP client(with sample code)&#8230;&#8217;) to get the exact data sent from the server.

For that (irrespective of which component you use), we can use the concept of message header tag and end tag like HTML tags. By that we can identify the starting and ending of a data packet. Also we can send many information in a data packet with different message heading/ending tag.
(This paragraph will answer a question a person asked sometime back thro&#8217; e-mail)

In my application (Using TClientSocket...Please refer my previous articles), I&#8217;m sending a whole bunch of bytes to another computer and getting the response back using the message header/end tag only. With this approach, there is very less possibility of losing data. If we didn&#8217;t get the whole tag contents between the header/end tag, we can throw an error to the user so that the user can try resending the same data again or take some other steps robustly.

Remove extra spaces from a string

Problem/Question/Abstract:

I would like to strip all extra/ unnecessary spaces from a string. Meaning, if there are two or more space characters next to each other, I want to strip all but one. How can I do this?

Answer:

Solve 1:

{ ... }
st := 'This    is a   test';
p: pos('  ', st);
while p <> 0 do
begin
  delete(st, p, 1);
  p: pos('  ', st);
end;
{ ... }


Solve 2:

{ ... }
while pos('  ', st) > 0 do
  st := StringReplace(st, '  ', ' ', [rfReplaceAll]);
{ ... }

Enumerating Network Connections

Problem/Question/Abstract:

How to detecting current network connections?

Answer:

From the MS-DOS prompt, you can enumerate the network connections (drives) by using the following command:

   net use

Programmatically, you would call WNetOpenEnum() to start the enumeration of connected resources and WNetEnumResources() to continue the enumeration.

The following sample code enumerates the network connections:

Sample Code

procedure TForm1.Button1Click(Sender: TObject);
var
  i, dwResult: DWORD;
  hEnum: THANDLE;
  lpnrDrv,
    lpnrDrvLoc: PNETRESOURCE;
  s: string;
const
  cbBuffer: DWORD = 16384;
  cEntries: DWORD = $FFFFFFFF;
begin

  dwResult := WNetOpenEnum(RESOURCE_CONNECTED,
    RESOURCETYPE_ANY,
    0,
    nil,
    hEnum);

  if (dwResult <> NO_ERROR) then
  begin
    ShowMessage('Cannot enumerate network drives.');
    Exit;
  end;
  s := '';
  repeat
    lpnrDrv := PNETRESOURCE(GlobalAlloc(GPTR, cbBuffer));
    dwResult := WNetEnumResource(hEnum, cEntries, lpnrDrv, cbBuffer);
    if (dwResult = NO_ERROR) then
    begin
      s := 'Network drives:'#13#10;
      lpnrDrvLoc := lpnrDrv;
      for i := 0 to cEntries - 1 do
      begin
        if lpnrDrvLoc^.lpLocalName <> nil then
          s := s + lpnrDrvLoc^.lpLocalName + #9 + lpnrDrvLoc^.lpRemoteName + #13#10;
        Inc(lpnrDrvLoc);
      end;
    end
    else if dwResult <> ERROR_NO_MORE_ITEMS then
    begin
      s := s + 'Cannot complete network drive enumeration';
      GlobalFree(HGLOBAL(lpnrDrv));
      break;
    end;
    GlobalFree(HGLOBAL(lpnrDrv));
  until (dwResult = ERROR_NO_MORE_ITEMS);
  WNetCloseEnum(hEnum);
  if s = '' then
    s := 'No network connections.';
  ShowMessage(s);
end;

Improving your Object classes reliability

Problem/Question/Abstract:

One of the worst things you can do is not call a destructor for an object. I found this the hard way with my article on Compound Volumes. The destructor call ensured that any new additions to the file were properly recorded. So forgetting it caused corruption if new files were added.

Answer:

So what we want is a way to call the destructor automatically if you forget to do it. Now I could be accused of encouraging lazy programming. So what you should do is put a ShowMessage call saying something like &#8220;*Oi dipstick, you haven&#8217;t called a destructor&#8221;. That way you avoid corrupting data and your mistakes are found a bit easier.

Heres the main code to be added after the implementation section:
Note that calling TObject(Pointer).Free works for all objects. (Unless you know better...)

var
  cvList: Tlist;

const
  InTidy: boolean = false;

procedure Remove(V: TCompoundVolume);
var
  Index: integer;
begin
  if InTidy then
    exit;
  for Index := cvlist.count - 1 downto 0 do
    if cvlist[Index] = v then
      cvlist.Delete(Index);
end;

procedure Tidylist;
var
  Index: integer;
begin
  if InTidy then
    exit;
  InTidy := true;
  for Index := cvlist.count - 1 downto 0 do
    if assigned(Cvlist[Index]) then
    begin
      TObject(Cvlist[index]).Free;
      cvlist.Delete(Index);
    end;
  InTidy := false;
end;

In the class creator add this line

cvList.Add(Self);

and in the destructor add this

Remove(Self);

And in your unit, add the lines or modify the Initialization/finalization sections

initialization
  cvlist := tlist.Create;

finalization
  TidyList;
  cvlist.free;

If your destructor is called by you, the call to Remove will remove it from the list. This needs a recursion check in case you forgot to call it and it tries to call Remove while the destructor is called from TidyList. That is what the flag InTidy guards against.

*Dipstick is a mild English term of abuse, about the same as tosspot or tosser, but not as bad as say wanker.

Detecting simultaneous left and right mouse clicks

Problem/Question/Abstract:

How to known if the user has pressed simultaneously the left and right mouse buttons?

Answer:

The OnMouse event is declared as follows:

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);

If you find in the Classes unit the declaration of TShiftState is:

TShiftState = set of (ssShift, ssAlt, ssCtrl,
  ssLeft, ssRight, ssMiddle, ssDouble);

So you need to test if sLeft and ssRight are present in the Shift parameter, now your code must be like this:

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if (ssRight in Shift) and (ssLeft in Shift) then
    ShowMessage('The user has pressed Left and Right buttons');
end;

From resources to TWebBrowser

Problem/Question/Abstract:

Ever wanted to fast do your own exe containing HTML pages. This way of doing, lets you easy manage HTML files included into your EXE in a TWebBrowser.

Answer:

First of all you need to include those two units:

uses mshtml, activex;

Next, you must insert a TWebBrowser (called "WB" in this article) into your form (called frmMain in this article).

You must add 2 public procedures, called "InternalPage" and "ResourcePage", to your form. After that, the declaration should look like this:

{...}
type
  TfrmMain = class(TForm)
    wb: TWebBrowser;
    {...}
  public
    procedure InternalPage(const HTMLString: string);
    procedure ResourcePage(const Name: string);
    {...}
  end;

The implementation of that procedures is this:

procedure tfrmmain.InternalPage(const HTMLString: string);
var
  pagesource: OleVariant;
  HTMLDocument: IHTMLDocument2;
begin
  if not (Assigned(WB.Document)) then
    WB.Navigate('about:blank', EmptyParam, EmptyParam, EmptyParam, EmptyParam);
  HTMLDocument := WB.Document as IHTMLDocument2;
  pagesource := VarArrayCreate([0, 0], varVariant);
  pagesource[0] := HTMLString;
  HTMLDocument.Write(PSafeArray(TVarData(pagesource).VArray));
  HTMLDocument.Close;
end;

procedure TfrmMain.ResourcePage(const Name: string);
var
  RS: TResourceStream;
  SL: TStringList;
begin
  try
    RS := TResourceStream.create(HInstance, uppercase(trim(Name)), RT_RCDATA);
    try
      SL := TStringList.create;
      try
        SL.LoadFromStream(RS);
        InternalPage(SL.Text);
      finally
        SL.Destroy;
      end;
    finally
      RS.Destroy;
    end;
  except
    on e: exception do
      ;
  end;
end;

The next move is to manage a little the BeforeNavigate2 event of our TWebBrowser. You only need to make this:

procedure TfrmMain.wbBeforeNavigate2(Sender: TObject;
  const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
  Headers: OleVariant; var Cancel: WordBool);
var
  pagename: string;
begin
  if lowercase(trim(url)) = 'about:blank' then
    exit;
  if pos('internal://', lowercase(URL)) = 1 then
  begin
    cancel := true;
    pagename := copy(URL, (pos('://', URL) + 3), maxint);
    if length(pagename) > 0 then
      if pagename[length(pagename)] = '/' then
        delete(pagename, length(pagename), 1);
    ResourcePage(pagename);
  end;
end;

Now, add, for example tro pages as RT_RCDATA into project's resources (Project\Resources menu into Delphi IDE, then right click on the toolwindow, and select New\User Data), called for example "FIRSTHTMLPAGE" and "SECONDHTMLPAGE".

On the Create event of your form you need to load the first page:

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  ResourcePage('FIRSTHTMLPAGE');
end;

That's all.

By the way: you'll need to refer all links in your page to "internal://" + name of the resource containing the page for it to work.

Here's a way to use this source code but without having to put "internal://" for every link inside to html files:

declare a TStringList:

private
{ Private declarations }
MyPages: TStringList;

...on the oncreate event add all your pages in the form:

MyPages := TStringList.Create;
MyPages.Add('about:blankdd.htm=HTMLFILE1');
MyPages.Add('about:blankddamigos.htm=HTMLFILE2');
MyPages.Add('about:blankddamigos2.htm=HTMLFILE3');
MyPages.Add('about:blankddamigos3.htm=HTMLFILE4')

  ...all your pages, note that I added 'about:blank' before the name of each html file... I don't know why, but it doesn't work without it, so... just put it...

then the BeforeNavigate2 event would look like:

procedure TForm1.wbBeforeNavigate2(Sender: TObject;
  const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
  Headers: OleVariant; var Cancel: WordBool);
var
  pagename: string;
begin
  if lowercase(trim(url)) = 'about:blank' then
    exit;
  pagename := MyPages.Values[url];
  if (PageName <> '') then
  begin
    Cancel := True;
    ResourcePage(pagename)
  end;
end;

That's it!

Of course both approaches have their advantages and disadvantages... I find this approach useful because you leave your html alone and you only worry about your Delphi Source code, like if there's more than one link to the same page (like from pages 2, 3, 4 to page 1) you don't need to make each of those links "internal://htmlfile1", this does it automatically for you.

Invert someones desktop for fun (has usefull code)

Problem/Question/Abstract:

Bored? Like playing tricks on your coworkers? I tested it out on my bosses secretary and it was fun, so I'll share it with you. BUT its just not fun, it also contains usefull classes.

Answer:

Fun program to trick your friends, secretary or anyone with a computer :-). The program flips your desktop upside down until you click on it.
BUT, this does have some interesting code.

It contains TDesktopCanvas where you can access your desktop through a TCanvas object.
It contains TQuickPixel which gives you high speed pixel access, btw - it caches the scan lines for even faster performance.

Download the source, it is fairly easy to follow. Compile it and stick it in your friends startup folder :-) or just run it and walk away.

To end the program just click the inverted screen.

Now for the usefull part as far as coding:

A class I made so I could have fast pixel access without fumbling with scan lines.  This class caches the scan lines for faster perfomance. One drawback of this class is that it sets your Bitmap to 24bit.  If you want me to build a class that supports all bit formats then please make a comment to do so and I can build one without causing a performance hit (use method pointers so there is no testing of bit format). I will also speed up the pixel setting to work without the shifts if anyone asks for the multiple format thing. As a side note I think it would be possible to include Line, arc and circle methods... but only if there is enough interest. Windows is really slow about drawing.

Here is the code for TQuickPixel. You can also go to my website for working EXE and download full source.

unit QuickPixel;

interface
uses
  Windows, Graphics;

type
  TQuickPixel = class
  private
    FBitmap: TBitmap;
    FScanLines: array of PRGBTriple;
    function GetPixel(X, Y: Integer): TColor;
    procedure SetPixel(X, Y: Integer; const Value: TColor);
    function GetHeight: Integer;
    function GetWidth: Integer;
  public
    constructor Create(const ABitmap: TBitmap);
    property Pixel[X, Y: Integer]: TColor read GetPixel write SetPixel;
    property Width: Integer read GetWidth;
    property Height: Integer read GetHeight;
  end;

implementation

{ TQuickPixel }

constructor TQuickPixel.Create(const ABitmap: TBitmap);
var
  I: Integer;
begin
  inherited Create;
  FBitmap := ABitmap;
  FBitmap.PixelFormat := pf24bit;
  SetLength(FScanLines, FBitmap.Height);
  for I := 0 to FBitmap.Height - 1 do
    FScanLines[I] := FBitmap.ScanLine[I];
end;

function TQuickPixel.GetHeight: Integer;
begin
  Result := FBitmap.Height;
end;

function TQuickPixel.GetPixel(X, Y: Integer): TColor;
var
  P: PRGBTriple;
begin
  P := FScanLines[Y];
  Inc(P, X);
  Result := (P^.rgbtBlue shl 16) or (P^.rgbtGreen shl 8) or P^.rgbtRed;
end;

function TQuickPixel.GetWidth: Integer;
begin
  Result := FBitmap.Width;
end;

procedure TQuickPixel.SetPixel(X, Y: Integer; const Value: TColor);
var
  P: PRGBTriple;
begin
  P := FScanLines[Y];
  Inc(P, X);
  P^.rgbtBlue := (Value and $FF0000) shr 16;
  P^.rgbtGreen := (Value and $00FF00) shr 8;
  P^.rgbtRed := Value and $0000FF;
end;

end.

unit DesktopCanvas;

// original aurthor is Erwin Molendijk

interface
uses
  Graphics, Windows;

type
  TDesktopCanvas = class(TCanvas)
  private
    FDC: HDC;
    function GetWidth: Integer;
    function GetHeight: Integer;
  public
    constructor Create;
    destructor Destroy; override;
  published
    property Width: Integer read GetWidth;
    property Height: Integer read GetHeight;
  end;

implementation

{ TDesktopCanvas }

function TDesktopCanvas.GetWidth: Integer;
begin
  Result := GetDeviceCaps(Handle, HORZRES);
end;

function TDesktopCanvas.GetHeight: Integer;
begin
  Result := GetDeviceCaps(Handle, VERTRES);
end;

constructor TDesktopCanvas.Create;
begin
  inherited Create;
  FDC := GetDC(0);
  Handle := FDC;
end;

destructor TDesktopCanvas.Destroy;
begin
  Handle := 0;
  ReleaseDC(0, FDC);
  inherited Destroy;
end;

end.

Disable Keyboard and Mouse

Problem/Question/Abstract:

How to disable mouse and keyboard for n seconds

Answer:

This Function detect is Function exists in Library (dll)

function FuncAvail(VLibraryname, VFunctionname: string; var VPointer: pointer):
  boolean;
var
  Vlib: tHandle;
begin
  Result := false;
  VPointer := nil;
  if LoadLibrary(PChar(VLibraryname)) = 0 then
    exit;
  VPointer := GetModuleHandle(PChar(VLibraryname));
  if Vlib <> 0 then
  begin
    VPointer := GetProcAddress(Vlib, PChar(VFunctionname));
    if VPointer <> nil then
      Result := true;
  end;
end;

Source code in Button1 on Form1

procedure TForm1.Button1Click(Sender: TObject);
var
  xBlockInput: function(Block: BOOL): BOOL; stdcall;
begin
  if FuncAvail('USER32.DLL', 'BlockInput', @xBlockInput) then
  begin
    xBlockInput(true);
    Sleep(15000); // 15 secounds
    xBlockInput(false);
  end;
end;

Towards a more accurate sort order

Problem/Question/Abstract:

Sorting Addresses is a pain at the best of times, especially when a client supplies bad data (You may define clear fields in your DB, but when the data comes in, does it fit easily??)
This attempts to resolve this issue

Answer:

unit AddrSortOrder;

{The custom sort order is used to deal with the fact that the
house and flat numbers are sorted as strings. They are stored as
strings to allow things like '150-175' as a house number, or '3a',
or perhaps even simply a flat 'A'.
The need for a custom sort order is caused by the fact that with an
ordinary ASCII sort order '4' will appear after '30'. This is not
desirable behaviour.

This approach to fix this problem is to look for the first number
in the string (if there is one) and then use this as some kind of
primary sort order. The rest of the sorting will then be done on
the remaining characters (with preceding and trailing spaces
stripped out), based on the ASCII value of their upper-
case varients. Potential problems caused by this approach include
(but are not limited to) the use of accented characters will
possibly cause strange orderings and furthermore, if there is a block
of flats with three floors A, B, C for example then supposing the
flats on those floors are A1, A2, A3, B1, B2, B3 then the ordering
of records will not be ideal - this approach will sort them as
A1, B1, A2, B2, A3, B3. This behaviour is regrettable, but
acceptable - we cannot tell that it is not flat A on floor 1 for
example. It's unlikely that we will be able to find a sort order
that always produces ideal results.
Some examples of sorted lists (not all ideal):
EXAMPLE 1       EXAMPLE 2        EXAMPLE 3
  Flat 1          1                 A
  Flat 2          -2                B
  3               2-4               C
  3B              3a                1
  Flat 3A         5                 2
}

interface

uses SysUtils;

function CalcSortIndex(NumStr: string): double;

implementation

function CalcSortIndex(NumStr: string): double;
var
  strlength, i, j, tmp: integer;
  found: boolean;
  numpart, strpart, divisor: double;
  choppedstr: string;
begin
  //This function will return the sort index value for the string passed

  strlength := length(NumStr);
  if strlength = 0 then
  begin
    result := 0;
    exit;
  end;

  found := false;

  //split the string into a 'number' and a 'string' part..

  //initialise
  choppedstr := numstr;
  numpart := 0;

  //Locate the first digit (if there)
  for i := 1 to strlength do
  begin
    if numstr[i] in ['0'..'9'] then
    begin
      found := true; //First digit found!!
      break;
    end;
  end; //for i..

  if found then
  begin
    //now get the to the end of the digits..
    found := false;
    for j := i to strlength do
    begin
      if not (numstr[j] in ['0'..'9']) then
      begin
        found := true; //end of digits found
        break;
      end;
    end; //for j..

    //Separate out the string parts
    if found then
    begin
      //Number was embedded..
      val(copy(numstr, i, j - i), numpart, tmp);
      Delete(choppedstr, i, j - i);
    end
    else
    begin
      //Number went to the end of the string
      val(copy(numstr, i, strlength), numpart, tmp);
      Delete(choppedstr, i, strlength);
    end;
  end;

  choppedstr := Uppercase(trim(choppedstr));
  strlength := length(choppedstr);

  //evaluate a number for the remaining part of the string
  strpart := 0;
  divisor := 1;

  for i := 1 to strlength do
  begin
    divisor := divisor / 256;
    //convert from Char to single using a variant conversion
    strpart := strpart + (ord(choppedstr[i]) * divisor);
  end;

  //All done, return the value
  result := numpart + strpart;
end;

end.

NB a version of this Algorithm for MSSQL7 is also posted (Title "Towards a more accurate sort order in MSSQL7")

Drawing components' bitmaps appeared in Delphi palette

Problem/Question/Abstract:

How to draw components' bitmaps appeared in Delphi palette?

Answer:

Example below demonstrates drawing components images in combo box items. Combo box is filled with names of all components placed on form. See comments in source for description of each action.

Source:

// Add LibIntf unit into uses clause of your unit.

// Add this definition for Delphi version detection, just for better reading
{$IFDEF VER90}
{$DEFINE DELPHI2}
{$ENDIF}

{$IFDEF VER100}
{$DEFINE DELPHI3}
{$ENDIF}

{$IFDEF VER120}
{$DEFINE DELPHI3}
{$DEFINE DELPHI4}
{$ENDIF}

{$IFDEF VER130}
{$DEFINE DELPHI3}
{$DEFINE DELPHI4}
{$ENDIF}

procedure TDlgForm.cbComponentsDrawItem(Control: TWinControl;
  Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  ARect: TRect;
{$IFDEF DELPHI3}
  PIt: LibIntf.TIPaletteItem;
{$ENDIF}
{$IFDEF DELPHI4}
  PIt: LibIntf.IPaletteItem;
{$ENDIF}
  B, tmpBmp: TBitmap;
{$IFDEF DELPHI2 }
  tmpImList: TImageList;
{$ENDIF}
  SName: string;
begin
  with cbComponents.Canvas do
  begin

    Brush.Color := cbComponents.Color;
    Brush.Style := bsSolid;
    FillRect(Rect);
    tmpBmp := TBitmap.Create;
    B := TBitmap.Create;
    try
      SName := cbComponents.Items[Index];
      B.Width := 24;
      B.Height := 24;
{$IFDEF DELPHI3}
      //Under Delphi 3 or later we should use routines from LibIntf unit
      PIt :=   LibIntf.DelphiIDE.GetPaletteItem(TComponentClass(GetClass(Comp.Owner.FindComponent(SName).ClassName)));
      // Drawing component image on our bitmap canvas
      PIt.paint(B.Canvas, 0, 0);
      tmpBmp.Assign(B);
{$ENDIF}
      ARect := Bounds(0, 0, 24, 24);
{$IFDEF DELPHI2}
      // Detecting the class name of component
      SName := TComponent(Comp.Owner.FindComponent(SName)).ClassName;
      // Loading bitmap image from resources since it is linked to cmplib32.dcl
      B.LoadFromResourceName(hInstance, UpperCase(PChar(SName)));
      tmpBmp.Width := 22;
      tmpBmp.Height := 22;
      BitBlt(tmpBmp.Canvas.Handle, 0, 0, 22, 22, B.Canvas.Handle, 2, 2, SRCCOPY);
      tmpImList := TImageList.CreateSize(22, 22);
      try
        tmpImList.AddMasked(tmpBmp, tmpBmp.TransparentColor);
        tmpBmp.Canvas.Brush.Color := cbComponents.Color;
        tmpBmp.Canvas.Brush.Style := bsSolid;
        tmpBmp.Canvas.FillRect(ARect);
        tmpImList.Draw(tmpBmp.Canvas, 0, 0, 0);
      finally
        tmpImList.Free;
      end;
{$ENDIF}
{$IFDEF DELPHI3}
      tmpBmp.Canvas.Brush.Color := cbComponents.Color;
      tmpBmp.Canvas.FillRect(ARect);
      tmpBmp.Width := 24;
      tmpBmp.Height := 24;
      BitBlt(tmpBmp.Canvas.Handle, 0, 0, 24, 24, B.Canvas.Handle, 4, 4, SRCCOPY);
{$ENDIF}
      // Drawing component image on the combo box canvas
      Draw(Rect.Left + 3, Rect.Top + 2, tmpBmp);
    finally
      tmpBmp.Free;
      B.Free;
    end;
    // Drawing raised rectangle if item is selected
    if odSelected in State then
    begin
      ARect := Bounds(Rect.Left + 1, Rect.Top + 1, 23, 23);
      Frame3D(cbComponents.Canvas, ARect, clBtnHighlight, clBtnShadow, 1);
      Font.Color := clHighlightText;
      Brush.Color := clHighlight;
      ARect := Bounds(26, Rect.Top, Rect.Right - Rect.Left - 26, Rect.Bottom -
        Rect.Top);
      FillRect(ARect);
    end
    else
      Font.Color := clBlack;
    Brush.Style := bsClear;
    TextOut(Rect.Left + 27, Rect.Top + 4, cbComponents.Items[Index]);

  end;

end;

Communicating between your applications

Problem/Question/Abstract:

I want to perform communication between two my applications or between two instances of my application.

Answer:

You can perform communication between your application using Windows messages exchange mechanism. We can use HWND_BROADCAST value for first parameter for SendMessage function for suppressing finding of forms' in other applications HANDLE.
For using HWND_BROADCAST we should register our messages in Windows.

For performing this you could make the following:

(In example below we will inform about our form's top position)

1. Define type of your message structure, it could be something like this:

type
  TWMMYMessage = record
    Msg: Cardinal; // ( first is the message ID )
    Handle: HWND; // ( this is the wParam, Handle of sender)
    Info: LongInt; // ( this is lParam, pointer to our data)
    Result: LongInt;
  end;

2. Override your form's DefaultHandler method and add method for handling your message, like this

TForm1 = class(TForm)
  {... }
public
  { Public declarations }
   {... }
  procedure DefaultHandler(var Message); override;
  procedure WMMYMessage(var Msg: TWMMYMessage);
  {... }
end;

3. Declare message variable:

var
  WM_OURMESSAGE: DWORD;

4. Insert realisation of DefaultHandler and our message handler methods:

procedure TForm1.DefaultHandler(var Message);
var
  ee: TWMMYMessage;
begin
  with TMessage(Message) do
  begin
    if (Msg = WM_OURMESSAGE) then
    begin
      ee.Msg := Msg;
      ee.Handle := wParam;
      ee.Info := lParam;
      //      Checking if this message is not from us
      if ee.Handle <> Handle then
        WMMYMessage(ee);
    end
    else
      inherited DefaultHandler(Message);
  end;
end;

procedure TForm1.WMMYMessage(var Msg: TWMMYMessage);
begin
  Label1.Caption := Format('Our another form handle :%d', [Msg.Handle]);
  Label2.Caption := Format('Our another form top :%d', [Msg.Info]);
end;

5. Add registration of your message that you could handle the HWND_BROADCAST messages:

initialization
  WM_OURMESSAGE := RegisterWindowMessage('Our broadcast message');

6. Add the message sending somewhere:

procedure TForm1.Button1Click(Sender: TObject);
begin
  SendMessage(HWND_BROADCAST, WM_OURMESSAGE, Handle, Top);
end;

7. Compile and run two copies of your application and test it functionality.

Gradient fill procedure

Problem/Question/Abstract:

Gradient fill

Answer:

Paste this on your form + 1 button and 2 panels and a paintbox and link the panels onclick event and you will see it work it is fairly fast. When using this code in your application it is suggested to first draw to a tbitmap this will when the screen area neads to be redrawn speed it up considerably.

function getnewcolor(M1, M2: TColor; Location: Integer): TColor;
var
  V: array[0..2] of Byte; //BeginRGBValue
  D: array[0..2] of integer; //RGBDifference
  R, G, B: Byte;
  K1, K2: Longint;
begin
  K1 := ColorToRGB(M1);
  K2 := ColorToRGB(M2);
  V[0] := GetRValue(K1);
  V[1] := GetGValue(K1);
  V[2] := GetBValue(K1);

  D[0] := GetRValue(K2) - V[0];
  D[1] := GetGValue(K2) - V[1];
  D[2] := GetBValue(K2) - V[2];

  R := V[0] + MulDiv(Location, D[0], Form1.PaintBox1.Width - 1);
  G := V[1] + MulDiv(Location, D[1], Form1.PaintBox1.Width - 1);
  B := V[2] + MulDiv(Location, D[2], Form1.PaintBox1.Width - 1);
  Result := RGB(R, G, B);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  I: Integer;
begin
  for i := 1 to PaintBox1.Width do
  begin
    PaintBox1.Canvas.Pen.Color := GetNewColor(panel1.color, panel2.color, i);
    PaintBox1.Canvas.MoveTo(i, 1);
    PaintBox1.Canvas.LineTo(i, Panel2.Height);
  end;
end;

procedure TForm1.Panel1Click(Sender: TObject);
begin
  if ColorDialog1.Execute then
    if Sender = Panel1 then
      Panel1.Color := ColorDialog1.Color
    else
      Panel2.Color := ColorDialog1.Color;
end;

Object Pooling in COM+

Problem/Question/Abstract:

How is Object Pooling Implemented in COM+?

Answer:

What is COM?

It&#8217;s a technology that defines a standard way for a client module and server module to communicate through a set of interfaces. The module could be an application or a DLL. Also the client and server can be in the same box or in different boxes

What is COM+?

It&#8217;s just an extended version of COM coming with Windows 2000. Microsoft has redefined and added some concepts/features with COM+.

What is Object Pooling and Why do we need Object Pooling?

To better illustrate the need for Object Pooling, let us consider a sample web application using COM objects. The basic functions of such an application using a COM object would be the following:

Creates a COM object
Uses the COM object by calling various methods/properties.
Destroys the COM object

Let us assume that we have an ASP page in that web application and got some 30,000 requests for a day/at peak times. Let us suppose that the ASP page creates three COM objects in that page. So as per the calculation, there would be 90,000 objects created and destroyed. No need to say, it will definitely consume a lot of resources and an overhead. What could be done to avoid this? Recycle. Yes. We can recycle the objects used at one transaction in the next transaction.

Here comes the Object Pool. It&#8217;s a place where the application return the COM objects after using it instead of destroying it. So every time the application needs a COM object, it needs to perform the following steps:

Checks the object pool if one exists. If exists, then use it or creates a new COM object.
Use the COM object by calling its methods/properties.
Return it to the same object pool after using it.

This looks like a good concept in reducing/conserving the usage of resources in a web application. But the next question comes to our mind is that can we implement all of those in an web application? We can; but we need to think of the following things in mind.

Who is responsible for managing the Object Pool?
When that Object Pool will be created/destroyed?
When will the objects be created/destroyed in that pool?
When those objects will be destroyed in that pool?
How will the web application know to use the objects in the pool? Does the application need to     write a separate code to call an object in the object pool?
How can we manage multiple clients accessing an object in the object pool?

But implementing these in every web application is really a difficult task and it&#8217;s an overhead on the programmer&#8217;s side; Also it&#8217;s error prone.

Here comes the COM+

COM+ helps us in doing all those processes without changing a single line of code in our COM object. That&#8217;s the beauty of COM+. A COM+ application is typically an MTS application in the earlier Windows versions(NT,95); but in Windows 2000, the name has been changed to COM+. That&#8217;s it.

COM+ provides us with a lot of services. One of its services is this Object Pooling. All we have to do is to set the component properties in Component Services Editor to use Object Pooling. The rest will be taken care of by the COM+ runtime.

But in COM+ 1.0, there are some restrictions on using its services by COM objects developed by various languages. This is because of the incompatibility between the COM+ and the languages.

As of now, COM objects developed using Visual Basic cannot use this Object Pooling service provided by the COM+. Is that right? Any ideas? What about COM objects developed using Delphi? Is Delphi 5.0/6.0 COM+ compatible? Can Delphi 5.0/6.0 use all of the services provided by COM+? Because, I didn&#8217;t get a chance to try these out. Discussions are welcome!!!

When COM Objects are destroyed?

As every COM programmer knows, COM implements some basic methods.

QueryInterface
AddRef
Release

Out of these methods, Release is responsible for destroying the object. After the COM Object is created, every time a method of the COM Object is called, it&#8217;ll call AddRef method to increase the reference count for that component. And after the method call has been over, the reference count will be reduced by one and once it reaches zero, the COM object will be destroyed.

Reference count is a number that indicates the number of active clients using the COM object.

How Object Pooling is implemented in COM+

This is implemented by intercepting the calls to the Release method of IUnknown. As you know already, every COM object maintains a reference count and once it reaches zero, then that COM object is destroyed. But this is not good if we would like to reuse/recycle the object. In turn, it's not good to implement the Object Pooling service. So the following are implemented by COM+:

COM+ maintains an additional reference count for COM objects to be pooled when the object is created.
COM+ intercepts the calls to Release method for pooled COM objects.

The above two things are implemented by a technique called Interception. The interception is implemented by a light-weight proxy. It's also called an Interceptor. It contains a small amount of code that acts between the client and the real object. This code is invoked for components which are marked as pooled components. So by this technique, inteception, COM+ runtime implements the Object Pooling.

All these are happening behind the scenes by COM+ runtime. All we have to do to make use of this Object Pooling service is to make sure that we set the right 2option in the Component Services Editor. Component Services is available in Win 2000.

This article is just a beginning to COM+ and I would like to explore more on this COM+ later. If you have any views,comments or have any experience with that, please feel free to share.

Write Components which handle ENTER-Key like TAB-Key

Problem/Question/Abstract:

Standard-behaviour of controls when pressing ENTER-KEY is a BEEP-Sound. But how to write Components which handle ENTER-Key like TAB-Key?

Answer:

This Article will show how to write Components which will handle the ENTER-Key in the same behaviour like the TAB-Key. As Sample I will take a TEdit-Component but it should work on oll other components with OnKeyPress-Event.

Create a new Component from TEdit with a new property:

EnterNextCtrl: Boolean

If this is TRUE (standard), the Focus will jump to next Control if the user press ENTER. If it is FALSE it will show standard-behaviour (beep). This functionality is included in OnKeyPress-Event. There the component sends the Message "WM_NextDLGCTL" to the parent Form. It's important to get the ParentForm, because the TMyEdit need not included on TForm directly but maybe on a TPanel. So you have to send the message directly to the parent-FORM (and not to PARENT, which may be a TPanel).

It should be possible to use this way for other components which have a OnKeyPress-Event.

type
  TMyEdit = class(TEdit)
  private
    FEnterNextCtrl: Boolean;
  protected
    procedure KeyPress(var Key: Char); override;
  published
    property EnterNextCtrl: Boolean read FEnterNextCtrl write FEnterNextCtrl;
    constructor Create(AOwner: TComponent); override;
  end;

constructor TMyEdit.Create(AOwner: TComponent);
begin
  inherited;
  FEnterNextCtrl := TRUE;
end;

procedure TMyEdit.KeyPress(var Key: Char);
var
  ParentForm: TCustomForm;
begin
  inherited;
  if key = #13 then
  begin
    Key := #0;

    //Get the parent-Form.
    ParentForm := GetParentForm(self);

    if FEnterNextCtrl = TRUE {//Jump to next Control or beep } then
      parentform.Perform(WM_NextDLGCTL, 0, 0)
    else
      messageBeep(0);
  end;
end;

Designer instance for DataModules

Problem/Question/Abstract:

I can retreive instance of Designer for forms as their property "Designer", but how to retreive it for DataModule like objects?

Answer:

For receiving instance of Designer for forms you should just get form's property "Designer". But how to receive the Designer instance if you have only DataModule's instance?

It is very simply: the DataModule is an usual VCL component and its owner is hidden form, so for retreiving Designer instance of DataModule just retreive "Designer" property of DataModule's owner.
The function below demonstrates retreiving Designer instance for any form in your project by its name. This function is useful when Designer instance is necessary for your experts.

Add these definitions:

{$IFDEF VER120}
TFormDesigner = IFormDesigner;
{$ENDIF}
{$IFDEF VER125}
TFormDesigner = IFormDesigner;
{$ENDIF}
{$IFDEF VER130}
TFormDesigner = IFormDesigner;
{$ENDIF}

function GetDesigner(FToolServices: TIToolServices; FormName: string): TFormDesigner;
var
  tmpC: TComponent;
begin
  Result := nil;
  with FToolServices.GetFormModuleInterface(FormName).GetFormInterface.GetFormComponent
    do
  begin
    tmpC := GetComponentHandle;
    if (tmpC is TCustomForm) then
    begin
      // We have the usual form
      Result := TFormDesigner(TCustomForm(tmpC).Designer);
      Exit;
    end
    else
      // We have the DataModule or WebModule or something else
      Result := TFormDesigner(TCustomForm(tmpc.Owner).Designer);
  end;
end;

For receiving Designer without using ToolServices you can use following function:

finction GetDesigner(AComp: TComponent): TFormDesigner;
var
  tmpC: TComponent;
begin
  Result = nil;
  if not Assigned(AComp) then
    Exit;
  if AComp is TCustomForm then
    Result := TFormDesigner(TCustomForm(AComp).Designer)
  else
  begin
    tmpC := AComp;
    while true do
    begin
      if Assigned(tmpC.Owner) then
        tmpC := tmpC.Owner
      else
        break;
      if tmpC is TCustomForm then
      begin
        Result := TFormDesigner(TCustomForm(AComp).Designer);
        break;
      end;
    end;
  end;
end;

Retrieve data from a URL

Problem/Question/Abstract:

How do I fetch text from a URL?

Answer:

This is a follow up to article "Checking if a URL is valid" which returns the data at the web page in a string. If it fails you should get a Status:xxx where xxx is the status or nothing at all if there isn't a web server at the url you try.

It uses the InternetReadfile function to read the data in 4kb chunks. The actual size of the buffer is irrelevant unless (as in this case) it is declared local to the function. This takes up stack space and a large buffer could potentially lead to a stack overflow if there were many functions nested in the call stack. Either move it somewhere non stack based or keep it small.

One thing to watch is the string conversion. If you are using buffer data, make sure you add a #0 on the end and use pchars to convert before ending up with strings.

uses wininet...

function FetchHTML(url: string): string;
var
  databuffer: array[0..4095] of char;
  ResStr: string;
  hSession, hfile, hRequest: hInternet;
  dwindex, dwcodelen, datalen, dwread, dwNumber: cardinal;
  dwcode: array[1..20] of char;
  res: pchar;
  Str: pchar;

begin
  ResStr := '';
  if pos('http://', lowercase(url)) = 0 then
    url := 'http://' + url;
  hSession := InternetOpen('InetURL:/1.0',
    INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if assigned(hsession) then
  begin
    hfile := InternetOpenUrl(
      hsession,
      pchar(url),
      nil,
      0,
      INTERNET_FLAG_RELOAD,
      0);
    dwIndex := 0;
    dwCodeLen := 10;
    HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE,
      @dwcode, dwcodeLen, dwIndex);
    res := pchar(@dwcode);
    dwNumber := sizeof(databuffer) - 1;
    if (res = '200') or (res = '302') then
    begin
      while (InternetReadfile(hfile, @databuffer, dwNumber, DwRead)) do
      begin
        if dwRead = 0 then
          break;
        databuffer[dwread] := #0;
        Str := pchar(@databuffer);
        resStr := resStr + Str;
      end;
    end
    else
      ResStr := 'Status:' + res;
    if assigned(hfile) then
      InternetCloseHandle(hfile);
  end;
  InternetCloseHandle(hsession);
  Result := resStr;
end;

This code was written with the help of 'Essential WinInet' by Aaron Skonnard and if you are interested in this subject I strongly suggest you buy the book. ISBN 0-201-37936-8. The code in the book is in C/C++ but isn't too difficult to convert to delphi.

Delphi .NET: "Hello, world!"

Problem/Question/Abstract:

How to make a simple application using Delphi .NET compiler

Answer:

WinForms is a programming model used to create Windows Applications. .NET framework offers base classes for building Windows applications. Most of the functionality for these classes is in the System.Windows.Forms.
Lets look at the simplest traditional &#8220;hello world&#8221; example which will help us create our first Windows application in Delphi .NET
The form class is derived form the System.Windows.Forms.Form class. In the constructor of this class private procedure called InitializeComponents is called. If we want to add a new controls to the form we can do it in this procedure.

program newform;

uses
  System.Drawing,
  System.Collections,
  System.ComponentModel,
  System.Windows.Forms,
  System.Data;

type
  TMyform = class(Form)
  private
    components: IContainer;
    procedure InitializeComponent;
  public
    constructor Create;
    destructor Destroy; override;
  end;

constructor TMyform.Create;
begin
  inherited Create;
  InitializeComponent;
end;

destructor TMyform.Destroy;
begin
  inherited;
end;

procedure TMyform.InitializeComponent;
begin
  Self.components := System.ComponentModel.Container.Create as IContainer;
  Self.AutoScaleBaseSize := System.Drawing.Size.Create(5, 13);
  Self.ClientSize := System.Drawing.Size.Create(160, 85);
  Self.Name := 'Myform';
  Self.Text := 'Hello World'; //change the form title
end;

var
  MyForm: TMyForm;

begin
  MyForm := TMyForm.Create;
  Application.Run(MyForm);
end.

Utility to Generate the Stored procedures and views of a SQL Database

Problem/Question/Abstract:

How can I create Stored Procedures and Views with out Knowing the Scripts ?

Answer:

For the persons who does not have the knowledge of Databases creating the stored procedures and views in the SQL Database was always a problem.
This utility will allow you to create the Stored procedures for Insert, Update and delete of a table and also will create the views. You have to just connect to the Database. All the Tables in the Database will be listed . Click on the table for which you need to create the stored procedures. The Script will be generated depending on the default templete. You can modify the templetes. Check or uncheck the fields you want to include in the Stored procedure. By default the need fields based upon the key fields will be included. Then just click, to create the stored procedures. For views you can include the fields in the views or cange the display names of the fields.
Copy the following codes to their respective files. Compile it and enjoy the ease of creating stored procedures.

GenerateSp.dpr file

program GenerateSp;

uses
  Forms,
  Main in 'Main.pas' {fmMain};

{$R *.res}

begin
  Application.Initialize;
  Application.CreateForm(TfmMain, fmMain);
  Application.Run;
end.

Main.dfm file

object fmMain: TfmMain
  Left = 37
    Top = 103
    Width = 1225
    Height = 759
    ActiveControl = edtsrv
    Caption = 'fmMain'
    Color = clBtnFace
    Constraints.MinHeight = 759
    Constraints.MinWidth = 1225
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -13
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    OldCreateOrder = False
    Position = poScreenCenter
    OnClose = FormClose
    OnCreate = FormCreate
    OnDestroy = FormDestroy
    OnShow = FormShow
    PixelsPerInch = 120
    TextHeight = 16
    object Label1: TLabel
    Left = 44
      Top = 12
      Width = 46
      Height = 16
      Caption = 'Server :'
  end
  object Label2: TLabel
    Left = 24
      Top = 38
      Width = 66
      Height = 16
      Caption = 'Database :'
  end
  object Label3: TLabel
    Left = 15
      Top = 64
      Width = 75
      Height = 16
      Caption = 'User Name :'
  end
  object Label4: TLabel
    Left = 24
      Top = 91
      Width = 66
      Height = 16
      Caption = 'Password :'
  end
  object lblConn: TLabel
    Left = 98
      Top = 140
      Width = 3
      Height = 16
  end
  object Label5: TLabel
    Left = 3
      Top = 138
      Width = 89
      Height = 16
      Caption = 'Table Names :'
      Font.Charset = DEFAULT_CHARSET
      Font.Color = clWindowText
      Font.Height = -13
      Font.Name = 'MS Sans Serif'
      Font.Style = [fsUnderline]
      ParentFont = False
  end
  object edtsrv: TEdit
    Left = 96
      Top = 8
      Width = 137
      Height = 24
      TabOrder = 0
  end
  object edtdb: TEdit
    Left = 96
      Top = 34
      Width = 137
      Height = 24
      TabOrder = 1
  end
  object edtUn: TEdit
    Left = 96
      Top = 60
      Width = 137
      Height = 24
      TabOrder = 2
  end
  object edtPw: TEdit
    Left = 96
      Top = 87
      Width = 137
      Height = 24
      PasswordChar = '@'
      TabOrder = 3
  end
  object btnConnect: TButton
    Left = 96
      Top = 112
      Width = 75
      Height = 25
      Caption = 'Connect'
      TabOrder = 4
      OnClick = btnConnectClick
  end
  object pcMain: TPageControl
    Left = 240
      Top = 0
      Width = 977
      Height = 726
      ActivePage = tsFields
      Align = alRight
      TabIndex = 0
      TabOrder = 5
      object tsFields: TTabSheet
      Caption = 'Select Fields'
        object Bevel1: TBevel
        Left = 0
          Top = 221
          Width = 976
          Height = 9
          Shape = bsTopLine
      end
      object Bevel3: TBevel
        Left = -19
          Top = 440
          Width = 994
          Height = 9
          Shape = bsTopLine
      end
      object Bevel4: TBevel
        Left = -11
          Top = 656
          Width = 992
          Height = 9
          Shape = bsTopLine
      end
      object Label6: TLabel
        Left = 8
          Top = 0
          Width = 92
          Height = 16
          Caption = 'Fields To Insert'
          Font.Charset = DEFAULT_CHARSET
          Font.Color = clWindowText
          Font.Height = -13
          Font.Name = 'MS Sans Serif'
          Font.Style = [fsUnderline]
          ParentFont = False
      end
      object Label7: TLabel
        Left = 3
          Top = 226
          Width = 129
          Height = 16
          Caption = 'Key Fields for Update'
          Font.Charset = DEFAULT_CHARSET
          Font.Color = clWindowText
          Font.Height = -13
          Font.Name = 'MS Sans Serif'
          Font.Style = [fsUnderline]
          ParentFont = False
      end
      object Label8: TLabel
        Left = 3
          Top = 444
          Width = 134
          Height = 16
          Caption = 'Key Fields for Deletion'
          Font.Charset = DEFAULT_CHARSET
          Font.Color = clWindowText
          Font.Height = -13
          Font.Name = 'MS Sans Serif'
          Font.Style = [fsUnderline]
          ParentFont = False
      end
      object lblStatus: TLabel
        Left = 280
          Top = 664
          Width = 3
          Height = 16
          Font.Charset = DEFAULT_CHARSET
          Font.Color = clBlue
          Font.Height = -13
          Font.Name = 'MS Sans Serif'
          Font.Style = []
          ParentFont = False
      end
      object clbInsert: TCheckListBox
        Left = 1
          Top = 18
          Width = 185
          Height = 198
          ItemHeight = 16
          TabOrder = 0
      end
      object clbUpdate: TCheckListBox
        Left = 1
          Top = 244
          Width = 185
          Height = 193
          ItemHeight = 16
          TabOrder = 1
      end
      object clbDelete: TCheckListBox
        Left = 1
          Top = 461
          Width = 185
          Height = 193
          ItemHeight = 16
          TabOrder = 2
      end
      object btnOk: TBitBtn
        Left = 809
          Top = 664
          Width = 75
          Height = 25
          Caption = 'Ok'
          TabOrder = 3
          OnClick = btnOkClick
      end
      object btnClose: TBitBtn
        Left = 889
          Top = 664
          Width = 75
          Height = 25
          Caption = 'Close'
          TabOrder = 4
          OnClick = btnCloseClick
      end
      object memScrInsert: TMemo
        Left = 194
          Top = 18
          Width = 769
          Height = 201
          ScrollBars = ssBoth
          TabOrder = 5
      end
      object memscrUpdate: TMemo
        Left = 194
          Top = 244
          Width = 769
          Height = 193
          ScrollBars = ssBoth
          TabOrder = 6
      end
      object memScrDelete: TMemo
        Left = 194
          Top = 461
          Width = 769
          Height = 193
          ScrollBars = ssBoth
          TabOrder = 7
      end
      object chbInsert: TCheckBox
        Left = 0
          Top = 668
          Width = 81
          Height = 17
          Caption = 'Sp Insert'
          Checked = True
          State = cbChecked
          TabOrder = 8
      end
      object chbUpdate: TCheckBox
        Left = 80
          Top = 668
          Width = 88
          Height = 17
          Caption = 'Sp UpDate'
          Checked = True
          State = cbChecked
          TabOrder = 9
      end
      object chbDelete: TCheckBox
        Left = 179
          Top = 668
          Width = 81
          Height = 17
          Caption = 'Sp Delete'
          Checked = True
          State = cbChecked
          TabOrder = 10
      end
    end
    object tsTemplate: TTabSheet
      Caption = 'Templates'
        ImageIndex = 1
        object Bevel2: TBevel
        Left = -6
          Top = 218
          Width = 984
          Height = 9
          Shape = bsTopLine
      end
      object Bevel5: TBevel
        Left = -24
          Top = 440
          Width = 1002
          Height = 9
          Shape = bsTopLine
      end
      object Bevel6: TBevel
        Left = -22
          Top = 665
          Width = 1000
          Height = 9
          Shape = bsTopLine
      end
      object Label9: TLabel
        Left = 16
          Top = -2
          Width = 32
          Height = 16
          Caption = 'Insert'
      end
      object Label10: TLabel
        Left = 16
          Top = 221
          Width = 45
          Height = 16
          Caption = 'Update'
      end
      object Label11: TLabel
        Left = 16
          Top = 444
          Width = 43
          Height = 16
          Caption = 'Delete '
      end
      object btnok1: TBitBtn
        Left = 809
          Top = 669
          Width = 75
          Height = 25
          Caption = 'Ok'
          TabOrder = 0
          OnClick = btnok1Click
      end
      object btnCancel: TBitBtn
        Left = 889
          Top = 669
          Width = 75
          Height = 25
          Caption = 'Cancel'
          TabOrder = 1
      end
      object memInsert: TMemo
        Left = 16
          Top = 13
          Width = 946
          Height = 201
          ScrollBars = ssBoth
          TabOrder = 2
      end
      object memUpdate: TMemo
        Left = 16
          Top = 237
          Width = 946
          Height = 201
          ScrollBars = ssBoth
          TabOrder = 3
      end
      object memDelete: TMemo
        Left = 16
          Top = 461
          Width = 946
          Height = 201
          ScrollBars = ssBoth
          TabOrder = 4
      end
    end
    object tbPrefix: TTabSheet
      Caption = 'Prefixes'
        ImageIndex = 2
        object Label12: TLabel
        Left = 24
          Top = 32
          Width = 38
          Height = 16
          Caption = 'Insert :'
      end
      object Label13: TLabel
        Left = 16
          Top = 112
          Width = 46
          Height = 16
          Caption = 'Delete :'
      end
      object Label14: TLabel
        Left = 11
          Top = 72
          Width = 51
          Height = 16
          Caption = 'Update :'
      end
      object Label15: TLabel
        Left = 27
          Top = 148
          Width = 35
          Height = 16
          Caption = 'View :'
      end
      object edtInsert: TEdit
        Left = 66
          Top = 28
          Width = 121
          Height = 24
          TabOrder = 0
      end
      object edtUpdate: TEdit
        Left = 66
          Top = 68
          Width = 121
          Height = 24
          TabOrder = 1
      end
      object edtDelete: TEdit
        Left = 66
          Top = 108
          Width = 121
          Height = 24
          TabOrder = 2
      end
      object btnOk2: TBitBtn
        Left = 67
          Top = 183
          Width = 75
          Height = 23
          Caption = 'Ok'
          TabOrder = 3
          OnClick = btnOk2Click
      end
      object edtView: TEdit
        Left = 66
          Top = 144
          Width = 121
          Height = 24
          TabOrder = 4
      end
    end
    object tbViews: TTabSheet
      Caption = 'Views'
        ImageIndex = 3
        object Label16: TLabel
        Left = 4
          Top = 5
          Width = 151
          Height = 16
          Caption = 'Fields To  Include in View'
          Font.Charset = DEFAULT_CHARSET
          Font.Color = clWindowText
          Font.Height = -13
          Font.Name = 'MS Sans Serif'
          Font.Style = [fsUnderline]
          ParentFont = False
      end
      object Label17: TLabel
        Left = 233
          Top = 5
          Width = 86
          Height = 16
          Caption = 'Display Name'
          Font.Charset = DEFAULT_CHARSET
          Font.Color = clWindowText
          Font.Height = -13
          Font.Name = 'MS Sans Serif'
          Font.Style = [fsUnderline]
          ParentFont = False
      end
      object lblStatusView: TLabel
        Left = 604
          Top = 340
          Width = 36
          Height = 16
          Caption = 'wwww'
          Font.Charset = DEFAULT_CHARSET
          Font.Color = clBlue
          Font.Height = -13
          Font.Name = 'MS Sans Serif'
          Font.Style = []
          ParentFont = False
      end
      object sgView: TStringGrid
        Left = 232
          Top = 24
          Width = 249
          Height = 665
          ColCount = 2
          DefaultRowHeight = 19
          FixedCols = 0
          RowCount = 1
          FixedRows = 0
          Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine,
            goRangeSelect, goEditing]
          TabOrder = 0
          OnSetEditText = sgViewSetEditText
          ColWidths = (
          243
          64)
          RowHeights = (
          20)
      end
      object memView: TMemo
        Left = 483
          Top = 24
          Width = 481
          Height = 305
          TabOrder = 1
      end
      object clbView: TCheckListBox
        Left = 1
          Top = 24
          Width = 230
          Height = 665
          OnClickCheck = clbViewClickCheck
          Columns = 1
          Font.Charset = DEFAULT_CHARSET
          Font.Color = clWindowText
          Font.Height = -17
          Font.Name = 'MS Sans Serif'
          Font.Style = []
          ItemHeight = 20
          ParentFont = False
          TabOrder = 2
      end
      object btnView: TButton
        Left = 488
          Top = 336
          Width = 97
          Height = 25
          Caption = 'Create View'
          TabOrder = 3
          OnClick = btnViewClick
      end
    end
  end
  object lbTables: TListBox
    Left = 0
      Top = 160
      Width = 233
      Height = 559
      ItemHeight = 16
      TabOrder = 6
      OnMouseUp = lbTablesMouseUp
  end
  object adoConn: TADOConnection
    ConnectionString =
      'Provider=SQLOLEDB.1;Password=Robotech!;Persist Security Info=Tru' +
      'e;User ID=sa;Initial Catalog=Dependency;Data Source=devrequest'
      Provider = 'SQLOLEDB.1'
      Left = 504
      Top = 72
  end
  object adoQry: TADOQuery
    Connection = adoConn
      Parameters = <>
      Left = 472
      Top = 72
  end
end

Main.pas file

unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, DB, ADODB, Menus, Buttons, ExtCtrls, CheckLst,
  ComCtrls, IniFiles, StrUtils, QDialogs, Grids;

type
  TfmMain = class(TForm)
    adoConn: TADOConnection;
    adoQry: TADOQuery;
    Label1: TLabel;
    edtsrv: TEdit;
    Label2: TLabel;
    edtdb: TEdit;
    Label3: TLabel;
    Label4: TLabel;
    edtUn: TEdit;
    edtPw: TEdit;
    btnConnect: TButton;
    lblConn: TLabel;
    Label5: TLabel;
    pcMain: TPageControl;
    tsFields: TTabSheet;
    tsTemplate: TTabSheet;
    clbInsert: TCheckListBox;
    clbUpdate: TCheckListBox;
    clbDelete: TCheckListBox;
    Bevel1: TBevel;
    Bevel3: TBevel;
    Bevel4: TBevel;
    btnOk: TBitBtn;
    btnClose: TBitBtn;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    lbTables: TListBox;
    Bevel2: TBevel;
    Bevel5: TBevel;
    Bevel6: TBevel;
    btnok1: TBitBtn;
    btnCancel: TBitBtn;
    memInsert: TMemo;
    memUpdate: TMemo;
    memDelete: TMemo;
    Label9: TLabel;
    Label10: TLabel;
    Label11: TLabel;
    memScrInsert: TMemo;
    memscrUpdate: TMemo;
    memScrDelete: TMemo;
    tbPrefix: TTabSheet;
    Label12: TLabel;
    Label13: TLabel;
    Label14: TLabel;
    edtInsert: TEdit;
    edtUpdate: TEdit;
    edtDelete: TEdit;
    btnOk2: TBitBtn;
    lblStatus: TLabel;
    chbInsert: TCheckBox;
    chbUpdate: TCheckBox;
    chbDelete: TCheckBox;
    Label15: TLabel;
    edtView: TEdit;
    tbViews: TTabSheet;
    sgView: TStringGrid;
    memView: TMemo;
    clbView: TCheckListBox;
    Label16: TLabel;
    Label17: TLabel;
    btnView: TButton;
    lblStatusView: TLabel;
    procedure btnConnectClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure lbTablesMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure btnCloseClick(Sender: TObject);
    procedure btnOkClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnOk2Click(Sender: TObject);
    procedure btnok1Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure clbViewClickCheck(Sender: TObject);
    procedure sgViewSetEditText(Sender: TObject; ACol, ARow: Integer;
      const Value: string);
    procedure btnViewClick(Sender: TObject);
  private
    { Private declarations }
    Fini: TIniFile;
    FTblDisplayName, FSelectedTable: string;
    procedure GetTables;
    procedure GetColumns;
    procedure ScriptInsert;
    procedure ScriptUpdate;
    procedure ScriptDelete;
    procedure ScriptView;
    procedure UpDateDatabase;
    procedure GenScriptView;
  public
    { Public declarations }
  end;

const
  LengthFields = '173,175,106,62,239,108,231,165,167';

var
  fmMain: TfmMain;

implementation

{$R *.dfm}

procedure TfmMain.btnConnectClick(Sender: TObject);
var
  S: string;
begin
  S := 'Provider=SQLOLEDB.1;Password=' + edtPw.Text + ';User ID=' + edtUn.Text +
    ';Initial Catalog=' + edtdb.Text + ';Data Source=' + edtsrv.Text;
  adoConn.Close;
  adoConn.ConnectionString := S;
  lblConn.Font.Color := clGreen;
  try
    adoConn.Open;
    lblConn.Caption := 'Connection Succeded';
  except
    lblConn.Font.Color := clRed;
    lblConn.Caption := 'Connection Failed';
  end;
  GetTables;
end;

procedure TfmMain.GetTables;
begin
  adoQry.SQL.Clear;
  adoQry.SQL.Text := 'Select name from sysobjects where xtype = ' +
    #39 + 'U' + #39 + ' order by name ';
  try
    adoQry.Open;
    lbTables.Clear;
    while (not adoQry.Eof) do
    begin
      if (adoQry.fieldbyname('name').AsString <> 'dtproperties') then
      begin
        lbTables.Items.Add(adoQry.fieldbyname('name').AsString);
      end;
      adoQry.Next;
    end;
    adoQry.Close;
  except
  end;
end;

procedure TfmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  adoQry.Close;
  adoConn.Close;
end;

procedure TfmMain.lbTablesMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  tp: TPoint;
begin
  tp.X := X;
  tp.Y := y;
  FSelectedTable := lbTables.Items[lbTables.ItemAtPos(tp, true)];
  FTblDisplayName := AnsiReplaceStr(FSelectedTable, 'tb_', '');
  GetColumns;
  ScriptInsert;
  ScriptUpdate;
  ScriptDelete;
  ScriptView;
  lblStatus.Caption := '';
  lblStatusView.Caption := '';
end;

procedure TfmMain.btnCloseClick(Sender: TObject);
begin
  Close;
end;

procedure TfmMain.GetColumns;
var
  vIdCol: string;
  procedure FillClb(var clb: TCheckListBox);
  var
    I: word;
  begin
    adoQry.First;
    clb.Clear;
    while (not adoQry.Eof) do
    begin
      clb.Items.Add(adoQry.fieldbyname('name').AsString);
      if (clb.Name = 'clbInsert') then
      begin
        clb.Checked[clb.Items.Count - 1] := True;
      end
      else
      begin
      end;
      adoQry.Next;
    end;
    if (clb.Name <> 'clbInsert') then
    begin
      for I := 0 to (clb.Items.Count - 1) do
      begin
        if (pos(clb.Items[I], vIdCol) > 0) then
        begin
          clb.Checked[I] := True;
        end;
      end;
    end;
  end;
begin
  vIdCol := '';
  adoQry.Close;
  adoQry.SQL.Clear;
  adoQry.SQL.Text := 'select A.NAME from SYSCOLUMNS A, sysINDEXKEYS B where A.id = ' +
    '( select id from sysobjects where name = ' + #39 + FSelectedTable + #39 + ' )' +
    ' and (a.Id = b.Id ) and ( a.ColId = b.ColId ) order by a.colid';
  try
    adoQry.Open;
    while (not adoQry.Eof) do
    begin
      vIdCol := vIdCol + adoQry.fieldbyname('name').AsString + '#';
      adoQry.Next;
    end;
  except
  end;

  adoQry.Close;
  adoQry.SQL.Clear;
  adoQry.SQL.Text := 'select name from syscolumns where id = ' +
    '( select id from sysobjects where name = ' +
    #39 + FSelectedTable + #39 + ' )  order by colid';
  try
    adoQry.Open;
    FillClb(clbInsert);
    FillClb(clbUpdate);
    FillClb(clbDelete);
    adoQry.Close;
  except
  end;
end;

procedure TfmMain.ScriptInsert;
var
  vFields: string;
  vParamsType: string;
  vParams: string;
  vReplace: string;
  I: Integer;
  vSpName: string;
begin
  adoQry.Close;
  adoQry.SQL.Text := 'Select a.name, b.name dt, a.xtype, a.length FROM SYSCOLUMNS a,'
    +
    'systypes b where a.id = ( select id from sysobjects where name = ' +
    #39 + FSelectedTable + #39 + ' ) and ( b.xtype = a.xtype )';
  try
    adoQry.Open;
  except
  end;
  vFields := '';
  vParams := '';
  vParamsType := '';
  for I := 0 to (clbInsert.Items.Count - 1) do
  begin
    if (clbInsert.Checked[I]) then
    begin
      if (vFields <> '') then
        vFields := vFields + ', ';
      vFields := vFields + clbInsert.Items[I];
      if (vParamsType <> '') then
        vParamsType := vParamsType + ', ';
      vParamsType := vParamsType + '@' + clbInsert.Items[I] + ' ';
      if (vParams <> '') then
        vParams := vParams + ', ';
      vParams := vParams + '@' + clbInsert.Items[I] + ' ';
      if adoQry.Locate('name', clbInsert.Items[I], [locaseinsensitive]) then
      begin
        vParamsType := vParamsType + adoQry.fieldbyname('dt').AsString + ' ';
        if (pos(adoQry.fieldbyname('xtype').AsString, LengthFields) > 0) then
        begin
          vParamsType := vParamsType + '( ' + adoQry.fieldbyname('length').AsString +
            ' )';
        end
        else
        begin
        end;
      end;
    end;
  end;
  vSpName := Fini.ReadString('Insert', 'Prefix', '');
  vReplace := memInsert.Lines.Text;
  vReplace := AnsiReplaceStr(vReplace, '', FSelectedTable);
  vReplace := AnsiReplaceStr(vReplace, '', vSpName + FTblDisplayName);
  vReplace := AnsiReplaceStr(vReplace, '', FTblDisplayName);
  vReplace := AnsiReplaceStr(vReplace, '', vFields);
  vReplace := AnsiReplaceStr(vReplace, '', vParamsType);
  vReplace := AnsiReplaceStr(vReplace, '', vParams);
  memScrInsert.Lines.Text := vReplace;
end;

procedure TfmMain.btnOkClick(Sender: TObject);
begin
  UpDateDatabase;
end;

procedure TfmMain.FormCreate(Sender: TObject);
begin
  Fini := TIniFile.Create(ExtractFileDir(Application.ExeName) + '\SpSettings.Ini');
  if (not Fini.SectionExists('Insert')) then
  begin
    Fini.WriteString('Insert', 'Prefix', '');
  end;
  if (not Fini.SectionExists('Update')) then
  begin
    Fini.WriteString('Update', 'Prefix', '');
  end;
  if (not Fini.SectionExists('Delete')) then
  begin
    Fini.WriteString('Delete', 'Prefix', '');
  end;
  Fini.UpdateFile;
end;

procedure TfmMain.FormDestroy(Sender: TObject);
begin
  Fini.Free;
  Fini := nil;
end;

procedure TfmMain.btnOk2Click(Sender: TObject);
begin
  Fini.WriteString('Insert', 'Prefix', edtInsert.Text);
  Fini.WriteString('Update', 'Prefix', edtUpdate.Text);
  Fini.WriteString('delete', 'Prefix', edtDelete.Text);
  Fini.WriteString('View', 'Prefix', edtView.Text);
  Fini.UpdateFile;
end;

procedure TfmMain.btnok1Click(Sender: TObject);
var
  I: Integer;
begin
  Fini.WriteInteger('Insert', 'Lines', memInsert.Lines.Count - 1);
  for I := 0 to (memInsert.Lines.Count - 1) do
  begin
    Fini.WriteString('Insert', 'Script' + Inttostr(I), memInsert.Lines[I]);
  end;
  Fini.WriteInteger('Update', 'Lines', memUpdate.Lines.Count - 1);
  for I := 0 to (memUpdate.Lines.Count - 1) do
  begin
    Fini.WriteString('Update', 'Script' + Inttostr(I), memUpdate.Lines[I]);
  end;
  Fini.WriteInteger('Delete', 'Lines', memDelete.Lines.Count - 1);
  for I := 0 to (memUpdate.Lines.Count - 1) do
  begin
    Fini.WriteString('delete', 'Script' + Inttostr(I), memDelete.Lines[I]);
  end;
  Fini.UpdateFile;
end;

procedure TfmMain.FormShow(Sender: TObject);
var
  I: Integer;
begin
  edtInsert.Text := Fini.ReadString('Insert', 'Prefix', '');
  edtUpdate.Text := Fini.ReadString('Update', 'Prefix', '');
  edtDelete.Text := Fini.ReadString('delete', 'Prefix', '');
  edtView.Text := Fini.ReadString('View', 'Prefix', '');
  memInsert.Clear;
  for I := 0 to (Fini.ReadInteger('Insert', 'Lines', 0)) do
  begin
    memInsert.Lines.Add(Fini.ReadString('Insert', 'Script' + intTostr(I), ''));
  end;
  memUpdate.Clear;
  for I := 0 to (Fini.ReadInteger('Update', 'Lines', 0)) do
  begin
    memUpdate.Lines.Add(Fini.ReadString('Update', 'Script' + intTostr(I), ''));
  end;
  memDelete.Clear;
  for I := 0 to (Fini.ReadInteger('delete', 'Lines', 0)) do
  begin
    memDelete.Lines.Add(Fini.ReadString('Delete', 'Script' + intTostr(I), ''));
  end;
  sgView.Cells[0, 0] := 'Table Fields';
  sgView.Cells[1, 0] := 'Display Name';
end;

procedure TfmMain.ScriptDelete;
var
  vDeleteKey: string;
  vParamsType: string;
  vReplace: string;
  I: Integer;
  vSpName: string;
begin
  vDeleteKey := '';
  for I := 0 to (clbDelete.Items.Count - 1) do
  begin
    if (clbDelete.Checked[I]) then
    begin
      if (vDeleteKey <> '') then
        vDeleteKey := vDeleteKey + ' and ';
      vDeleteKey := vDeleteKey + ' (' + clbDelete.Items[I] + ' = @' +
        clbDelete.Items[I] + ') ';
      if (vParamsType <> '') then
        vParamsType := vParamsType + ', ';
      vParamsType := vParamsType + '@' + clbUpdate.Items[I] + ' ';
      if adoQry.Locate('name', clbDelete.Items[I], [locaseinsensitive]) then
      begin
        vParamsType := vParamsType + adoQry.fieldbyname('dt').AsString + ' ';
        if (pos(adoQry.fieldbyname('xtype').AsString, LengthFields) > 0) then
        begin
          vParamsType := vParamsType + '( ' + adoQry.fieldbyname('length').AsString +
            ' )';
        end
        else
        begin
        end;
      end;
    end
    else
    begin
    end;
  end;
  vSpName := Fini.ReadString('delete', 'Prefix', '');
  vReplace := memDelete.Lines.Text;
  vReplace := AnsiReplaceStr(vReplace, '', FSelectedTable);
  vReplace := AnsiReplaceStr(vReplace, '', vSpName + FTblDisplayName);
  vReplace := AnsiReplaceStr(vReplace, '', vDeleteKey);
  vReplace := AnsiReplaceStr(vReplace, '', FTblDisplayName);
  vReplace := AnsiReplaceStr(vReplace, '', vParamsType);
  memScrDelete.Lines.Text := vReplace;
end;

procedure TfmMain.ScriptUpdate;
var
  vUpdateFields: string;
  vUpDateKey: string;
  vFields: string;
  vParamsType: string;
  vParams: string;
  vReplace: string;
  I: Integer;
  vSpName: string;
begin
  vUpdateFields := '';
  vUpDateKey := '';
  vFields := '';
  vParams := '';
  vParamsType := '';
  for I := 0 to (clbUpdate.Items.Count - 1) do
  begin
    if (clbUpdate.Checked[I]) then
    begin
      if (vUpDateKey <> '') then
        vUpDateKey := vUpDateKey + ' and ';
      vUpDateKey := vUpDateKey + ' (' + clbUpdate.Items[I] + ' = @' +
        clbUpdate.Items[I] + ') ';
    end
    else
    begin
      if (vFields <> '') then
        vFields := vFields + ', ';
      vFields := vFields + ' ' + clbUpdate.Items[I] + ' = ' + '@' + clbUpdate.Items[I]
        + ' ';
    end;
    if (vParamsType <> '') then
      vParamsType := vParamsType + ', ';
    vParamsType := vParamsType + '@' + clbUpdate.Items[I] + ' ';
    if (vParams <> '') then
      vParams := vParams + ', ';
    vParams := vParams + '@' + clbInsert.Items[I] + ' ';
    if adoQry.Locate('name', clbInsert.Items[I], [locaseinsensitive]) then
    begin
      vParamsType := vParamsType + adoQry.fieldbyname('dt').AsString + ' ';
      if (pos(adoQry.fieldbyname('xtype').AsString, LengthFields) > 0) then
      begin
        vParamsType := vParamsType + '( ' + adoQry.fieldbyname('length').AsString +
          ' )';
      end
      else
      begin
      end;
    end;
  end;
  vSpName := Fini.ReadString('Update', 'Prefix', '');
  vReplace := memUpdate.Lines.Text;
  vReplace := AnsiReplaceStr(vReplace, '', FSelectedTable);
  vReplace := AnsiReplaceStr(vReplace, '', vSpName + FTblDisplayName);
  vReplace := AnsiReplaceStr(vReplace, '', vFields);
  vReplace := AnsiReplaceStr(vReplace, '', vParamsType);
  vReplace := AnsiReplaceStr(vReplace, '', FTblDisplayName);
  vReplace := AnsiReplaceStr(vReplace, '', vUpDateKey);
  memscrUpdate.Lines.Text := vReplace;
end;

procedure TfmMain.UpDateDatabase;
var
  vSpName: string;
  procedure Insert;
  begin
    try
      adoQry.Close;
      adoQry.SQL.Text := memScrInsert.Lines.Text;
      adoQry.ExecSQL;
      lblStatus.Caption := 'Insert Done';
    except
      lblStatus.Caption := 'Insert Failed';
    end;
  end;
  procedure Update;
  begin
    try
      adoQry.Close;
      adoQry.SQL.Text := memscrUpdate.Lines.Text;
      adoQry.ExecSQL;
      lblStatus.Caption := lblStatus.Caption + 'Update - Done'
    except
      lblStatus.Caption := lblStatus.Caption + 'Update - Failed'
    end;
  end;
  procedure Delete;
  begin
    try
      adoQry.Close;
      adoQry.SQL.Text := memScrDelete.Lines.Text;
      adoQry.ExecSQL;
      lblStatus.Caption := lblStatus.Caption + ', Delete - Done'
    except
      lblStatus.Caption := lblStatus.Caption + ', Delete - Failed'
    end;
  end;
begin
  vSpName := Fini.ReadString('Insert', 'Prefix', '') + FTblDisplayName;
  try
    adoQry.Close;
    adoQry.SQL.Text := 'Select count(1) obj from sysobjects where name = ' +
      #39 + vSpName + #39;
    adoQry.Open;
    if (adoQry.FieldByName('obj').AsInteger > 0) then
    begin
      if (MessageDlg('Insert', 'Stored Procedure ' + vSpName +
        ' already Exists, Over Write it ?', mtconfirmation, [mbYes, mbNo], 0) = mrYes)
        then
      begin
        adoQry.Close;
        adoQry.SQL.Text := 'drop procedure ' + vSpName;
        try
          adoQry.ExecSQL;
          Insert;
        except
          ShowMessage('Could not delete ' + vSpName);
        end;
      end;
    end
    else
      Insert;
  except
  end;

  if (lblStatus.Caption <> '') then
    lblStatus.Caption := lblStatus.Caption + ', ';
  vSpName := Fini.ReadString('Update', 'Prefix', '') + FTblDisplayName;
  try
    adoQry.Close;
    adoQry.SQL.Text := 'Select count(1) obj from sysobjects where name = ' +
      #39 + vSpName + #39;
    adoQry.Open;
    if (adoQry.FieldByName('obj').AsInteger > 0) then
    begin
      if (MessageDlg('Update', 'Stored Procedure ' + vSpName +
        ' already Exists, Over Write it ?', mtConfirmation, [mbYes, mbNo], 0) = mrYes)
        then
      begin
        adoQry.Close;
        adoQry.SQL.Text := 'drop procedure ' + vSpName;
        try
          adoQry.ExecSQL;
          Update;
        except
          ShowMessage('Could not delete ' + vSpName);
        end;
      end;
    end
    else
      Update;
  except
  end;

  if (lblStatus.Caption <> '') then
    lblStatus.Caption := lblStatus.Caption + ', ';
  vSpName := Fini.ReadString('Delete', 'Prefix', '') + FTblDisplayName;
  try
    adoQry.Close;
    adoQry.SQL.Text := 'Select count(1) obj from sysobjects where name = ' +
      #39 + vSpName + #39;
    adoQry.Open;
    if (adoQry.FieldByName('obj').AsInteger > 0) then
    begin
      if (MessageDlg('Delete', 'Stored Procedure ' + vSpName +
        ' already Exists, Over Write it ?', mtConfirmation, [mbYes, mbNo], 0) = mrYes)
        then
      begin
        adoQry.Close;
        adoQry.SQL.Text := 'drop procedure ' + vSpName;
        try
          adoQry.ExecSQL;
          Delete;
        except
          ShowMessage('Could not delete ' + vSpName);
        end;
      end;
    end
    else
      Delete;
  except
  end;
end;

procedure TfmMain.ScriptView;
var
  I: Integer;
  vScr: string;
begin
  vScr := '';
  sgView.RowCount := 1;
  sgView.Cells[0, 0] := '';
  clbView.Items := clbInsert.Items;
  //  sgView.RowCount := ( clbInsert.Items.Count - 1 );
  for I := 0 to (clbInsert.Items.Count - 1) do
  begin
    if (I > 0) then
      sgView.RowCount := (I + 1);
    sgView.Cells[0, I] := clbInsert.Items[I];
    clbView.Checked[I] := true;
  end;
  GenScriptView;
end;

procedure TfmMain.GenScriptView;
var
  I: Integer;
  vScr: string;
begin
  vScr := 'Create View ' + Fini.ReadString('View', 'Prefix', 'vw_') + FTblDisplayName +
    ' As ' + #13 +
    '   Select ';
  for I := 0 to (clbView.Items.Count - 1) do
  begin
    if clbView.Checked[I] then
    begin
      if (I > 0) then
        vScr := vScr + ', ' + #13;
      if (I > 0) then
        vScr := vScr + '                 ';
      vScr := vScr + clbView.Items[I];
      if (sgView.Cells[0, I] <> clbView.Items[I]) then
      begin
        vScr := vScr + ' [' + sgView.Cells[0, I] + ']';
      end
      else
      begin
      end;
    end;
  end;
  vScr := vScr + #13 + ' from ' + FSelectedTable;
  memView.Lines.Text := vScr;
end;

procedure TfmMain.clbViewClickCheck(Sender: TObject);
begin
  GenScriptView;
end;

procedure TfmMain.sgViewSetEditText(Sender: TObject; ACol, ARow: Integer;
  const Value: string);
begin
  GenScriptView;
end;

procedure TfmMain.btnViewClick(Sender: TObject);
var
  vSpName: string;
  procedure ViewScript;
  begin
    try
      adoQry.Close;
      adoQry.SQL.Text := memView.Text;
      adoQry.ExecSQL;
      lblStatusView.Caption := 'View Created.';
    except
      lblStatusView.Caption := 'View Creation Failed';
    end;
  end;
begin
  vSpName := Fini.ReadString('View', 'Prefix', '') + FTblDisplayName;
  try
    adoQry.Close;
    adoQry.SQL.Text := 'Select count(1) obj from sysobjects where name = ' +
      #39 + vSpName + #39;
    adoQry.Open;
    if (adoQry.FieldByName('obj').AsInteger > 0) then
    begin
      if (Application.MessageBox(pchar('View ' + vSpName +
        ' already Exists, Over Write it ?'), pchar('View'), MB_YESNO) = 6) then
      begin
        // if ( MessageDlg( 'View', 'View ' + vSpName + ' already Exists, Over Write it ?', mtconfirmation, [mbYes, mbNo],0 ) = mrYes ) then begin
        adoQry.Close;
        adoQry.SQL.Text := 'drop view ' + vSpName;
        try
          adoQry.ExecSQL;
          ViewScript;
        except
          ShowMessage('Could not delete ' + vSpName);
        end;
      end;
    end
    else
      ViewScript;
  except
  end;

end;

end.

SpSettings.ini

[Insert]
Prefix=spIns_
Lines=16
Script0=CREATE  PROCEDURE
Script1=AS
Script2=DECLARE @Err int, @RowC int
Script3=BEGIN TRAN
Script4=SET NOCOUNT ON
Script5=Insert into   ()  values ( )
Script6=
Script7=Select @Err=@@Error,@RowC=@@RowCount
Script8=IF @Err  <> 0
Script9=BEGIN
Script10=ROLLBACK TRAN
Script11=RAISERROR('Could not Add Information into ',16,-1)
Script12=RETURN
Script13=END
Script14=SET NOCOUNT OFF
Script15=COMMIT TRAN
Script16=GO
[Update]
Prefix=spUpd_
Lines=25
Script0=CREATE  PROCEDURE
Script1=AS
Script2=DECLARE @Err int, @RowC int
Script3=BEGIN TRAN
Script4=SET NOCOUNT ON
Script5=Update   set
Script6=where
Script7=
Script8=Select @Err=@@Error,@RowC=@@RowCount
Script9=
Script10=IF @RowC = 0
Script11=BEGIN
Script12=ROLLBACK TRAN
Script13=RAISERROR(' Information does not exist in ',16,-1)
Script14=RETURN
Script15=END
Script16=
Script17=IF @Err  <> 0
Script18=BEGIN
Script19=ROLLBACK TRAN
Script20=RAISERROR('Could not Update Information in ',16,-1)
Script21=RETURN
Script22=END
Script23=SET NOCOUNT OFF
Script24=COMMIT TRAN
Script25=GO
Script26=GO
[Delete]
Prefix=spDel_
Lines=24
Script0=CREATE  PROCEDURE
Script1=AS
Script2=DECLARE @Err int, @RowC int
Script3=BEGIN TRAN
Script4=SET NOCOUNT ON
Script5=Delete from where
Script6=
Script7=Select @Err=@@Error,@RowC=@@RowCount
Script8=
Script9=IF @RowC = 0
Script10=BEGIN
Script11=ROLLBACK TRAN
Script12=RAISERROR('Information does not exist in ',16,-1)
Script13=RETURN
Script14=END
Script15=
Script16=IF @Err  <> 0
Script17=BEGIN
Script18=ROLLBACK TRAN
Script19=RAISERROR('Could not Delete  Information from ',16,-1)
Script20=RETURN
Script21=END
Script22=SET NOCOUNT OFF
Script23=COMMIT TRAN
Script24=GO
Script25=
Script26=
[View]
Prefix=vw_

Simple Implementation of LZW Compression/Decompression Algorithm

Problem/Question/Abstract:

How do I Compress and Decompress files using LZW Algorithm.

Answer:

Here is a simple implemntation of LZW compression/Decompression algorithm. It is not fast and compression ratio is very small. Here is the code.

unit RevLZW;

interface

uses
  sysutils, classes, dialogs, windows;

const
  tabsize: integer = 4095;
  copybyte: integer = 0;
  compbyte: integer = 1;
  endlist: integer = -1;
  nochar: integer = -2;
  empty: integer = -3;
  eofchar: integer = -4;
  bufsize: integer = 32768;
  maxstack: integer = 4096;
type
  TStringObject = record
    prevchar: integer;
    nextchar: integer;
    next: integer;
    used: boolean;
    nused: integer;
    flocked: boolean;
  end;

procedure Initialize;
procedure Terminate;
function OpenInputFile(fname: string): boolean;
function OpenOutputFile(fname: string): boolean;
function getbyte: integer;
procedure putbyte(c: integer);
procedure compress;
procedure decompress;
procedure putcode(code: integer; lbyte: boolean = false);
function getcode: integer;
function GetHashCode(prevc, nextc: integer): integer;
function findstring(prevc, nextc: integer): integer;
function MakeTableEntry(prevc: integer; nextc: integer): boolean;
procedure push(c: integer);
procedure pop(var c: integer);
procedure InitializeStringTable;

var
  fsize: integer;
  fread, fwrote: integer;
  ihandle, ohandle: integer;
  inbufpos, outbufpos: integer;
  objectid: integer;
  stringtable: array[0..4095] of TstringObject;
  inblock: array[0..65535 {32767}] of char;
  outblock: array[0..65535 {32767}] of char;
  stack: array[0..4095] of char;
  stackpointer: integer;
  rembits: integer;
  lastbyte: boolean;
  rembitcount: integer;
  lzwerr: boolean;
  imap, omap: integer;
implementation

function OpenInputFile(fname: string): boolean;
begin
  result := true;
  ihandle := fileopen(fname, fmShareExclusive or fmOpenRead);
  fsize := getfilesize(ihandle, nil);
  if fsize < 32768 then
    fileread(ihandle, inblock, fsize)
  else
    fileread(ihandle, inblock, 32768);
  if ihandle = -1 then
    result := false;
end;

function OpenOutputFile(fname: string): boolean;
begin
  result := true;
  ohandle := filecreate(fname);
  if ohandle = -1 then
    result := false;
end;

function getbyte: integer;
begin
  if inbufpos = 32768 then
  begin
    inbufpos := 0;
    fileread(ihandle, inblock, 32768);
  end;
  if fread = fsize then
    result := eofchar
  else
    result := integer(inblock[inbufpos]);
  inc(inbufpos);
  inc(fread);
end;

procedure putbyte(c: integer);
begin
  if outbufpos = 32768 then
  begin
    outbufpos := 0;
    filewrite(ohandle, outblock, 32768);
  end;
  outblock[outbufpos] := char(c);
  inc(outbufpos);
  inc(fwrote);
end;

procedure Initialize;
begin
  inbufpos := 0;
  outbufpos := 0;
  fread := 0;
  fwrote := 0;
  objectid := 0;
  stackpointer := 0;
  lastbyte := false;
  rembits := empty;
  rembitcount := 0;
  lzwerr := false;
  InitializeStringtable;
end;

procedure InitializeStringTable;
var
  i: integer;
begin
  objectid := 0;
  for i := 0 to 4095 do
  begin
    with stringtable[i] do
    begin
      if not flocked then
      begin
        prevchar := nochar;
        nextchar := nochar;
        next := endlist;
        used := false;
        nused := 0;
        flocked := false;
      end;
    end;
    if i <= 255 then
    begin
      stringtable[i].nextchar := i;
      stringtable[i].used := true;
      inc(objectid);
    end;
  end;
end;

procedure Terminate;
begin
  if outbufpos > 0 then
    filewrite(ohandle, outblock, outbufpos);
  setendoffile(ohandle);
  fileclose(ihandle);
  fileclose(ohandle);
end;

function GetHashCode(prevc, nextc: integer): integer;
var
  index, newindex: integer;
begin
  index := ((prevc shl 5) xor nextc) and tabsize;
  if not stringtable[index].used then
    result := index
  else
  begin
    while stringtable[index].next <> endlist do
      index := stringtable[index].next;
    newindex := index and tabsize;
    while stringtable[newindex].used do
      newindex := succ(newindex) and tabsize;
    stringtable[index].next := newindex;
    result := newindex;
  end;
end;

function findstring(prevc, nextc: integer): integer;
var
  index: integer;
  found: boolean;
begin
  result := endlist;
  if (prevc = nochar) and (nextc <= 255) then
    result := nextc
  else
  begin
    index := ((prevc shl 5) xor nextc) and tabsize;
    repeat
      found := (stringtable[index].prevchar = prevc) and (stringtable[index].nextchar
        = nextc);
      if not found then
        index := stringtable[index].next;
    until found or (index = endlist);
    if found then
    begin
      result := index;
      inc(stringtable[index].nused);
    end;
  end;
end;

function MakeTableEntry(prevc: integer; nextc: integer): boolean;
var
  index: integer;
begin
  result := true;
  if objectid <= tabsize then
  begin
    index := gethashcode(prevc, nextc);
    with stringtable[index] do
    begin
      prevchar := prevc;
      nextchar := nextc;
      used := true;
    end;
    inc(objectid);
    if objectid = tabsize + 1 then
      result := false;
  end;
end;

procedure putcode(code: integer; lbyte: boolean);
var
  tmpcode: integer;
begin
  if stringtable[code].prevchar = nochar then
  begin
    if rembitcount < 7 then
    begin
      tmpcode := (rembits shl (8 - rembitcount)) or (copybyte shl (7 - rembitcount))
        or ((code shr (rembitcount + 1)) and ($7F shr rembitcount));
      putbyte(tmpcode);
      inc(fwrote);
      rembits := code and ($FF shr (7 - rembitcount));
      inc(rembitcount);
    end
    else if rembitcount = 7 then
    begin
      tmpcode := (rembits shl 1) or copybyte;
      putbyte(tmpcode);
      inc(fwrote, 2);
      putbyte(code);
      rembits := empty;
      rembitcount := 0;
    end;
  end
  else
  begin
    tmpcode := (rembits shl (8 - rembitcount)) or (compbyte shl (7 - rembitcount)) or
      (code shr (5 + rembitcount) and ($7F shr rembitcount));
    putbyte(tmpcode);
    inc(fwrote);
    rembitcount := rembitcount + 5;
    if rembitcount < 8 then
      rembits := code and ($FF shr (8 - rembitcount));
    if rembitcount >= 8 then
    begin
      rembits := (code shr (rembitcount - 8)) and $FF;
      inc(fwrote);
      putbyte(rembits);
      rembitcount := rembitcount - 8;
      rembits := code and ($FF shr (8 - rembitcount));
    end;
  end;
  if lbyte and (rembitcount > 0) then
  begin
    tmpcode := ((rembits and ($FF shr (8 - rembitcount))) shl (8 - rembitcount));
    putbyte(tmpcode);
    inc(fwrote);
  end;
end;

function getcode: integer;
var
  part1, part2: integer;
  iscomp: integer;
  c1, c2: integer;
begin
  result := eofchar;
  if (fread = fsize) and (rembitcount = 0) then
  begin
    result := eofchar;
    exit;
  end;
  if rembitcount = 0 then
  begin
    part1 := getbyte;
    part2 := getbyte;
    iscomp := (part1 shr 7) and 1;
    if iscomp = 1 then
    begin
      c1 := part1 and $7F;
      c2 := (part2 shr 3) and $1F;
      rembits := part2 and $7;
      rembitcount := 3;
      result := (c1 shl 5) or c2;
    end
    else if iscomp = 0 then
    begin
      c1 := part1 and $7F;
      c2 := (part2 shr 7) and $1;
      result := (c1 shl 1) or c2;
      rembits := part2 and $7F;
      rembitcount := 7;
    end;
  end
  else if rembitcount = 1 then
  begin
    part1 := getbyte;
    iscomp := rembits;
    if iscomp = 1 then
    begin
      part2 := getbyte;
      c1 := part1 and $FF;
      c2 := (part2 shr 4) and $F;
      rembits := part2 and $F;
      rembitcount := 4;
      result := (c1 shl 4) or c2;
    end
    else if iscomp = 0 then
    begin
      c1 := part1 and $FF;
      result := c1;
      rembits := empty;
      rembitcount := 0;
    end;
  end
  else if rembitcount = 2 then
  begin
    part1 := getbyte;
    iscomp := (rembits shr 1) and 1;
    if iscomp = 1 then
    begin
      part2 := getbyte;
      c1 := ((rembits and 1) shl 7) or ((part1 shr 1) and $7F);
      c2 := ((part1 and 1) shl 3) or ((part2 shr 5) and $7);
      rembits := part2 and $1F;
      rembitcount := 5;
      result := (c1 shl 4) or (c2 and $F);
    end
    else if iscomp = 0 then
    begin
      c1 := ((rembits and 1) shl 7) or ((part1 shr 1) and $7F);
      result := c1;
      rembits := part1 and 1;
      rembitcount := 1;
    end;
  end
  else if rembitcount = 3 then
  begin
    part1 := getbyte;
    iscomp := (rembits shr 2) and 1;
    if iscomp = 1 then
    begin
      part2 := getbyte;
      c1 := ((rembits and $3) shl 6) or ((part1 shr 2) and $3F);
      c2 := ((part1 and $3) shl 2) or ((part2 shr 6) and $3);
      rembits := part2 and $3F;
      rembitcount := 6;
      result := (c1 shl 4) or (c2 and $F);
    end
    else if iscomp = 0 then
    begin
      c1 := ((rembits and $3) shl 6) or ((part1 shr 2) and $3F);
      result := c1;
      rembits := part1 and $3;
      rembitcount := 2;
    end;
  end
  else if rembitcount = 4 then
  begin
    part1 := getbyte;
    iscomp := (rembits shr 3) and 1;
    if iscomp = 1 then
    begin
      part2 := getbyte;
      c1 := ((rembits and $7) shl 5) or ((part1 shr 3) and $1F);
      c2 := ((part1 and $7) shl 1) or ((part2 shr 7) and $1);
      rembits := part2 and $7F;
      rembitcount := 7;
      result := (c1 shl 4) or (c2 and $F);
    end
    else if iscomp = 0 then
    begin
      c1 := ((rembits and $7) shl 5) or ((part1 shr 3) and $1F);
      result := c1;
      rembits := part1 and $7;
      rembitcount := 3;
    end;
  end
  else if rembitcount = 5 then
  begin
    part1 := getbyte;
    iscomp := (rembits shr 4) and 1;
    if iscomp = 1 then
    begin
      c1 := ((rembits and $F) shl 4) or ((part1 shr 4) and $F);
      c2 := part1 and $F;
      rembits := empty;
      rembitcount := 0;
      result := (c1 shl 4) or (c2 and $F);
    end
    else if iscomp = 0 then
    begin
      c1 := ((rembits and $F) shl 4) or ((part1 shr 4) and $F);
      result := c1;
      rembits := part1 and $F;
      rembitcount := 4;
    end;
  end
  else if rembitcount = 6 then
  begin
    part1 := getbyte;
    iscomp := (rembits shr 5) and 1;
    if iscomp = 1 then
    begin
      c1 := ((rembits and $1F) shl 3) or ((part1 shr 5) and $7);
      c2 := (part1 shr 1) and $F;
      rembits := part1 and 1;
      rembitcount := 1;
      result := (c1 shl 4) or (c2 and $F);
    end
    else if iscomp = 0 then
    begin
      c1 := ((rembits and $1F) shl 3) or ((part1 shr 5) and $7);
      result := c1;
      rembits := part1 and $1F;
      rembitcount := 5;
    end;
  end
  else if rembitcount = 7 then
  begin
    part1 := getbyte;
    iscomp := (rembits shr 6) and 1;
    if iscomp = 1 then
    begin
      c1 := ((rembits and $3F) shl 2) or ((part1 shr 6) and $3);
      c2 := (part1 shr 2) and $F;
      rembits := part1 and $3;
      rembitcount := 2;
      result := (c1 shl 4) or (c2 and $F);
    end
    else if iscomp = 0 then
    begin
      c1 := ((rembits and $3F) shl 2) or ((part1 shr 6) and $3);
      result := c1;
      rembits := part1 and $3F;
      rembitcount := 6;
    end;
  end;
end;

procedure compress;
var
  c, wc, w: integer;
begin
  initialize;
  c := getbyte;
  w := findstring(nochar, c);
  c := getbyte;
  while fread <= fsize - 1 do
  begin
    if lastbyte then
    begin
      putcode(w);
      lastbyte := false;
      InitializeStringtable;
      c := getbyte;
      w := findstring(nochar, c);
      c := getbyte;
    end;
    wc := findstring(w, c);
    if wc = endlist then
    begin
      lastbyte := not (MakeTableEntry(w, c));
      putcode(w);
      w := findstring(nochar, c);
    end
    else
      w := wc;
    if not lastbyte then
      c := getbyte;
  end;
  putcode(w, true);
end;

procedure decompress;
var
  unknown: boolean;
  finchar, lastchar: integer;
  code, oldcode, incode: integer;
  c, tempc: integer;
begin
  initialize;
  unknown := false;
  lastchar := empty;
  oldcode := getcode;
  code := oldcode;
  c := stringtable[code].nextchar;
  putbyte(c);
  finchar := c;
  incode := getcode;
  while incode <> eofchar do
  begin
    if lastbyte then
    begin
      lastbyte := false;
      InitializeStringTable;
      stackpointer := 0;
      unknown := false;
      lastchar := empty;
      oldcode := getcode;
      code := oldcode;
      c := stringtable[code].nextchar;
      putbyte(c);
      finchar := c;
      incode := getcode;
    end;
    code := incode;
    if not stringtable[code].used then
    begin
      lastchar := finchar;
      code := oldcode;
      unknown := true;
    end;
    while (stringtable[code].prevchar <> nochar) do
    begin
      push(stringtable[code].nextchar);
      if lzwerr = true then
        break;
      code := stringtable[code].prevchar;
    end;
    if lzwerr = true then
      break;
    finchar := stringtable[code].nextchar;
    putbyte(finchar);
    pop(tempc);
    while (tempc <> empty) do
    begin
      putbyte(tempc);
      pop(tempc);
    end;
    if unknown then
    begin
      finchar := lastchar;
      putbyte(finchar);
      unknown := false;
    end;
    lastbyte := not (maketableentry(oldcode, finchar));
    if not lastbyte then
    begin
      oldcode := incode;
      incode := getcode;
    end
  end;
end;

procedure push(c: integer);
var
  s: string;
begin
  if stackpointer < 4096 then
  begin
    inc(stackpointer);
    stack[stackpointer] := char(c);
  end;
  if stackpointer >= 4096 then
  begin
    s := 'Stack full at ' + inttostr(inbufpos);
    lzwerr := true;
    showmessage(s);
  end;
end;

procedure pop(var c: integer);
begin
  if stackpointer > 0 then
  begin
    c := integer(stack[stackpointer]);
    dec(stackpointer);
  end
  else
    c := empty;
end;

end.

To compress the file add the following code to a button

openinputfile('C:\cdidxtmp\myfile.exe');
openoutputfile('C:\cdidxtmp\myfile.bak');
initialize;
compress;

To Decompress

openinputfile('C:\cdidxtmp\myfile.bak');
openoutputfile('C:\cdidxtmp\myfile.exe');
initialize;
decompress;