Load DOS text in a RichEdit

Problem/Question/Abstract:

Load OEM file (any DOS edited file) in a RichEdit.

Answer:

Use the following code, that translates the text through the OemToAnsiBuff function:


procedure TForm1.Button1Click(Sender: TObject);
var
  i: integer;
  linea: PChar;
  txt: TStringList;
begin
  txt := TStringList.Create;
  try
    txt.LoadFromFile('c:\Fichero\a\leer.txt');
    for i := 0 to txt.Count - 1 do
    begin
      linea := PChar(txt.strings[i]);
      OemToAnsiBuff(linea, linea, strlen(linea));
    end;
    RichEdit1.Lines.AddStrings(txt);
  finally
    txt.Free;
  end;
end;

Implode / Explode methods like in PHP

Problem/Question/Abstract:

In Delphi you can also use the implode and explode methods from PHP:

Answer:

type
  TDynStringArray = array of string;

function Implode(const Glue: string; const Pieces: array of string): string;
var
  I: Integer;
begin
  Result := '';
  for I := 0 to High(Pieces) do
    Result := Result + Glue + Pieces[I];
  Delete(Result, 1, Length(Glue));
end;

function Explode(const Separator, S: string; Limit: Integer = 0): TDynStringArray;
var
  SepLen: Integer;
  F, P: PChar;
begin
  SetLength(Result, 0);
  if (S = '') or (Limit < 0) then
    Exit;
  if Separator = '' then
  begin
    SetLength(Result, 1);
    Result[0] := S;
    Exit;
  end;
  SepLen := Length(Separator);

  P := PChar(S);
  while P^ <> #0 do
  begin
    F := P;
    P := AnsiStrPos(P, PChar(Separator));
    if (P = nil) or ((Limit > 0) and (Length(Result) = Limit - 1)) then
      P := StrEnd(F);
    SetLength(Result, Length(Result) + 1);
    SetString(Result[High(Result)], F, P - F);
    F := P;
    while (P^ <> #0) and (P - F < SepLen) do
      Inc(P); // n�chsten Anfang ermitteln
  end;
end;

Debug your ISAPI applications on IIS 5

Problem/Question/Abstract:

Debug your ISAPI applications on IIS 5 without messing around with the registry. Just as simple as it should be!

Answer:

Start IIS WWW service;

Open Internet Services Manager and start your web site;

Open the properties sheet of your scripts directory;

Choose Aplication Protection = Low;

Click on Configuration button and choose the App Debugging tab;

Enable both Debugging Flags;

Close Internet Services Manager and stop IIS WWW service (do not stop your web site before stoping IIS);

Set your Delphi ISAPI Run Parameters as follows:
- host application: C:\WINNT\system32\inetsrv\inetinfo.exe (fix the path if necessary);
- parameters: -e w3svc;

That's it!

Now start your application inside Delphi IDE and it'll start IIS. Open your browser and go to your application. Delphi should start it and "say" it's running.

Good luck!

How to read/ write a variable length string from/ to a TFileStream

Problem/Question/Abstract:

How to read/ write a variable length string from/ to a TFileStream

Answer:

Solve 1:

procedure WriteStringToFS(const s: string; const fs: TFileStream);
var
  i: integer;
begin
  i := 0;
  i := Length(s);
  if i > 0 then
    fs.WriteBuffer(s[1], i);
end;

function ReadStringFromFS(const fs: TFileStream): string;
var
  i: integer;
  s: string;
begin
  i := 0;
  s := '';
  fs.ReadBuffer(i, SizeOf(i));
  SetLength(s, i);
  fs.ReadBuffer(s, i);
  Result := s;
end;


Solve 2:

You should be using TWriter and TReader. They make this kind of thing really simple to do. Create a stream, writer and reader object at the form level, then instantiate them in the OnCreate and destroy them in the OnDestroy event.

Stream := TMemoryStream.Create; {Or whatever kind of stream}
Writer := TWriter.Create(Stream, 1024);
Reader := TReader.Create(Stream, 1024);

Once that's done, try something similar to the following...

procedure TForm1.WriteStringToFS(const S: string; Writer: TWriter);
begin
  try
    Writer.WriteString(S);
  except
    raise;
  end;
end;

function TForm1.ReadStringFromFS(Reader: TReader): string;
begin
  try
    Result := Reader.ReadString;
  except
    raise;
  end;
end;

No need to save the length of the string because the writer do this automatically. The only caveat is that you need to be sure to create the stream first and to destroy it last.

How to extract coordinates from a region

Problem/Question/Abstract:

I am trying to do regioning backwards. I am writing an application that will read in a bitmap, allow the user to set a transparent colour, and then calculate the point set that would be needed to make that region transparent. I then want to supply the user with the coordinates as a set of coordinates, i.e. I want to extract it from a region format. Why? Because that's how Winamp takes the data in to make its custom shaped forms. But I can't seem to figure out how to pull the data out.

Answer:

One thing I found is that you must create a region prior to GetWindowRgn. I thought that one was created by default. I made a function that does what you need:

procedure TForm1.ShowRgnInfo(Rgn: HRGN);
type
  RgnRects = array[0..1000] of TRect;
  PRgnRect = ^RgnRects;
var
  RgnData: PRgnData;
  Size: DWORD;
  i: Integer;
  R: TRect;
  RgnPtr: PRgnRect;
begin
  Size := GetRegionData(Rgn, 0, nil);
  Memo1.Lines.Add('Size = ' + IntToStr(Size));
  GetMem(RgnData, Size);
  GetRegionData(Rgn, Size, RgnData);
  Memo1.Lines.Add('Number of Rectangles = ' + IntToStr(RgnData.rdh.nCount));
  RgnPtr := @RgnData.Buffer;
  for i := 0 to RgnData.rdh.nCount - 1 do
  begin
    R := RgnPtr[i];
    Memo1.Lines.Add('Rect ' + IntToStr(i));
    Memo1.Lines.Add(IntToStr(R.Left) + ', ' + IntToStr(R.Top) + ', ' +
      IntToStr(R.Right) + ', ' + IntToStr(R.Bottom));
  end;
end;

Making a screen shot (Windows has trouble with big resolutions)

Problem/Question/Abstract:

I just want to give you an example of making a screen shot in "tiles" and pasting the results yourself.

Answer:

Sometimes you want to take a screen shot, however often Windows has trouble with big data amounts and becomes very slow. The simple solution is to make many small screen shots and paste the result together. It's not light speed, however often faster than taking the whole screen at once.

const
  cTileSize = 50;

function TForm1.GetScreenShot: TBitmap;
var
  Locked: Boolean;
  X, Y, XS, YS: Integer;
  Canvas: TCanvas;
  R: TRect;
begin
  Result := TBitmap.Create;
  Result.Width := Screen.Width;
  Result.Height := Screen.Height;
  Canvas := TCanvas.Create;
  Canvas.Handle := GetDC(0);
  Locked := Canvas.TryLock;
  try
    XS := Pred(Screen.Width div cTileSize);
    if Screen.Width mod cTileSize > 0 then
      Inc(XS);
    YS := Pred(Screen.Height div cTileSize);
    if Screen.Height mod cTileSize > 0 then
      Inc(YS);
    for X := 0 to XS do
      for Y := 0 to YS do
      begin
        R := Rect(
          X * cTileSize, Y * cTileSize, Succ(X) * cTileSize,
          Succ(Y) * cTileSize
          );
        Result.Canvas.CopyRect(R, Canvas, R);
      end;
  finally
    if Locked then
      Canvas.Unlock;
    ReleaseDC(0, Canvas.Handle);
    Canvas.Free;
  end;
end;

How to determine if a field's value has actually changed before posting the new value

Problem/Question/Abstract:

How to determine if a field's value has actually changed before posting the new value

Answer:

{ ... }
var
  sBeforeText: string;

  in the AfterEdit event of the table catch the value:

  SBeforeText := DataSet.FieldByName('Category').AsString;

  in the BeforePost or AfterPost Event(depending on your preference)you can compare the original with the current

  if (sBeforeText <> DataSet.FieldByName('Category').AsString) then
    ShowMessage('Different Values');

How to create a Starfield Simulation

Problem/Question/Abstract:

How to create a Starfield Simulation

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  tmp: Integer;
begin
  for tmp := 1 to Num_Stars do {Num_Stars is an Integer value}
    Canvas.Pixels[Random(ClientWidth), Random(ClientHeight)] := clWhite;
end;

And you could get more fancy than that (i.e alter star color / greylevel for brightness, vary star
positions for galaxys).

Add a password to several Paradox tables in one step

Problem/Question/Abstract:

How to add a password to several Paradox tables in one step

Answer:

procedure BDEProtectTable(ATable: TTable; const APassword: string);
var
  CurPrp: CURProps;
  hDB: hDBIdb;
  TableDesc: CRTblDesc;
  DoEncrypt: boolean;
  bExcl, bOpen: boolean;
begin
  Check(DBIGetCursorProps(ATable.Handle, CurPrp));
  DoEncrypt := (APassword > '');
  with ATable do
  begin
    bOpen := Active;
    bExcl := Exclusive;
    if Active and not Exclusive then
      Close;
    if not Exclusive then
      Exclusive := True;
    if not Active then
      Open;
    {supply nulls (=default) for every optional parameter:}
    FillChar(TableDesc, SizeOf(CRTblDesc), 0);
    {supply indispensable parameters:}
    AnsiToNative(DBLocale, TableName, TableDesc.szTblName, DBIMAXTBLNAMELEN - 1);
    TableDesc.szTblType := CurPrp.szTableType;
    {supply parameters for our action here:}
    AnsiToNative(DBLocale, APassword, TableDesc.szPassword, 255);
    TableDesc.bProtected := DoEncrypt; {supply False to decrypt}
    hDB := DBHandle;
    Close;
    {do the restructure:}
    try
      Check(DBIDoRestructure(hDB, 1, @TableDesc, nil, nil, nil, False));
    finally
      Exclusive := bExcl;
      Active := bOpen;
    end;
  end;
end;

Send a file from a TServerSocket to a TClientSocket

Problem/Question/Abstract:

How i can send a file from a TServerSocket to a TClientSocket?

Answer:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ScktComp, StdCtrls;

type
  TForm1 = class(TForm)
    ClientSocket1: TClientSocket;
    ServerSocket1: TServerSocket;
    btnTestSockets: TButton;
    procedure ClientSocket1Read(Sender: TObject; Socket: TCustomWinSocket);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ClientSocket1Disconnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ClientSocket1Connect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure ServerSocket1ClientConnect(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure btnTestSocketsClick(Sender: TObject);
  private
    FStream: TFileStream;

  public

  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.ClientSocket1Read(Sender: TObject;
  Socket: TCustomWinSocket);
var
  iLen: Integer;
  Bfr: Pointer;
begin
  iLen := Socket.ReceiveLength;
  GetMem(Bfr, iLen);
  try
    Socket.ReceiveBuf(Bfr^, iLen);
    FStream.Write(Bfr^, iLen);
  finally
    FreeMem(Bfr);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FStream := nil;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if Assigned(FStream) then
  begin
    FStream.Free;
    FStream := nil;
  end;
end;

procedure TForm1.ClientSocket1Disconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  if Assigned(FStream) then
  begin
    FStream.Free;
    FStream := nil;
  end;
end;

procedure TForm1.ClientSocket1Connect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  FStream := TFileStream.Create('c:\temp\test.stream.html', fmCreate or
    fmShareDenyWrite);
end;

procedure TForm1.ServerSocket1ClientConnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  Socket.SendStream(TFileStream.Create('c:\temp\test.html', fmOpenRead or
    fmShareDenyWrite));
end;

procedure TForm1.btnTestSocketsClick(Sender: TObject);
begin
  ServerSocket1.Active := True;
  ClientSocket1.Active := True;
end;

end.

Implement an inactivity timer with automatic logout

Problem/Question/Abstract:

Anyone have suggestions on how to implement an inactivity timer? My application has passwords for various functions, and I need to be able to automatically logout a user if they've been inactive for 10 minutes, etc.. I suppose I'd tie into the messaging queue, looking at keyboard and mouse events. The implementation should cover activity related to any form in my application, but not any activity outside the application.

Answer:

In your main form, add the integer variables "ShutdownCounter" and "ShutDownDelay". Add a TApplicationEvents and a TTimer control. Set the timer interval to, say, 5000 mSecs. In the form's OnCreate event handler, add:

{ ... }
    {Set up the automatic log off routine. Get the users auto logoff time,
                which defaults to 20 minutes. 0 is never autologoff}
shutDownDelay := UserIni.ReadInteger('Settings', 'Auto Shutdown Delay', 20);
shutDownDelay := shutDownDelay * 60;
ShutdownCounter := 0;
if shutDownDelay > 0 then
  timShutDown.Enabled := true;
    {Enable the timer if you want to use a timeout for this user}

This format allows you to add different logoff times for different users, or completely disable autologoff - I do this on my development system.

In the TApplicationEvents OnMessage event handler, add code to check for keypresses, or left mouse button clicks (or any other message you want to use to keep the app running). Whenever any of these messages are received by the application, reset the ShutDownCounter to zero.

procedure TfrmAutoProMain.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
begin
  case Msg.message of
    WM_KEYDOWN, WM_LBUTTONDOWN:
      ShutdownCounter := 0;
  end;
end;

In the TTimer OnTimer event handler, add code to compare the current value of ShutDownCounter against the ShutDownDelay for this user. If the counter is larger than the delay, then we need to exit the application. In my apps, I actually show another window with a 30 second decrementing progress bar which gives the user notification that the app is about to shutdown, and gives him a chance to keep the app alive - that's the references to dlgAutoLogOff .

procedure TfrmAutoProMain.timShutDownTimer(Sender: TObject);
begin
  Inc(ShutdownCounter, 5);
    {Increase counter by 5 seconds (if TTimer interval was 5000)}
  if ShutdownCounter >= shutDownDelay then
  begin
    timShutDown.Enabled := false;
    {The next block handles a "last chance" warning dialog to allow the user
                to stay alive}
    dlgAutoLogOff := TdlgAutoLogOff.Create(self);
    try
      dlgAutoLogOff.Show;
      repeat
        Application.ProcessMessages;
      until
        (dlgAutoLogOff.ModalResult = mrOK) or (dlgAutoLogOff.ModalResult = mrAbort);
      if dlgAutoLogOff.ModalResult = mrOK then
      begin
        ShutdownCounter := 0;
        timShutDown.Enabled := true;
      end
      else
        Application.Terminate;
    finally
      dlgAutoLogOff.Free;
    end;
  end;
end;

How to determine which combinations of rows and columns have been checked off in an array of TCheckBoxes

Problem/Question/Abstract:

I have a form with checkboxes in 8 rows and 7 columns. I want to be able to determine which combinations of rows and columns have been checked off. Is the best way to do this using a 2-D array? How would I declare this array for the checkboxes?

Answer:

FArray: array[0..7, 0..6] of TCheckBox;

You also you have to create Checkboxes at runtime, like:

FArray[i, j] := TCheckBox.Create(Self);

I would suggest to use the Tag property instead. Assign the same OnClick event handler to all checkboxes and code the Tag for each checkbox. Say 23 (second column, third row), you know like matrix indices in math:

....OnClick(Sender: TObject);
var
  ATag: Integer;
begin
  if (Sender is TComponent) then
  begin
    ATag := TComponent(Sender).Tag;
    ShowMessage(Format('Column %d, Row %d', [ATag div 10, ATag mod 10]));
  end;
end;

How to identify detail tables linked to a master table

Problem/Question/Abstract:

How can I retrieve the name of the detail tables of some master table? How can I know if a table has a detail table linked? Is there any property or function in the table or query to get the details they have?

Answer:

One way to identify linked detail tables is to scan the form or data module's components array:

for I := 0 to Pred(Component.Count) do
  if Components[I] is TTable then
    if TTable(Components[I]).DataSource <> nil then
      { do whatever }

How to embed binary data in an executable (3)

Problem/Question/Abstract:

Does anyone have experience using Delphi to create program that can create standalone exe that contains code and data like Picture2exe? This program creates a stand alone executable exe file that contains image and sound data that plays them in a slideshow. What is the approach and techniques used?

Answer:

Try this code where discclone.res includes the file you want to include:

procedure TMain.mnuCreateClick(Sender: TObject);
var
  MyFile: TFileStream;
  MyAppend: TMemoryStream;
begin
  if diagOpenSelf.Execute then
  begin
    if diagCreateSelf.Execute then
    begin
      CopyFile(PChar(ExtractFilePath(ParamStr(0)) + '\Extractor.exe'),
        PChar(diagCreateSelf.FileName), False);
      {Create a filestream object for the extractor executable}
      MyFile := TFileStream.Create(diagCreateSelf.FileName, $0002);
      try
        MyAppend := TMemoryStream.Create;
        try
          MyAppend.LoadFromFile(diagOpenSelf.FileName);
          MyFile.Seek(0, soFromEnd);
          MyFile.CopyFrom(MyAppend, 0);
          MessageBox(0, 'File was successfully created.', 'File Created',
            MB_OK + MB_ICONINFORMATION);
        finally
          MyAppend.Free;
        end;
      finally
        MyFile.Free;
      end;
    end;
  end;
end;

program Extractor;

{$R DiscClone.res}

uses
  Windows, Classes, ShellAPI, Sysutils;

const
  FileSize = 64512;
  {Or 60416. You may have to change to this number to the size of the
        compiled Extractor executable - minus the appended executable of course.}
var
  {MyExtract: TFileStream;}
  MyFile: TMemoryStream;
  TempStream: TMemoryStream;
  FileExe: string;
  Buffer: array[0..260] of Char;
  Count: DWord;
  Buf: Pointer;
  G: THandle;
  Res: LongBool;
begin
  { ... }
  {ask to make sure}
  { ... }
  {check floppy in drive}
  { ... }
  TempStream := TMemoryStream.Create;
  {Create the memory stream which will hold a copy of this executable in memory}
  MyFile := TMemoryStream.Create;
  try
    SetString(FileExe, Buffer, GetModuleFileName(0, Buffer,
      SizeOf(Buffer))); {What is the name of this executable?}
    MyFile.LoadFromFile(FileExe); {Load a copy of the executable into memory}
    {A filestream which will eventually create the HelloWorld program}
    // MyExtract := TFileStream.Create('dummy.floppy', fmCreate);
    try
      MyFile.Seek(FileSize, 0);
      Move the stream pointer to the start of the appended executable}
        {Copy the appended data to our filestream buffer - this creates the file}
    // MyExtract.CopyFrom(MyFile, MyFile.Size - FileSize);
      TempStream.CopyFrom(MyFile, MyFile.Size - FileSize);
    finally
      //  MyExtract.Free;  {Free the filestream object}
    end;
    {Tell the user that extraction went well and ask to run HelloWorld}
    G := CreateFile('\\.\A:', GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING,
                          FILE_ATTRIBUTE_NORMAL, 0);
    //  F := CreateFile(PChar('\\.\' + location), GENERIC_READ or GENERIC_WRITE,
                0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
    GetMem(Buf,1457664);  {1457664}
    //  SetFilePointer(F, 0, nil, FILE_BEGIN);
    //  ReadFile(F, Buf^, 1457664, Count, nil);
    //  Buf:=@MyExtract; //new
    WriteFile(G, Pointer(TempStream)^, 1457664, Count, nil);
    //  WriteFile(G, Buf^, 1457664, Count, nil);
    //  ShowMessage(IntToStr(GetLastError));
    FreeMem(Buf);
    //  CloseHandle(F);
    CloseHandle(G);
    
      {  G := CreateFile(PChar('\\.\C:\Work\Boot\TestCenter\Fred.txt'),
                                GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_ALWAYS,
                                FILE_ATTRIBUTE_NORMAL, 0);}
    G := CreateFile('\\.\A:', GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING,
      FILE_ATTRIBUTE_NORMAL, 0);
    GetMem(Buf, 1474560);
    TempStream.Position := 0;
    TempStream.Read(Buf^, 1474560);
    res := WriteFile(G, Buf^, 1474560, Count, nil);
    if not res then
      MessageBox(0, PChar(IntToStr(GetLastError)),
        PChar(SysErrorMessage(GetLastError)),
        MB_OK);
    CloseHandle(G);
    FreeMem(Buf);
    //  FlushFileBuffers(MyFileStream.Handle);
    MessageBox(0, PChar(IntToStr(TempStream.size)), 'Extraction successful!',
      MB_OK + MB_ICONQUESTION)
  finally
    {Free the memoerystream object}
    MyFile.Free;
  end;
  TempStream.Free;
end.