Open a WORD-document and replace Bookmarks with given Values

Problem/Question/Abstract:

An Example how to Open a WORD-Document and replace the bookmarks inside of it.

Answer:

here I try to give a detailed Example how to Open an existing WORD-document from the background of an application an replace bookmarks in this document with given text.

Global declarations:

TDocKapselWORD = class(TDocKapsel)
private
  OleWord: OLEVariant;
public
  function DocClose: Integer;
  function DocNew(VorlagenFilename: string): Integer;
  function ReplaceTM(TM_Name, Ergebnis: string): Integer;
  procedure Test;
end;

function TDocKapselWORD.DocNew(TemplateFilename: string): Integer;
// Opens the connection to WORD
// Returns 0 when ok, -1 on Error
var
  LocalWordDoc: OLEVariant;
  rtnCode: integer;
begin
  rtnCode := 0;
  // Is OLEWord still open? When yes, -> Error
  if VarIsEmpty(OLEWord) = FALSE then
    rtnCode := -1
  else
  begin
    try
      LocalWordDoc := CreateOleObject('WORD.Document');
    except
      // OLE-connection not successful
      rtnCode := -1;
    end;
    if rtnCode >= 0 then
    begin
      // New Document with given template
      LocalWordDoc.Application.Documents.Add(TemplateFilename);
      // Put new document in private variable
      OLEWord := LocalWordDoc.Application.ActiveDocument;
      LocalWordDoc.close();
      // Everything gone ok?
      if OLEWord.Application.Documents.Count > 0 then
        rtnCode := 0
      else
        RtnCode := -1;
    end;
  end;
  DocNew := rtnCode;
end;

function TDocKapselWORD.ReplaceTM(TM_Name, Ergebnis: string): Integer;
// Replaces Bookmark TM_Name with String Ergebnis
// returns 0 when ok, -1 on error.
begin
  if OLEWord.Bookmarks.exists(TM_Name) then
  begin
    OLEWord.Bookmarks.Item(TM_Name).Range.Text := Ergebnis;
    if OLEWord.Bookmarks.exists(TM_Name) then
      result := -1
    else
      result := 0
  end
  else
    result := -1;
end;

function TDocKapselWORD.DocClose: Integer;
// Closes Document and OLE-connection
// Returns 0 when ok, -1 on Error
var
  rtnCode: integer;
begin
  result := -1;
  if not VarIsEmpty(OleWord) then
  try
    OleWord.close();
    OleWord := unassigned;
    if VarIsEmpty(OleWord) then
      result := 0
    else
      result := -1;
  except
    OleWord := unassigned;
    result := -1;
  end;
end;

procedure TDocKapselWord.test;
var
  BMCount, BM: integer;
  MyBookmarks: array[1..42] of string;
  MyTexts: array[1..42] of string;
  rtnCode: integer
begin
  rtnCode := DocNew('TestFile.DOT');
  if rtnCode = 0 then
  begin // Go on only when Opened
    ...
      // Here You need to initialize the bookmarks: how many, what text to which
    // bookmark and so on. I suppose here, it's in two arrays!
    ...
      BM := 1
      repeat
      rtnCode := ReplaceTM(bookmarks[BM], texts[BM]);
      BM := BM + 1;
    until (BM > 42) or (rtnCode < 0);
    ...
      // Some Processing afterwards, perhaps print or save
    ...
      rtnCode := DocClose;
  end;
  ...
    // Some Processing, when it was or was not successful
  ...
end;

Stack Overflow error

Problem/Question/Abstract:

I was filling a Tree view from a huge number of hierarchical records. Inorder to keep them in hierarchy, I used
a recursive function. But after filling about 90%, a "Stack overflow" error occurred. How can I complete the operation.

Answer:

In Delphi, we can use the directive MAXSTACKSIZE to alter the Stack size.  Setting it to a large value causes more memory to be allocated in the stack

Eg:

{Include the following statement in your program}
{$MAXSTACKSIZE 999999}

Place text in the header or footer of a Word document

Problem/Question/Abstract:

Can someone tell me how to set the text in footers of MS Word documents programmatically from inside D5? I can create and open the document. I think it has to do with the BuiltInDocumentProperties. However, I cannot find a property for the document footer. Any ideas?

Answer:

Solve 1:

You can't access the header/ footer via BuiltInDocumentProperties. Use this instead:

Footer:

{ ... }
aDoc := WordApp.Documents.Add(EmptyParam, EmptyParam);
aDoc.Sections.Item(1).Footers.Item(wdHeaderFooterPrimary).Range.Text :=
  'This is a footer';
{ ... }

Header:

{ ... }
aDoc := WordApp.Documents.Add(EmptyParam, EmptyParam);
aDoc.Sections.Item(1).Headers.Item(wdHeaderFooterPrimary).Range.Text :=
  'This is a header';
{ ... }


Solve 2:

This works with Word 2000, and I can't remember it having changed since Word 97, anyway. If Doc is your Word document:

{ ... }
var
  Hdr: HeaderFooter;
  { ... }
  Hdr := Doc.Sections.Item(1).Headers.Item(wdHeaderFooterPrimary);
  Hdr.Range.Text := 'This is a header';
  { ... }

how to delete temporary Internet Files

Problem/Question/Abstract:

How to delete Temporary Internet files.

Answer:

uses
WinInet;

procedure DeleteIECache;
var
lpEntryInfo: PInternetCacheEntryInfo;
hCacheDir: LongWord;
dwEntrySize: LongWord;
begin
dwEntrySize := 0;
FindFirstUrlCacheEntry(nil, TInternetCacheEntryInfo(nil^), dwEntrySize);
GetMem(lpEntryInfo, dwEntrySize);
if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;
hCacheDir := FindFirstUrlCacheEntry(nil, lpEntryInfo^, dwEntrySize);
if hCacheDir <> 0 then
begin
repeat
DeleteUrlCacheEntry(lpEntryInfo^.lpszSourceUrlName);
FreeMem(lpEntryInfo, dwEntrySize);
dwEntrySize := 0;
FindNextUrlCacheEntry(hCacheDir, TInternetCacheEntryInfo(nil^), dwEntrySize);
GetMem(lpEntryInfo, dwEntrySize);
if dwEntrySize > 0 then lpEntryInfo^.dwStructSize := dwEntrySize;
until not FindNextUrlCacheEntry(hCacheDir, lpEntryInfo^, dwEntrySize);
end;
FreeMem(lpEntryInfo, dwEntrySize);
FindCloseUrlCache(hCacheDir);
end;


// Beispiel:
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
DeleteIECache;
end;

Extract FileName from Url

Problem/Question/Abstract:

How can I extract a FileName from a URL?  For example http://www.domain.com/file.zip -> file.zip

Answer:

Solve 1:

function ExtractUrlFileName(const AUrl: string): string;
var
I: Integer;
begin
I := LastDelimiter('\:/', AUrl);
Result := Copy(AUrl, I + 1, MaxInt);
end;


Solve 2:

You will just have to parse the string manually, ie:

Filename := '../../afolder/anotherfolder/aFilename.ext';
Pos := LastDelimiter('/\', Filename);
if (Pos > 0) then
Filename := Copy(Pos + 1, Length(Filename) - Pos, Filename);


Solve 3:

Filename := '../../afolder/anotherfolder/aFilename.ext';
Filename := StringReplace(Filename, '/', '\', [rfReplaceAll]);
Filename := ExtractFileName(Filename);


Solve 4:

You can treat a string as an array of characters and index individual characters in it with array notation. That allows you to write a loop that checks characters starting from the end of the string and walking backwards. Once you find the start of the filename you can use the Copy function to isolate it.

function GetFilenameFromUrl(const url: string): string;
var
i: Integer;
begin
Result := EmptyStr; // be a realist, assume failure
i := Length(url);
while (i > 0) and (url[i] <> '.') do
dec(i);

if i = 0 then
Exit; // no filename separator found

if AnsiCompareText(Copy(url, i, maxint), '.exe') <> 0 then
Exit; // no .exe at end of url

// find next '.' before current position
dec(i);
while (i > 0) and (url[i] <> '.') do
dec(i);

if i = 0 then
Exit; // no filename separator found
Result := Copy(url, i + 1, maxint);
end;

Give a listbox a rounded border

Problem/Question/Abstract:

How to give a listbox a rounded border

Answer:

To round a ListBox use CreateRoundRectRgn to shape it. Reduce the client size to reposition back in place. Experiment with the rounding value. The greater the round value the smoother it is.

Add a TListBox to a form

procedure TForm1.RoundListbox(var TheList: TListbox);
const
schange = 5;
rnd = 20;
var
thergn: HRGN;
mclient: TRect;
begin
mclient := TheList.ClientRect; {get size}
thergn := CreateRoundRectRgn(mclient.Left, mclient.top, mclient.right,
mclient.bottom, rnd, rnd);
TheList.BorderStyle := bsNone;
InflateRect(mclient, -schange, -schange); {shrink}
TheList.Perform(EM_SETRECTNP, 0, lparam(@mclient)); {change}
SetWindowRgn(TheList.Handle, thergn, true);
end;

Minimize an application by pressing [ALT] [TAB]

Problem/Question/Abstract:

I would like to be able to minimize my application if the user presses [ALT] + [TAB]. Will I need to hook the keyboard for this? There is lot of code around to disable [ALT] [TAB] but nothing to detect it.

Answer:

This works on WinNT SP3+, Win2K and WinXP:

{ ... }
var
FHook: HHook = 0;

const
WH_KEYBOARD_LL = 13;
LLKHF_ALTDOWN = KF_ALTDOWN shr 8;

type
tagKBDLLHOOKSTRUCT = packed record
vkCode: DWord;
scanCode: DWord;
flags: DWord;
time: DWord;
dwExtraInfo: PDWord;
end;
TKBDLLHOOKSTRUCT = tagKBDLLHOOKSTRUCT;
PKBDLLHOOKSTRUCT = ^TKBDLLHOOKSTRUCT;
{ ... }

function LowLevelKeyboardProc(HookCode: Longint; MessageParam: WParam;
StructParam: LParam): DWord; stdcall;
var
SwitchingTask: Boolean;
P: PKBDLLHOOKSTRUCT;
begin
SwitchingTask := False;
if (HookCode = HC_ACTION) then
case (MessageParam) of
WM_KEYDOWN, WM_SYSKEYDOWN, WM_KEYUP, WM_SYSKEYUP:
begin
P := PKBDLLHOOKSTRUCT(StructParam);
SwitchingTask := ((P.VKCode = VK_TAB) and (P.Flags and LLKHF_ALTDOWN <> 0))
or
((P.VKCode = VK_ESCAPE) and ((P.Flags and LLKHF_ALTDOWN) <> 0)) or
((P.VKCode = VK_ESCAPE) and ((GetKeyState(VK_CONTROL)
and $8000) <> 0));
end;
end;
if SwitchingTask then
begin
{If you want to disable task switch just uncomment next two lines}
// Result := 1;
// Exit;
{If not, put your code here...}
Application.Minimize;
end;
Result := CallNextHookEx(0, HookCode, MessageParam, StructParam);
end;

procedure SetHook;
begin
FHook := SetWindowsHookEx(WH_KEYBOARD_LL, @LowLevelKeyboardProc, Hinstance, 0);
end;

procedure UnHook;
begin
if FHook > 0 then
UnHookWindowsHookEx(FHook);
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
SetHook;
end;

procedure TMainForm.FormDestroy(Sender: TObject);
begin
UnHook;
end;

Connecting to Firebird DB

Problem/Question/Abstract:

How do i connect to a remote firebird database server?

Answer:

Firebird/Interbase Databases
A Firebird database is a single file - normally either *.fdb or *.gdb - all the tables are stored in that file.
To create a new alias, follow the instructions above, select the INTRBASE driver, and set the following parameters.

Property  Value  Comments
Server Name     This is the fully qualified *.fdb or *.gdb file
User Name  SYSDBA  For employee.gdb, the default password is masterkey

Warning:  If the focus is in an Opened Interbase/Firebird table when Object / New... is selected, it is possible that you will create a new table or a new field instead of a new alias.

To connect to a remote firebird server, you MUST include the drive letter after the computer name.

CompName:C:\Program Files\Common Files\Borland Shared\Data\employee.gdb

The Interbase help says that the following format is also acceptable in ISQL - but it definitely does NOT work in the Database Explore.
\\CompName\C:\Program Files\Common Files\Borland Shared\Data\employee.gdb

Firebird is the open source version of Borland's Interbase database server.

.

Write multiple values to a bookmark in Word

Problem/Question/Abstract:

How can I add rows at the end of a wordtable even when I have vertically merged cells? I always receive the error message "cannot access individual rows in this collection because the table has vertically merged cells"! The recorded word macro simple add a row by "selection.insertrows 1", but I have problems converting this into a Delphi statement (defining the right selection etc.).

Answer:

I've been automating MS Word, using bookmarks. Sometimes I need to write multiple values to one bookmark. I pass the values to the following routine as comma-text in the AValue parameter. It works fine with D5 using the Word97 unit and MS Word 2000 executable. Hope it helps.

{ ... }
FMSWord := CreateComObject(CLASS_WordApplication) as WordApplication;
{ ... }

procedure TLTWordDocHandler.PopulateListBookMark(const ABookMarkName:
  string; const AValue: Widestring);
var
  i: integer;
  LBMName: OleVariant;
  MoveUnit: OleVariant;
  NumRows: OleVariant;
  WorkingList: TStringList;
begin
  LBMName := ABookMarkName;
  FMSWord.ActiveDocument.Bookmarks.Item(LBMName).Select;
  if FMSWord.Selection.Tables.Count = 0 then
    raise Exception.Create(Format(sBookmarkNotInTable, [ABookmarkName]));
  MoveUnit := wdCell;
  NumRows := 1;
  WorkingList := TStringList.Create;
  try
    WorkingList.CommaText := AValue;
    for i := 0 to WorkingList.Count - 1 do
    begin
      FMSWord.Selection.TypeText(WorkingList.Strings[i]);
      if not (i = (WorkingList.Count - 1)) then
        FMSWord.Selection.MoveRight(MoveUnit, EmptyParam, EmptyParam);
          {97 & 2000 compliant}
    end;
  finally
    FreeAndNil(WorkingList);
  end;
end;

Web Pages about developing Winhelp and HTML help files

Problem/Question/Abstract:

Web Pages about developing Winhelp and HTML help files

Answer:

Helpmaster
Web site with lots of Winhelp/ HTML Help related information and links

Helpware Home Page
A web site focussing on HTML help

HTML Help Center
Samples, source code and tools for working with HTML Help

MSDN Online Library
Official Microsoft page with extensive information on HTML help

Richard Hendricks' Windows Help File Authoring Web Site
Many links to WinHelp and HTML Help related sources

VizAcc
Home of Help Jotter - a commercial WYSIWYG Windows help authoring tool creating all types of help files and printed manuals from the same data

Winhelp.net
Tips and information about developing Winhelp and HTML help files

WinWriters
Winhelp/ HTML Help related links and online help journal

Speed up some queries on my Microsoft SQL Server

Problem/Question/Abstract:

What can I do to speed up some queries on my Microsoft SQL Server?

Answer:

I have found that queries like:

select * from table1 innerjoin table2 on table1.field=table2.field

...sometimes will query quickly, but takes time to return a result.

The solution I have found to work is to insert the first query to a temporary table, then query the second, like:


select * into #temptable from table1 innerjoin table2 on table1.field=table2.field

select * from #temptable


The "#temptable" can be anything starting with the pound sign.  The temporary table will be released when your connection is closed.

I have found what I think is the answer here-- table locking.
When I query active tables, I fight with other applications having locks on various rows and tables.  When the query takes part into a temporary table, the lock is not there.

This article then has a really silly premise, I concur.

What should be used rather than temporary tables in a select statement is the "with (nolock)" feature that does a dirty read. Like:

select * from BigTable with (nolock)

rather than:
select * into #tempTable from BigTable

Format Float with Comma

Problem/Question/Abstract:

Format Float with Comma

Answer:

function FormatNum(Value: Extended; Decimal: Integer): string;
var
  SLen, SPos: Integer;
  SVal: string;
begin
  Str(Value: 0: Decimal, SVal);
  SLen := Length(SVal);
  if Decimal = 0 then
    SPos := SLen - 2
  else
    SPos := SLen - (Decimal + 3);
  while SPos > 1 do
  begin
    Insert(',', SVal, SPos);
    SPos := SPos - 3;
  end;
  Result := SVal;
end;

Also, you can simply do this:

i: Extended;
s: string;

i := 1000.123456;
s := Format('%.2n', [i]);

The value of s will be 1,000.12

You can also add your own characters, so you could do something like this:

s := Format('$%.2n', [i]);

This would output $1,000.12

So, good luck in your number to string formatting.

Next Position of a sub-string in a string

Problem/Question/Abstract:

The Pos funciton of Delphi returns the first occurence of a sub string within a string, only. How to get the positions of the next occurences?

Answer:

Solve 1:

This solution was developed using Borland Delphi 5 Service Pack 1. It is based upon the Pos algorithm delivered by Borland within the Systems unit, completely written in Assembler. !!!It might work with other versions of Borland Delphi (3.x, 4.x, 5.0) but has not been tested on them!!!

The syntax is similar to the syntax of the Pos function supplied by Delphi:

function NextPos(Substr: string; S: string; LastPos: DWORD = 0): DWORD;

NextPos returns the index value of the first character in a specified substring that occurs in a given string starting after the index value supplied by LastPos. LastPos may be omitted.

Note: As LastPos you should pass the position of the last occurence, not last position + 1. Just for convinience.

Here the commented Code:

function NextPos(SubStr: AnsiString; Str: AnsiString; LastPos: DWORD
  = 0): DWORD;
type
  StrRec = packed record
    allocSiz: Longint;
    refCnt: Longint;
    length: Longint;
  end;
const
  skew = sizeof(StrRec);

  asm
  // Search-String passed?
  TEST    EAX,EAX
  JE      @@noWork

  // Sub-String passed?
  TEST    EDX,EDX
  JE      @@stringEmpty

   // Save registers affected
PUSH ECX
PUSH EBX
PUSH ESI
PUSH EDI

// Load Sub-String pointer
MOV ESI, EAX
// Load Search-String pointer
MOV EDI, EDX
// Save Last Position in EBX
MOV EBX, ECX
// Get Search-String Length
MOV ECX, [EDI - skew].StrRec.length
// subtract Start Position
SUB ECX, EBX
// Save Start Position of Search String to return
PUSH EDI
// Adjust Start Position of Search String
ADD EDI, EBX
// Get Sub-String Length
MOV EDX, [ESI - skew].StrRec.length
// Adjust
DEC EDX
// Failed if Sub-String Length was zero
JS@@fail
// Pull first character of Sub-String for SCASB function
MOV AL, [ESI]
// Point to second character for CMPSB function
INC ESI
// Load character count to be scanned
SUB ECX, EDX
// Failed if Sub-String was equal or longer than Search-String
JLE@@fail
@@loop:
// Scan for first matching character
REPNE SCASB
// Failed, if none are matching
JNE@@fail
// Save counter
MOV EBX, ECX
PUSH ESI
PUSH EDI
// load Sub-String length
MOV ECX, EDX
// compare all bytes until one is not equal
REPE CMPSB
// restore counter
POP EDI
POP ESI
// all byte were equal, search is completed
JE@@found
// restore counter
MOV ECX, EBX
// continue search
JMP@@loop
@@fail:
// saved pointer is not needed
POP EDX
xor EAX, EAX
JMP@@exit
@@stringEmpty:
// return zero - no match
xor EAX, EAX
JMP@@noWork
@@found:
// restore pointer to start position of Search-String
POP EDX
// load position of match
MOV EAX, EDI
// difference between position and start in memory is
//   position of Sub
SUB EAX, EDX
@@exit:
// restore registers
POP EDI
POP ESI
POP EBX
POP ECX
@@noWork:
end;


Solve 2:

PosEx function:

function PosEx(SubStr: string; s: string; Index: DWord): DWord;
var
  I: Integer;
begin
  I := Pos(SubStr, Copy(s, Index, Length(s) - Index + 1));
  if I <> 0 then
    I := I + Index - 1;
  Result := I;
end;

The prarameter Index is the position you want to begin to search substr in s.

How to scroll a TTreeView?

Problem/Question/Abstract:

How to scroll a TTreeView?

Answer:

procedure TForm1.FormMouseWheelUp(Sender: TObject;
  Shift: TShiftState;
  MousePos: TPoint;
  var Handled: Boolean);

var
  iPos: Integer;

begin
  iPos := GetScrollPos(Form1.TreeView1.Handle, SB_VERT);
  SetScrollPos(Form1.TreeView1.Handle, SB_VERT, iPos - 1, True);
  // Don't set Handled to True otherwise the scrollbar scrolls
  // but the content of the TreeView does NOT scroll!
  // I have not found a way to check if the TreeView has a scrollbar or not.
  // Maybe if you first call:
  // GetScrollRange(Form1.TreeView1.Handle, SB_VERT,lpMinPos,lpMaxPos);
  // and then:
  // if MaxPos = 0 and MinPos = 0 then there is no vertical scrollbar
  // if MaxPos <> 0 then there is a vertical scrollbar
end;

Draw the caption of a TForm programmatically

Problem/Question/Abstract:

I need to be able to draw the text in a TForm's caption area manually, without using WM_SETTEXT (setting the TForm's Caption property, or using the API call SetWindowText, both use this method so they are unsuitable). I need functionality similar to DrawText where the text is drawn directly rather than sent to a message handler. Can anyone help?

Answer:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
  TForm1 = class(TForm)
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure WriteTexttoDC(WinHandle: HWND; Text: string; X, Y: Integer);
var
  DC: HDC;
begin
  DC := GetWindowDC(WinHandle);
  ExtTextOut(DC, 1, 1, ETO_CLIPPED, nil, PChar(Text), Length(Text), nil);
  ReleaseDC(WinHandle, DC);
end;

procedure TForm1.WMPaint(var Message: TWMPaint);
begin
  WriteTexttoDC(Handle, 'Is it OK?', 5, 5);
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  WriteTexttoDC(Handle, 'Is it OK?', 5, 5);
end;

end.

How to create a Paradox table with an AutoInc field at runtime

Problem/Question/Abstract:

How do I create a Paradox table with an Auto Increment type field programmatically? I'm using TTable.CreateTable, but TFieldType doesn't include this type.

Answer:

Use a TQuery and SQL CREATE TABLE statement. For example:

procedure TForm1.Button1Click(Sender: TObject);
begin
  with Query1 do
  begin
    DatabaseName := 'DBDemos';
    with SQL do
    begin
      Clear;
      Add('CREATE TABLE "PDoxTbl.db" (ID AUTOINC,');
      Add('Name CHAR(255),');
      Add('PRIMARY KEY(ID))');
      ExecSQL;
      Clear;
      Add('CREATE INDEX ByName ON "PDoxTbl.db" (Name)');
      ExecSQL;
    end;
  end;
end;

Remote Execute Function (Unix REXEC)

Problem/Question/Abstract:

Remote Execute Function (Unix REXEC)

Answer:

This function will execute a command to a Unix box (or any TCP connection that supports REXEC - port 512) and return the display results in a file. I currently use it on HP and SUN systems.

The parameters to RExec() are

  HostIP                                 : string               // eg. '196.11.121.160'          
  UserID                                 : string               // eg. 'root'
  Password                         : string                          // eg. 'fraqu34'
  Command                         : string                          // eg. 'export TERM=vt100; dv'
  ResultFilename         : string                           // eg. 'c:\temp\uxresult.txt'

The function returns true if sucessful, else false.

The command may contain multiple statements separated by semi-colons. REMEMBER : REXEC does not run the user .profile, so NO user environments are set. You can export  any environment settings in this parameter.

eg. 'export TERM=vt100; export APP=baan; run_mycommand'

An example of use is ....
(change to directory /var and return a dir listing and return results in file c:\temp\ux.txt)

procedure TForm1.Button1Click(Sender: TObject);
begin
  RExec('196.11.121.162',
    'root', 'passwd342',
    'cd /var; ls -1',
    'c:\temp\ux.txt');

  Memo1.Lines.LoadFromFile('c:\temp\ux.txt');
end;


uses ScktComp;

function RExec(const HostIP: string; const UserID: string;
  const Password: string; const Command: string;
  const ResultFilename: string): boolean;
var
  TCP: TClientSocket;
  i: integer;
  TxOut: file;
  Buffer, Cr, Lf: byte;
  Failed: boolean;
begin
  Failed := true; // Assume initial error state
  Cr := 13; // Carriage Return Char
  Lf := 10; // Line Feed Char
  TCP := TClientSocket.Create(nil);

  try
    TCP.Address := HostIP;
    TCP.ClientType := ctBlocking;
    TCP.Port := 512; // REXEC port
    TCP.Open;

    // Give time to connect
    for i := 1 to 500 do
      if not TCP.Active then
        Sleep(100)
      else
        break;

    // If TCP opened OK then send the command to host
    // and write results to specified file
    if TCP.Active then
    begin
      AssignFile(TxOut, ResultFileName);
      Rewrite(TxOut, 1);
      TCP.Socket.SendText('0' + #0);
      TCP.Socket.SendText(UserID + #0);
      TCP.Socket.SendText(Password + #0);
      TCP.Socket.SendText(Command + #0);
      TCP.Socket.SendText(#13);
      Sleep(20); // Give a gap to respond

      // Wait for resonse from Host
      // You may want to check for timeout here using
      // a TTimer. My complete function does this, but
      // have omitted for sake of clarity.
      while (TCP.Socket.ReceiveBuf(Buffer, 1) <> 1) do
        Application.ProcessMessages;

      // Write host byte stream to file
      while TCP.Socket.ReceiveBuf(Buffer, 1) = 1 do
      begin
        if (Buffer = 10) then
        begin
          BlockWrite(TxOut, Cr, 1);
          BlockWrite(TxOut, Lf, 1);
        end
        else
          BlockWrite(TxOut, Buffer, 1);
      end;

      TCP.Close;
      CloseFile(TxOut);
      Failed := false;
    end;
  finally
    TCP.Free;
  end;

  Result := not Failed;
end;

Play WAV files

Problem/Question/Abstract:

Play WAV files

Answer:

You can use the mci commands (easy using the mciSendString() routine) or - even easier, this:

uses
  MMSystem;

var
  s: array[0..79] of char;
begin
  StrCopy(s, 'ding.wav');
  sndPlaySound(s, 0);
end;

Get the server (router) and client IP address of your dial up connection

Problem/Question/Abstract:

There are quite a lot of articles on retrieving IP addresses for LAN interfaces. Here's one for dialup using RAS(Remote Access Services). Note that it requires header files which are available from Delphi JEDI site

Answer:

Please note that the program uses ras.pas and other header files which are available in the API library of delphi jedi site. The complete project having all the header files is being provided to the webmaster for update.

It displays the server and client IP every second on a label.

unit uMain;

interface

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

type
  TfrmMain = class(TForm)
    lblIP: TLabel;
    tmrUpdate: TTimer;
    procedure tmrUpdateTimer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

uses Ras, RasError;

{$R *.DFM}

procedure GetDialUpIpAddress(var server, client: string);
var
  RASPppIp: RASIP;
  lpcp: DWORD;
  ConnClientIP: array[0..RAS_MaxIpAddress] of Char;
  ConnServerIP: array[0..RAS_MaxIpAddress] of Char;

  Entries: PRasConn;
  BufSize, NumberOfEntries, Res: DWORD;
  RasConnHandle: THRasConn;
begin
  New(Entries);
  BufSize := Sizeof(Entries^);
  ZeroMemory(Entries, BufSize);
  Entries^.dwSize := Sizeof(Entries^);

  Res := RasEnumConnections(Entries, BufSize, NumberOfEntries);
  if Res = ERROR_BUFFER_TOO_SMALL then
  begin
    ReallocMem(Entries, BufSize);
    ZeroMemory(Entries, BufSize);
    Entries^.dwSize := Sizeof(Entries^);
    Res := RasEnumConnections(Entries, BufSize, NumberOfEntries);
  end;
  try
    if (Res = 0) and (NumberOfEntries > 0) then
      RasConnHandle := Entries.hrasconn
    else
      exit
  finally
    FreeMem(Entries);
  end;

  FillChar(RASPppIp, SizeOf(tagRASIP), 0);
  RASPppIp.dwSize := SizeOf(tagRASIP);
  lpcp := RASPppIp.dwSize;
  if RasGetProjectionInfo(RasConnHandle,
    RASP_PppIp, @RasPppIp, lpcp) = 0 then
  begin

    Move(RASPppIp.szServerIpAddress,
      ConnServerIP,
      SizeOf(ConnServerIP));
    Server := ConnServerIP;
    Move(RASPppIp.szIpAddress,
      ConnClientIP,
      SizeOf(ConnClientIP));
    client := ConnClientIP;
  end;
end;

procedure TfrmMain.tmrUpdateTimer(Sender: TObject);
var
  ConnServerIP, ConnClientIP: string;
begin
  GetDialUpIpAddress(ConnServerIP, ConnClientIP);
  if ConnServerIP = '' then
    ConnServerIP := 'NA';
  if ConnClientIP = '' then
    ConnClientIP := 'NA';
  lblIP.Caption := Format('Server : %s'#13#10'Client   : %s', [ConnServerIP,
    ConnClientIP])
end;

Viewing PCX File Format in Delphi (256-colors)

Problem/Question/Abstract:

How to show bitmap in pcx file format using Delphi ??

Answer:

This is quite simple way to answer above question: viewing pcx file format using Delphi. But this answer is limited only for 256-colors image (pcx image).

Here is the example code for the answer :

type
  TArrBuff = array[1..512] of Byte;
  TPalette_Cell = record
    r, g, b: byte;
  end;
  TPal = array[0..255] of TPalette_Cell;
  TPPal = ^TPal;

  TPCX_Header = record // PCX Header
    Manufacture, Version, Encoding, BpPixel: Byte;
    XMin, YMin, XMax, YMax, Hdpi, Vdpi: Smallint;
    ColorMap: array[0..15, 0..2] of Byte;
    Reserved, Nplanes: Byte;
    BpLpPlane, PaletteInfo, HScreenSize, VScreenSize: Smallint;
    Filer: array[74..127] of Byte;
  end;

var
  pal: TPPal;
  pFile: file;
  FPcxHeader: TPCX_Header;
  buffer: TArrBuff;

procedure THPPcx.ReadImageData2Bitmap;
var
  X, Y: Integer;
  i, Loop: Byte;
  data: Word;
  tmpClr: TColor;
begin
  X := FPcxHeader.XMin;
  Y := FPcxHeader.YMin;
  data := 1;
  BlockRead(pFile, Buffer, SizeOf(Buffer));
  while (Y <= FPcxHeader.YMax) do
  begin
    if (Buffer[data] and $C0) = $C0 then
    begin
      Loop := Buffer[data] and $3F;
      if data < SizeOf(Buffer) then
        Inc(data)
      else
      begin
        data := 1;
        BlockRead(pFile, Buffer, SizeOf(Buffer));
      end;
    end
    else
      Loop := 1;
    for i := 1 to Loop do
    begin
      tmpClr := rgb(pal^[Buffer[data]].R, pal^[Buffer[data]].G, pal^[Buffer[data]].B);
      SetPixel(Bitmap.Canvas.Handle, x, y, tmpClr);
      Inc(X);
      if X = FPcxHeader.BpLpPlane then
      begin
        X := FPcxHeader.XMin;
        Inc(Y);
      end;
    end;
    if data < SizeOf(Buffer) then
      Inc(data)
    else
    begin
      data := 1;
      BlockRead(pFile, Buffer, SizeOf(Buffer));
    end;
  end;
end;

procedure THPPCX.LoadFromFile(const FileName: string);
begin
  AssignFile(pFile, FileName);
{$I-}Reset(pFile, 1);
{$I+}
  if IOResult = 0 then
  begin
    BlockRead(pFile, FPcxHeader, SizeOf(FPcxHeader));
    if FPcxHeader.Manufacture = 10 then
    begin // valid pcx header id
      Bitmap.Width := FPcxHeader.XMax;
      Bitmap.Height := FPcxHeader.YMax;
      GetMem(pal, 768);
      try
        Seek(pFile, FileSize(pFile) - 768); // palette position
        BlockRead(pFile, pal^, 768);
        Seek(pFile, SizeOf(FPcxHeader)); // image data position
        ReadImageData2Bitmap;
      finally
        FreeMem(pal);
      end;
    end
    else
      MessageBox(Application.Handle, 'Not A Valid PCX File Format',
        'PCX Viewer Error', MB_ICONHAND);
    CloseFile(pFile);
  end
  else
    MessageBox(Application.Handle, 'Error Opening File', 'PCX Viewer Error',
      MB_ICONHAND);
end;

How to try this code ?? Just call the "LoadFromFile" procedure above in your application (probably with little modification offcourse, especially about the name of mainForm that I used here [THPPCX]).

Hopefully It can help you.

For full source code and simple application that use this, you can look and download from my website: www.geocities.com/h4ryp/delphi.html

How to use an animated cursor to your application

Problem/Question/Abstract:

How to use an animated cursor to your application

Answer:

Using animated cursors in your application is very easy.

Here's an example:

mycursor.ani is an animated cursor file. You can create those with Microsoft's aniedit.exe


const
  crMyCursor = 1;

procedure TForm1.FormCreate(Sender: TObject);
begin
  // Load the cursor. Needs to be done only once
  Screen.Cursors[crMyCursor] := LoadCursorFromFile('c:\mystuff\mycursor.ani');
  // Use the cursor with this form
  Cursor := crMyCursor;
end;

Change the font color of a specific row in a TListView

Problem/Question/Abstract:

How to change the font color of a specific row in a TListView

Answer:

Use the events OnCustomDrawItem and OnCustomDrawSubItem:

procedure TForm1.ListView1CustomDrawItem(Sender: TCustomListView;
  Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
  if (Item.Index mod 2) = 0 then
    Sender.Canvas.Font.Color := clRed
  else
    Sender.Canvas.Font.Color := clBlack;
end;

Share memory among several instances of a DLL

Problem/Question/Abstract:

Share memory among several instances of a DLL

Answer:

The DB unit in the 32-bit version has some examples of how it's done in general.

Basically, in 32-bit mode a DLL is mapped into each process's address space, not an address space of its own, so that it cannot share memory simply by virtue of being a DLL. You must use some kind of shared memory object -- such as shared memory, or a memory-mapped file -- and employ semaphores to properly synchronize access to it.

Have a window stay on top all the time

Problem/Question/Abstract:

Have a window stay on top all the time

Answer:

The following code results in a window that stays on top all the time, even when the main application form is in the background:


Minitool := TMinitool.Create(Self);
Application.NormalizeTopMosts;
SetWindowPos(Minitool.Handle, HWND_TOPMOST, 0, 0, 0, 0,
  SWP_NOACTIVATE + SWP_NOMOVE + SWP_NOSIZE);
Minitool.Show;

How to create an array of buttons at runtime

Problem/Question/Abstract:

How to create an array of buttons at runtime

Answer:

Here is a unit that creates a row of buttons and a label at run time and displays which button is clicked on. All you need to do is start a new project, then paste all the code below into Unit1.

unit Unit1;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure ButtonClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

const
  b = 4; {Total number of buttons to create}

var
  ButtonArray: array[0..b - 1] of TButton; {Set up an array of buttons}
  MessageBox: TLabel;

procedure TForm1.FormCreate(Sender: TObject);
var
  loop: integer;
begin
  {Size the form to fit all the components in}
  ClientWidth := (b * 60) + 10;
  ClientHeight := 65;
  MessageBox := TLabel.Create(Self); {Create a label...}
  MessageBox.Parent := Self;
  MessageBox.Align := alTop; {...set up it's properties...}
  MessageBox.Alignment := taCenter;
  MessageBox.Caption := 'Press a Button';
  for loop := 0 to b - 1 do {Now create all the buttons}
  begin
    ButtonArray[loop] := TButton.Create(Self);
    with ButtonArray[loop] do
    begin
      Parent := self;
      Caption := IntToStr(loop);
      Width := 50;
      Height := 25;
      Top := 30;
      Left := (loop * 60) + 10;
      Tag := loop; {Used to tell which button is pressed}
      OnClick := ButtonClick;
    end;
  end;
end;

procedure TForm1.ButtonClick(Sender: TObject);
var
  t: Integer;
begin
  t := (Sender as TButton).Tag; {Get the button number}
  MessageBox.Caption := ' You pressed Button ' + IntToStr(t);
end;

end.

Implement tooltips in a TListView

Problem/Question/Abstract:

Is there a possibility to get tooltips in a common TListView component under Delphi 4.0? I want to display details if the user moves the mouse over an item and wait a little (same function like the component names in Delphi, if you move your mouse over a component).

Answer:

There is an event handler in Delphi 5, which makes it possible for you to get tooltips for each item of a ListView easily: TListView.OnInfoTip. In Delphi 3 and 4, you have to write your own hint event handler, which you assign to the method OnShowHint of TApplication:

unit Test_u1;
{ ... }

type
  TForm1 = class(TForm)
    ListView1: TListView;
    { ... }
  private
    procedure DisplayHint(var HintStr: string; var CanShow: Boolean; var HintInfo:
      THintInfo);
  end;

  { ... }

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var
  NewItem: TListItem;
begin
  Application.OnShowHint := DisplayHint;
  { ... }
end;

procedure TForm1.DisplayHint;
var
  Item: TListItem;
  Rect: TRect;
begin
  CanShow := true;
  {Trace the item of ListView1, which is found on the mouse position X, Y.
        If the mouse isn't dragged over a item, result will be nil.}
  Item := ListView1.GetItemAt(HintInfo.CursorPos.X, HintInfo.CursorPos.Y);
  if Item <> nil then
  begin
    Rect := Item.DisplayRect(drBounds); {in coordinates of ListView1!}
    HintInfo.HintStr := 'Mouse is over Item ' + Item.Caption;
  end
  else
  begin
    Rect := ActiveControl.ClientRect;
    HintInfo.HintStr := GetShortHint(TControl(ActiveControl).Hint);
  end;
  { Converting into coordinates of screen. }
  Rect.TopLeft := ActiveControl.ClientToScreen(Rect.TopLeft);
  Rect.BottomRight := ActiveControl.ClientToScreen(Rect.BottomRight);
  with HintInfo do
  begin
    HintPos.Y := Rect.Top + GetSystemMetrics(SM_CYCURSOR);
    HintPos.X := Rect.Left + GetSystemMetrics(SM_CXCURSOR);
    HintMaxWidth := TControl(ActiveControl).ClientWidth;
    HintColor := clInfoBk;
    ReshowTimeout := 10;
    HideTimeout := 100;
  end;
end;

end.

BTW: The type THintInfo is used to define the appearance and the function of the HintWindow:

type
  THintWindowClass = class of THintWindow;

  THintInfo = record
    HintControl: TControl;
    HintWindowClass: THintWindowClass;
    HintPos: TPoint;
    HintMaxWidth: Integer;
    HintColor: TColor;
    CursorRect: TRect;
    CursorPos: TPoint;
    ReshowTimeout: Integer;
    HideTimeout: Integer;
    HintStr: string;
    HintData: Pointer;
  end;

How to flip the characters in a string

Problem/Question/Abstract:

How to flip the characters in a string

Answer:

If you want to take "Hello" and make it "olleH" then use the following:

procedure Flip(A: string);
var
  t: Integer;
begin
  Result := '';
  for t := Length(A) downto 1 do
    Result := Result + A[t];
end;

If you want to take "abcd" and make it "zyxw" then use the following:

procedure Flip(A: string);
var
  t: Integer;
begin
  Result := '';
  A := Uppercase(A); {develop others for lower case}
  for t := 1 to Length(A) do
    Result := Result + CHR(91 - (ORD(A[t]) - 65));
end;

Filter operation on a lookup field

Problem/Question/Abstract:

How can I filter on a lookup field in a dataset?

Answer:

You cannot use the lookup field's name in the filter string, but you can use an OnFilterRecord event handler instead.

Recompile a component that is in a package

Problem/Question/Abstract:

Recently I had downloaded an updated freeware component and wanted to recompile the package in which I kept that one. The question was: in which package did I put this component?

Answer:

Choose menu item "Component | Configure Palette" or right click on the component palette and then choose Properties. A dialog with an overview comes up - sort it by component name and see the package name in the second column. Open this package and recompile it.

Adding Explorer ToolBar Btn

Problem/Question/Abstract:

Creating  Explorer ToolBar Button

Answer:

type
  TConnType = (COM_OBJECT, EXPLORER_BAR, SCRIPT, EXECUTABLE);

function AddBandToolbarBtn(Visible: Boolean; ConnType: TConnType;
  BtnText, HotIcon, Icon, GuidOrPath: string): string;
var
  GUID: TGUID;
  Reg: TRegistry;
  ID: string;
begin
  CreateGuid(GUID);
  ID := GuidToString(GUID);
  Reg := TRegistry.Create;
  with Reg do
  try
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey('\Software\Microsoft\Internet Explorer\Extensions\'
      + ID, True);
    if Visible then
      WriteString('Default Visible', 'Yes')
    else
      WriteString('Default Visible', 'No');
    WriteString('ButtonText', BtnText);
    WriteString('HotIcon', HotIcon);
    WriteString('Icon', Icon);
    case ConnType of
      COM_OBJECT:
        begin
          WriteString('CLSID', '{1FBA04EE-3024-11d2-8F1F-0000F87ABD16}');
          WriteString('ClsidExtension', GuidOrPath);
        end;
      EXPLORER_BAR:
        begin
          WriteString('CLSID', '{E0DD6CAB-2D10-11D2-8F1A-0000F87ABD16}');
          WriteString('BandCLSID', GuidOrPath);
        end;
      EXECUTABLE:
        begin
          WriteString('CLSID', '{1FBA04EE-3024-11D2-8F1F-0000F87ABD16}');
          WriteString('Exec', GuidOrPath);
        end;
      SCRIPT:
        begin
          writeString('CLSID', '{1FBA04EE-3024-11D2-8F1F-0000F87ABD16}');
          WriteString('Script', GuidOrPath);
        end;
    end;
    CloseKey;
    OpenKey('\Software\IE5Tools\ToolBar Buttons\', True);
    WriteString(BtnText, ID);
    CloseKey;
  finally
    Free;
  end;
  Result := ID;
end;