Using Microsoft Index Server from Delphi

Problem/Question/Abstract:

Many people has asked how to search inside an index server from Microsoft in order to show the results like a normal dataset. Here's how this can be done and some considerations on the use & misuse of this technology

Answer:

What is Index Server

Index Server is the web-based solution choosen by Microsoft to give its IIS server the ability to search and retrieve documents; as it is concieved for use with ASP pages, it is strongly based on COM technology and in its latest release has been fully integrated also with the ADO technology.

First Steps

I will demonstrate how to leverage on ADO in order to search the directories of the default catalog of the main website; to search another catalog you will just change an option.
First of all you should get the Microsoft primer on Index Server at:

http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnindex/html/msdn_is-intro.asp

With this link you wil lfind the explanation necessary to use the index server; using it is anyway easy.
To start it just go inside the Microsoft Management Console (MMC) and open inside it the services; the Microsoft Index Server Service is listed here, just right click to view the contextual menu and choose from it the "Start" option; if you want you can have it start automatically on every boot, just choose the properties of the listed item and choose "Auto Start" from the combo box.
You can have more than 1 catalog to search within; top add new catalogues you should open the MMC for IIS and work from it, but remember that this works only with Nt4/W2K server, not workstation, as in Nt4/W2K wkst only 1 web site is allowed.
BTW: The default catalog is named "WEB".

ADO integration

Let's get our feet wet... We will build a form with a text field and a db grid in which you will see the results of your search, just like using a normal database like access or sql server
First of all open a brand new Delphi Project; add a ADQuery & ADOConncetion couple on the form, together with a Datasource and a DBGrid. You will also need a button and a Edit component.
After these veru first steps, double click on the connectionstring property of the ADOCOnnection1 component; it will open the standard box; from the list of OLEDB Providers you should find (if your ADO is up to date) choose:
"Microsoft OleDb Provider for Indexing Services"; with a double click you will have access to the advanced options, which are already setted correctly; if you want to change the catalogue, just modify the text in the "data source" field. Click on "Test connection", everything should work.

Connect together as usual the components:

Adoquery1 -> Adoconnection1
Datasource1 -> Adoquery1
DBGRID1 -> Datasource1

I suggest of course to keep Adoconnection1.loginprompt := False and to open the connection asap (I made this at design time).

and then double click on th Button you already placed on the form in the first step; the event handler is as follows, just copy and paste:

var
  tmp: string;
begin
  if ADOQuery2.active then
    ADOQuery2.close;
  tmp := 'Select DocTitle, path, rank, size, Vpath, write FROM scope() WHERE
         CONTAINS(''' + edit1.text + ''') > 0 ORDER by FileName';
  ADOQuery2.sql.text := tmp;
  ADOQuery2.Open;
end;

now you have finished: just run the application and type "note" inside the text field, it should show you 3/4 records inside the dbgrid, with the records showing the file names, path etc etc.

Pros & Cons

PROS

You can integrate searched made on Index server and other data repositories like Access files... this can be very useful for sites based upon dynamic page creation technology.
Zero administration
Perfect for ASP objects made in Delphi and for CGIs

CONS

First of all there is a bug in the ADOQuery implementation by Borland, changing the SQL property of the ADOQUERY may result in error messages at design time; it is a confirmed bug, anyway everything works perfectly on runtime. So don't worry for this; maybe a patch will be given to Delphi user, otherwise you can try other ways (Using native ADO as COM objects resolve the problem)
Second: Index Server is tigtly integrated with IIS so you can search only web catalogues, not particular directories of you file system.


Component Download: http://www.dreamscapeitalia.com/download/delphi_index_server.zip

Sending Raw IP Packets

Problem/Question/Abstract:

How can I send raw IP Packets?

Answer:

This example just showes how to send an UDP packet with customized (spoofed) source ip+port.

Using raw sockets you can SEND raw packets over the internet containing whatever you like.

Keep in mind:

This only works under Window 2000.

You can SEND raw packets. You can NOT RECEIVE raw packets.

You must be Administrator to run this.

This unit requires a form containing a button and a memo.


Usage:

Before you run your program, you must change the SrcIP+SrcPort+ DestIP+DestPort to suitable values!

If you don't understand what this source does: Don't use it.

unit main;

interface

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

const
  SrcIP = '123.123.123.1';
  SrcPort = 1234;
  DestIP = '123.123.123.2';
  DestPort = 4321;

  Max_Message = 4068;
  Max_Packet = 4096;

type

  TPacketBuffer = array[0..Max_Packet - 1] of byte;

  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure SendIt;
  end;

  // IP Header
type
  T_IP_Header = record
    ip_verlen: Byte;
    ip_tos: Byte;
    ip_totallength: Word;
    ip_id: Word;
    ip_offset: Word;
    ip_ttl: Byte;
    ip_protocol: Byte;
    ip_checksum: Word;
    ip_srcaddr: LongWord;
    ip_destaddr: LongWord;
  end;

  // UDP Header
type
  T_UDP_Header = record
    src_portno: Word;
    dst_portno: Word;
    udp_length: Word;
    udp_checksum: Word;
  end;

  // Some Winsock 2 type declarations
  u_char = Char;
  u_short = Word;
  u_int = Integer;
  u_long = Longint;

  SunB = packed record
    s_b1, s_b2, s_b3, s_b4: u_char;
  end;
  SunW = packed record
    s_w1, s_w2: u_short;
  end;
  in_addr = record
    case integer of
      0: (S_un_b: SunB);
      1: (S_un_w: SunW);
      2: (S_addr: u_long);
  end;
  TInAddr = in_addr;
  Sockaddr_in = record
    case Integer of
      0: (sin_family: u_short;
        sin_port: u_short;
        sin_addr: TInAddr;
        sin_zero: array[0..7] of Char);
      1: (sa_family: u_short;
        sa_data: array[0..13] of Char)
  end;
  TSockAddr = Sockaddr_in;
  TSocket = u_int;

const
  WSADESCRIPTION_LEN = 256;
  WSASYS_STATUS_LEN = 128;

type
  PWSAData = ^TWSAData;
  WSAData = record // !!! also WSDATA
    wVersion: Word;
    wHighVersion: Word;
    szDescription: array[0..WSADESCRIPTION_LEN] of Char;
    szSystemStatus: array[0..WSASYS_STATUS_LEN] of Char;
    iMaxSockets: Word;
    iMaxUdpDg: Word;
    lpVendorInfo: PChar;
  end;
  TWSAData = WSAData;

  // Define some winsock 2 functions
function closesocket(s: TSocket): Integer; stdcall;
function socket(af, Struct, protocol: Integer): TSocket; stdcall;
function sendto(s: TSocket; var Buf; len, flags: Integer; var addrto: TSockAddr;
  tolen: Integer): Integer; stdcall; {}
function setsockopt(s: TSocket; level, optname: Integer; optval: PChar;
  optlen: Integer): Integer; stdcall;
function inet_addr(cp: PChar): u_long; stdcall; {PInAddr;} { TInAddr }
function htons(hostshort: u_short): u_short; stdcall;
function WSAGetLastError: Integer; stdcall;
function WSAStartup(wVersionRequired: word; var WSData: TWSAData): Integer; stdcall;
function WSACleanup: Integer; stdcall;

const
  AF_INET = 2; // internetwork: UDP, TCP, etc.

  IP_HDRINCL = 2; // IP Header Include

  SOCK_RAW = 3; // raw-protocol interface

  IPPROTO_IP = 0; // dummy for IP
  IPPROTO_TCP = 6; // tcp
  IPPROTO_UDP = 17; // user datagram protocol
  IPPROTO_RAW = 255; // raw IP packet

  INVALID_SOCKET = TSocket(not (0));
  SOCKET_ERROR = -1;

var
  Form1: TForm1;

implementation

// Import Winsock 2 functions
const
  WinSocket = 'WS2_32.DLL';

function closesocket; external winsocket name 'closesocket';
function socket; external winsocket name 'socket';
function sendto; external winsocket name 'sendto';
function setsockopt; external winsocket name 'setsockopt';
function inet_addr; external winsocket name 'inet_addr';
function htons; external winsocket name 'htons';
function WSAGetLastError; external winsocket name 'WSAGetLastError';
function WSAStartup; external winsocket name 'WSAStartup';
function WSACleanup; external winsocket name 'WSACleanup';

{$R *.DFM}

//
// Function: checksum
//
// Description:
//    This function calculates the 16-bit one's complement sum
//    for the supplied buffer
//

function CheckSum(var Buffer; Size: integer): Word;
type
  TWordArray = array[0..1] of Word;
var
  ChkSum: LongWord;
  i: Integer;
begin
  ChkSum := 0;
  i := 0;
  while Size > 1 do
  begin
    ChkSum := ChkSum + TWordArray(Buffer)[i];
    inc(i);
    Size := Size - SizeOf(Word);
  end;

  if Size = 1 then
    ChkSum := ChkSum + Byte(TWordArray(Buffer)[i]);

  ChkSum := (ChkSum shr 16) + (ChkSum and $FFFF);
  ChkSum := ChkSum + (Chksum shr 16);

  Result := Word(ChkSum);
end;

procedure BuildHeaders(
  FromIP: string;
  iFromPort: Word;
  ToIP: string;
  iToPort: Word;
  StrMessage: string;
  var Buf: TPacketBuffer;
  var remote: TSockAddr;
  var iTotalSize: Word
  );
var
  dwFromIP: LongWord;
  dwToIP: LongWord;

  iIPVersion: Word;
  iIPSize: Word;
  ipHdr: T_IP_Header;
  udpHdr: T_UDP_Header;

  iUdpSize: Word;
  iUdpChecksumSize: Word;
  cksum: Word;

  Ptr: ^Byte;

  procedure IncPtr(Value: Integer);
  begin
    ptr := pointer(integer(ptr) + Value);
  end;

begin
  // Convert ip address'ss

  dwFromIP := inet_Addr(PChar(FromIP));
  dwToIP := inet_Addr(PChar(ToIP));

  // Initalize the IP header
  //
  iTotalSize := sizeof(ipHdr) + sizeof(udpHdr) + length(strMessage);

  iIPVersion := 4;
  iIPSize := sizeof(ipHdr) div sizeof(LongWord);
  //
  // IP version goes in the high order 4 bits of ip_verlen. The
  // IP header length (in 32-bit words) goes in the lower 4 bits.
  //
  ipHdr.ip_verlen := (iIPVersion shl 4) or iIPSize;
  ipHdr.ip_tos := 0; // IP type of service
  ipHdr.ip_totallength := htons(iTotalSize); // Total packet len
  ipHdr.ip_id := 0; // Unique identifier: set to 0
  ipHdr.ip_offset := 0; // Fragment offset field
  ipHdr.ip_ttl := 128; // Time to live
  ipHdr.ip_protocol := $11; // Protocol(UDP)
  ipHdr.ip_checksum := 0; // IP checksum
  ipHdr.ip_srcaddr := dwFromIP; // Source address
  ipHdr.ip_destaddr := dwToIP; // Destination address
  //
  // Initalize the UDP header
  //
  iUdpSize := sizeof(udpHdr) + length(strMessage);

  udpHdr.src_portno := htons(iFromPort);
  udpHdr.dst_portno := htons(iToPort);
  udpHdr.udp_length := htons(iUdpSize);
  udpHdr.udp_checksum := 0;
  //
  // Build the UDP pseudo-header for calculating the UDP checksum.
  // The pseudo-header consists of the 32-bit source IP address,
  // the 32-bit destination IP address, a zero byte, the 8-bit
  // IP protocol field, the 16-bit UDP length, and the UDP
  // header itself along with its data (padded with a 0 if
  // the data is odd length).
  //
  iUdpChecksumSize := 0;

  ptr := @buf[0];
  FillChar(Buf, SizeOf(Buf), 0);

  Move(ipHdr.ip_srcaddr, ptr^, SizeOf(ipHdr.ip_srcaddr));
  IncPtr(SizeOf(ipHdr.ip_srcaddr));

  iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_srcaddr);

  Move(ipHdr.ip_destaddr, ptr^, SizeOf(ipHdr.ip_destaddr));
  IncPtr(SizeOf(ipHdr.ip_destaddr));

  iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_destaddr);

  IncPtr(1);

  Inc(iUdpChecksumSize);

  Move(ipHdr.ip_protocol, ptr^, sizeof(ipHdr.ip_protocol));
  IncPtr(sizeof(ipHdr.ip_protocol));
  iUdpChecksumSize := iUdpChecksumSize + sizeof(ipHdr.ip_protocol);

  Move(udpHdr.udp_length, ptr^, sizeof(udpHdr.udp_length));
  IncPtr(sizeof(udpHdr.udp_length));
  iUdpChecksumSize := iUdpChecksumSize + sizeof(udpHdr.udp_length);

  move(udpHdr, ptr^, sizeof(udpHdr));
  IncPtr(sizeof(udpHdr));
  iUdpChecksumSize := iUdpCheckSumSize + sizeof(udpHdr);

  Move(StrMessage[1], ptr^, Length(strMessage));
  IncPtr(Length(StrMessage));

  iUdpChecksumSize := iUdpChecksumSize + length(strMessage);

  cksum := checksum(buf, iUdpChecksumSize);
  udpHdr.udp_checksum := cksum;

  //
  // Now assemble the IP and UDP headers along with the data
  //  so we can send it
  //
  FillChar(Buf, SizeOf(Buf), 0);
  Ptr := @Buf[0];

  Move(ipHdr, ptr^, SizeOf(ipHdr));
  IncPtr(SizeOf(ipHdr));
  Move(udpHdr, ptr^, SizeOf(udpHdr));
  IncPtr(SizeOf(udpHdr));
  Move(StrMessage[1], ptr^, length(StrMessage));

  // Apparently, this SOCKADDR_IN structure makes no difference.
  // Whatever we put as the destination IP addr in the IP header
  // is what goes. Specifying a different destination in remote
  // will be ignored.
  //
  remote.sin_family := AF_INET;
  remote.sin_port := htons(iToPort);
  remote.sin_addr.s_addr := dwToIP;
end;

procedure TForm1.SendIt;
var
  sh: TSocket;
  bOpt: Integer;
  ret: Integer;
  Buf: TPacketBuffer;
  Remote: TSockAddr;
  Local: TSockAddr;
  iTotalSize: Word;
  wsdata: TWSAdata;

begin
  // Startup Winsock 2
  ret := WSAStartup($0002, wsdata);
  if ret <> 0 then
  begin
    memo1.lines.add('WSA Startup failed.');
    exit;
  end;
  with memo1.lines do
  begin
    add('WSA Startup:');
    add('Desc.:  ' + wsData.szDescription);
    add('Status: ' + wsData.szSystemStatus);
  end;

  try
    // Create socket
    sh := Socket(AF_INET, SOCK_RAW, IPPROTO_UDP);
    if (sh = INVALID_SOCKET) then
    begin
      memo1.lines.add('Socket() failed: ' + IntToStr(WSAGetLastError));
      exit;
    end;
    Memo1.lines.add('Socket Handle = ' + IntToStr(sh));

    // Option: Header Include
    bOpt := 1;
    ret := SetSockOpt(sh, IPPROTO_IP, IP_HDRINCL, @bOpt, SizeOf(bOpt));
    if ret = SOCKET_ERROR then
    begin
      Memo1.lines.add('setsockopt(IP_HDRINCL) failed: ' + IntToStr(WSAGetLastError));
      exit;
    end;

    // Build the packet
    BuildHeaders(SrcIP, SrcPort,
      DestIP, DestPort,
      'THIS IS A TEST PACKET',
      Buf, Remote, iTotalSize);

    // Send the packet
    ret := SendTo(sh, buf, iTotalSize, 0, Remote, SizeOf(Remote));
    if ret = SOCKET_ERROR then
      Memo1.Lines.Add('sendto() failed: ' + IntToStr(WSAGetLastError))
    else
      Memo1.Lines.Add('send ' + IntToStr(ret) + ' bytes.');

    // Close socket
    CloseSocket(sh);
  finally
    // Close Winsock 2
    WSACleanup;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SendIt;
end;

end.

Muting and revoicing the audio from your application

Problem/Question/Abstract:

Based on an old article that described the solution for muting the audio during my application, someone asked me to make a similar to be controlled from a Button: here's the solution... easy and fast!

Answer:

WARNING: you must avoid pressing 2 times the mute button or the mixer data will be lost. so I added a boolean condition.

uses
  MMSystem;

{...}

{Global variables}

var
  MyVolume: array[0..10] of LongInt;
  mDevs: Integer;
  IsMute: Boolean;

Create two button:

cmdMute
cmdRevoice

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  IsMute := False;
end;

procedure TfrmMain.cmdMuteClick(Sender: TObject);
var
  I: Integer;
begin
  if (not (IsMute)) then
  begin
    mDevs := auxGetNumDevs;
    for I := 0 to mDevs do
    begin
      auxGetVolume(I, Addr(MyVolume[I]));
      auxSetVolume(I, LongInt(9000) * 65536 + LongInt(9000));
    end;
    IsMute := True;
  end;
end;

procedure TfrmMain.cmdRevoiceClick(Sender: TObject);
var
  I: Integer;
begin
  if (IsMute) then
  begin
    for I := 0 to mDevs do
      auxSetVolute(I, MyVolume[I]);
    IsMute := False;
  end;
end;

Get the list of function that an executable file imports

Problem/Question/Abstract:

How to get the list of functions that an executable file imports as well as other information like the dlls from which the program imports these functions.

Answer:

The following program shows how you can get the list of functions imported by the executable file. It consists of two units the first one is the 'structures' unit which is required by the program unit

Here is the code

Structures File

unit structures;

interface
uses Windows, sysutils;
const
  IMAGE_DOS_SIGNATURE = $5A4D; { MZ }
  IMAGE_OS2_SIGNATURE = $454E; { NE }
  IMAGE_OS2_SIGNATURE_LE = $454C; { LE }
  IMAGE_VXD_SIGNATURE = $454C; { LE }
  IMAGE_NT_SIGNATURE = $00004550; { PE00 }

  IMAGE_SIZEOF_SHORT_NAME = 8;
  IMAGE_SIZEOF_SECTION_HEADER = 40;
  IMAGE_NUMBEROF_DIRECTORY_ENTRIES = 16;
  IMAGE_RESOURCE_NAME_IS_STRING = $80000000;
  IMAGE_RESOURCE_DATA_IS_DIRECTORY = $80000000;
  IMAGE_OFFSET_STRIP_HIGH = $7FFFFFFF;
  DIRECTORY_ENTRY_EXPORT = 0; // Export Directory
  IMAGE_DIRECTORY_ENTRY_IMPORT = 1; // Import Directory
  IMAGE_DIRECTORY_ENTRY_RESOURCE = 2; // Resource Directory
  IMAGE_DIRECTORY_ENTRY_EXCEPTION = 3; // Exception Directory
  IMAGE_DIRECTORY_ENTRY_SECURITY = 4; // Security Directory
  IMAGE_DIRECTORY_ENTRY_BASERELOC = 5; // Base Relocation Table
  IMAGE_DIRECTORY_ENTRY_DEBUG = 6; // Debug Directory
  IMAGE_DIRECTORY_ENTRY_COPYRIGHT = 7; // Description String
  IMAGE_DIRECTORY_ENTRY_GLOBALPTR = 8; // Machine Value (MIPS GP)
  IMAGE_DIRECTORY_ENTRY_TLS = 9; // TLS Directory
  IMAGE_DIRECTORY_ENTRY_LOAD_CONFIG = 10; // Load Configuration Directory
  IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT = 11; // Bound Import Directory in headers
  IMAGE_DIRECTORY_ENTRY_IAT = 12;

type
  plist_entry = ^LIST_ENTRY;
  LIST_ENTRY = record
    Flink: pLIST_ENTRY;
    Blink: pLIST_ENTRY;
  end;

type
  IMAGE_EXPORT_DIRECTORY = packed record
    Characteristics: DWORD;
    TimeDateStamp: DWORD;
    MajorVersion: WORD;
    MinorVersion: WORD;
    Name: DWORD;
    Base: DWORD;
    NumberOfFunctions: DWORD;
    NumberOfNames: DWORD;
    pAddressOfFunctions: PDWORD;
    pAddressOfNames: PDWORD;
    pAddressOfNameOrdinals: PWORD;
  end;
  PIMAGE_EXPORT_DIRECTORY = ^IMAGE_EXPORT_DIRECTORY;

type
  FPO_DATA = packed record
    ulOffStart: DWORD; // offset 1st byte of function code
    cbProcSize: DWORD; // # bytes in function
    cdwLocals: DWORD; // # bytes in locals/4
    cdwParams: WORD; // # bytes in params/4
    cbProlog: WORD; // # bytes in prolog
    cbRegs: WORD; // # regs saved
    fHasSEH: WORD; // TRUE if SEH in func
    fUseBP: WORD; // TRUE if EBP has been allocated
    reserved: WORD; // reserved for future use
    cbFrame: WORD; // frame type
  end;
  PFPO_DATA = ^FPO_DATA;

type
  IMAGE_FUNCTION_ENTRY = packed record
    StartingAddress: dword;
    EndingAddress: dword;
    EndOfPrologue: dword;
  end;
  PIMAGE_FUNCTION_ENTRY = ^IMAGE_FUNCTION_ENTRY;

type
  PIMAGE_DOS_HEADER = ^IMAGE_DOS_HEADER;
  IMAGE_DOS_HEADER = packed record { DOS .EXE header }
    e_magic: WORD; { Magic number }
    e_cblp: WORD; { Bytes on last page of file }
    e_cp: WORD; { Pages in file }
    e_crlc: WORD; { Relocations }
    e_cparhdr: WORD; { Size of header in paragraphs }
    e_minalloc: WORD; { Minimum extra paragraphs needed }
    e_maxalloc: WORD; { Maximum extra paragraphs needed }
    e_ss: WORD; { Initial (relative) SS value }
    e_sp: WORD; { Initial SP value }
    e_csum: WORD; { Checksum }
    e_ip: WORD; { Initial IP value }
    e_cs: WORD; { Initial (relative) CS value }
    e_lfarlc: WORD; { File address of relocation table }
    e_ovno: WORD; { Overlay number }
    e_res: packed array[0..3] of WORD; { Reserved words }
    e_oemid: WORD; { OEM identifier (for e_oeminfo) }
    e_oeminfo: WORD; { OEM information; e_oemid specific }
    e_res2: packed array[0..9] of WORD; { Reserved words }
    e_lfanew: Longint; { File address of new exe header }
  end;

  PIMAGE_FILE_HEADER = ^IMAGE_FILE_HEADER;
  IMAGE_FILE_HEADER = packed record
    Machine: WORD;
    NumberOfSections: WORD;
    TimeDateStamp: DWORD;
    PointerToSymbolTable: DWORD;
    NumberOfSymbols: DWORD;
    SizeOfOptionalHeader: WORD;
    Characteristics: WORD;
  end;

  PIMAGE_DATA_DIRECTORY = ^IMAGE_DATA_DIRECTORY;
  IMAGE_DATA_DIRECTORY = packed record
    VirtualAddress: DWORD;
    Size: DWORD;
  end;

  PIMAGE_OPTIONAL_HEADER = ^IMAGE_OPTIONAL_HEADER;
  IMAGE_OPTIONAL_HEADER = packed record
    { Standard fields. }
    Magic: WORD;
    MajorLinkerVersion: Byte;
    MinorLinkerVersion: Byte;
    SizeOfCode: DWORD;
    SizeOfInitializedData: DWORD;
    SizeOfUninitializedData: DWORD;
    AddressOfEntryPoint: DWORD;
    BaseOfCode: DWORD;
    BaseOfData: DWORD;
    { NT additional fields. }
    ImageBase: DWORD;
    SectionAlignment: DWORD;
    FileAlignment: DWORD;
    MajorOperatingSystemVersion: WORD;
    MinorOperatingSystemVersion: WORD;
    MajorImageVersion: WORD;
    MinorImageVersion: WORD;
    MajorSubsystemVersion: WORD;
    MinorSubsystemVersion: WORD;
    Reserved1: DWORD;
    SizeOfImage: DWORD;
    SizeOfHeaders: DWORD;
    CheckSum: DWORD;
    Subsystem: WORD;
    DllCharacteristics: WORD;
    SizeOfStackReserve: DWORD;
    SizeOfStackCommit: DWORD;
    SizeOfHeapReserve: DWORD;
    SizeOfHeapCommit: DWORD;
    LoaderFlags: DWORD;
    NumberOfRvaAndSizes: DWORD;
    DataDirectory: packed array[0..IMAGE_NUMBEROF_DIRECTORY_ENTRIES - 1] of
      IMAGE_DATA_DIRECTORY;
  end;

  PIMAGE_SECTION_HEADER = ^IMAGE_SECTION_HEADER;
  IMAGE_SECTION_HEADER = packed record
    Name: packed array[0..IMAGE_SIZEOF_SHORT_NAME - 1] of Char;
    PhysicalAddress: DWORD; // or VirtualSize (union);
    VirtualAddress: DWORD;
    SizeOfRawData: DWORD;
    PointerToRawData: DWORD;
    PointerToRelocations: DWORD;
    PointerToLinenumbers: DWORD;
    NumberOfRelocations: WORD;
    NumberOfLinenumbers: WORD;
    Characteristics: DWORD;
  end;

  PIMAGE_NT_HEADERS = ^IMAGE_NT_HEADERS;
  IMAGE_NT_HEADERS = packed record
    Signature: DWORD;
    FileHeader: IMAGE_FILE_HEADER;
    OptionalHeader: IMAGE_OPTIONAL_HEADER;
  end;

  PIMAGE_RESOURCE_DIRECTORY = ^IMAGE_RESOURCE_DIRECTORY;
  IMAGE_RESOURCE_DIRECTORY = packed record
    Characteristics: DWORD;
    TimeDateStamp: DWORD;
    MajorVersion: WORD;
    MinorVersion: WORD;
    NumberOfNamedEntries: WORD;
    NumberOfIdEntries: WORD;
  end;

  PIMAGE_RESOURCE_DIRECTORY_ENTRY = ^IMAGE_RESOURCE_DIRECTORY_ENTRY;
  IMAGE_RESOURCE_DIRECTORY_ENTRY = packed record
    Name: DWORD; // Or ID: Word (Union)
    OffsetToData: DWORD;
  end;

  PIMAGE_RESOURCE_DATA_ENTRY = ^IMAGE_RESOURCE_DATA_ENTRY;
  IMAGE_RESOURCE_DATA_ENTRY = packed record
    OffsetToData: DWORD;
    Size: DWORD;
    CodePage: DWORD;
    Reserved: DWORD;
  end;

  PIMAGE_RESOURCE_DIR_STRING_U = ^IMAGE_RESOURCE_DIR_STRING_U;
  IMAGE_RESOURCE_DIR_STRING_U = packed record
    Length: WORD;
    NameString: array[0..0] of WCHAR;
  end;

type
  LOADED_IMAGE = record
    ModuleName: pchar;
    hFile: thandle;
    MappedAddress: pchar;
    FileHeader: PIMAGE_NT_HEADERS;
    LastRvaSection: PIMAGE_SECTION_HEADER;
    NumberOfSections: integer;
    Sections: PIMAGE_SECTION_HEADER;
    Characteristics: integer;
    fSystemImage: boolean;
    fDOSImage: boolean;
    Links: LIST_ENTRY;
    SizeOfImage: integer;
  end;
  PLOADED_IMAGE = ^LOADED_IMAGE;

type
  IMAGE_LOAD_CONFIG_DIRECTORY = packed record
    Characteristics: DWORD;
    TimeDateStamp: DWORD;
    MajorVersion: WORD;
    MinorVersion: WORD;
    GlobalFlagsClear: DWORD;
    GlobalFlagsSet: DWORD;
    CriticalSectionDefaultTimeout: DWORD;
    DeCommitFreeBlockThreshold: DWORD;
    DeCommitTotalFreeThreshold: DWORD;
    LockPrefixTable: Pointer;
    MaximumAllocationSize: DWORD;
    VirtualMemoryThreshold: DWORD;
    ProcessHeapFlags: DWORD;
    ProcessAffinityMask: DWORD;
    Reserved: array[0..2] of DWORD;
  end;
  PIMAGE_LOAD_CONFIG_DIRECTORY = ^IMAGE_LOAD_CONFIG_DIRECTORY;

type
  IMAGE_IMPORT_BY_NAME = packed record
    Hint: WORD;
    Name: DWORD;
  end;
  PIMAGE_IMPORT_BY_NAME = ^IMAGE_IMPORT_BY_NAME;

type
  IMAGE_THUNK_DATA = packed record
    ForwarderString: PBYTE;
    Func: PDWORD;
    Ordinal: DWORD;
    AddressOfData: PIMAGE_IMPORT_BY_NAME;
  end;
  PIMAGE_THUNK_DATA = ^IMAGE_THUNK_DATA;

type
  IMAGE_IMPORT_DESCRIPTOR = packed record
    Characteristics: DWORD;
    TimeDateStamp: DWORD;
    ForwarderChain: DWORD;
    Name: DWORD;
    FirstThunk: DWORD;
  end;
  PIMAGE_IMPORT_DESCRIPTOR = ^IMAGE_IMPORT_DESCRIPTOR;

implementation

end.

Code File

unit p1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    OpenDialog1: TOpenDialog;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    procedure ProcessFile;
  end;

var
  Form1: TForm1;
  h1, hmap: integer;
  bptr: pointer;
  gptr: pbyte;
  ntsign: plongword;
  doshd: PIMAGE_DOS_HEADER;
  pehd: PIMAGE_FILE_HEADER;
  peoptn: PIMAGE_OPTIONAL_HEADER;
  sectionheads: array of PIMAGE_SECTION_HEADER;
  offsetmem: longword;
  idataphysicaladress: pbyte;
  idata: PIMAGE_IMPORT_DESCRIPTOR;
  modulename, functionname: pchar;
  dptr: plongword;
  ord: word;
  pexpdir: PIMAGE_EXPORT_DIRECTORY;
  pexpnames: pdword;
  expfname: pchar;
implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  processfile;
end;

procedure TForm1.ProcessFile;
var
  i, j: integer;
begin
  if opendialog1.Execute = false then
    exit
  else
    h1 := fileopen(opendialog1.FileName, fmShareDenyNone or fmOpenRead);
  hmap := CreateFileMapping(h1, nil, PAGE_READONLY, 0, 0, nil);
  doshd := PIMAGE_DOS_HEADER(mapviewoffile(hmap, FILE_MAP_READ, 0, 0, 0));
  bptr := doshd;
  memo1.lines.add('DOS Header');
  memo1.Lines.Add(' -e_magic=' + inttostr(doshd.e_magic));
  memo1.Lines.Add(' -e_cblp=' + inttostr(doshd.e_cblp));
  memo1.Lines.Add(' -e_cp=' + inttostr(doshd.e_cp));
  memo1.Lines.Add(' -e_crlc=' + inttostr(doshd.e_crlc));
  memo1.Lines.Add(' -e_cparhdr=' + inttostr(doshd.e_cparhdr));
  memo1.Lines.Add(' -e_minalloc=' + inttostr(doshd.e_minalloc));
  memo1.Lines.Add(' -e_maxalloc=' + inttostr(doshd.e_maxalloc));
  memo1.Lines.Add(' -e_ss=' + inttostr(doshd.e_ss));
  memo1.Lines.Add(' -e_sp=' + inttostr(doshd.e_sp));
  memo1.Lines.Add(' -e_csum=' + inttostr(doshd.e_csum));
  memo1.Lines.Add(' -e_ip=' + inttostr(doshd.e_ip));
  memo1.Lines.Add(' -e_cs=' + inttostr(doshd.e_cs));
  memo1.Lines.Add(' -e_lfarlc=' + inttostr(doshd.e_lfarlc));
  memo1.Lines.Add(' -e_ovno=' + inttostr(doshd.e_ovno));
  memo1.Lines.Add(' -e_oemid=' + inttostr(doshd.e_oemid));
  memo1.Lines.Add(' -e_oeminfo=' + inttostr(doshd.e_oeminfo));
  memo1.Lines.Add(' -e_lfanew=' + inttostr(doshd.e_lfanew));
  gptr := bptr;
  inc(gptr, doshd.e_lfanew);
  ntsign := plongword(gptr);
  if (ntsign^ = IMAGE_NT_SIGNATURE) then
  begin
    memo1.Lines.Add('NT Signature<' + inttostr(IMAGE_NT_SIGNATURE) + '>=' +
      inttostr(ntsign^));
    memo1.Lines.Add('Windows Executable');
    memo1.lines.add('------------------------------------------');
    gptr := bptr;
    inc(gptr, doshd.e_lfanew + 4);
    pehd := PIMAGE_FILE_HEADER(gptr);
    memo1.lines.add('PE Header');
    memo1.Lines.Add(' -Machine=' + inttostr(pehd.Machine));
    memo1.Lines.Add(' -Number of Sections=' + inttostr(pehd.NumberOfSections));
    memo1.Lines.Add(' -TimeDateStamp=' + IntToStr(pehd.TimeDateStamp));
    memo1.Lines.Add(' -PointerToSymbolTable=' + IntToStr(pehd.PointerToSymbolTable));
    memo1.Lines.Add(' -Number of Symbols=' + IntToStr(pehd.NumberOfSymbols));
    memo1.Lines.Add(' -SizeOfOptionalHeader=' + IntToStr(pehd.SizeOfOptionalHeader));
    memo1.Lines.Add(' -Characteristics=' + IntToStr(pehd.Characteristics));
    memo1.lines.add('------------------------------------------');
    gptr := pbyte(pehd);
    inc(gptr, sizeof(IMAGE_FILE_HEADER));
    peoptn := PIMAGE_OPTIONAL_HEADER(gptr);
    memo1.lines.add('PE Optional Header');
    memo1.Lines.Add(' -Magic=' + inttostr(peoptn.Magic));
    memo1.Lines.Add(' -MajorLinkerVersion=' + inttostr(peoptn.MajorLinkerVersion));
    memo1.Lines.Add(' -MinorLinkerVersion=' + inttostr(peoptn.MinorLinkerVersion));
    memo1.Lines.Add(' -SizeOfCode=' + inttostr(peoptn.SizeOfCode));
    memo1.Lines.Add(' -SizeOfInitializedData=' +
      inttostr(peoptn.SizeOfInitializedData));
    memo1.Lines.Add(' -SizeOfUninitializedData=' +
      inttostr(peoptn.SizeOfUninitializedData));
    memo1.Lines.Add(' -AddressOfEntryPoint=' + inttostr(peoptn.AddressOfEntryPoint));
    memo1.Lines.Add(' -BaseOfCode=' + inttostr(peoptn.BaseOfCode));
    memo1.Lines.Add(' -BaseOfData=' + inttostr(peoptn.BaseOfData));
    memo1.Lines.Add(' -ImageBase=' + inttostr(peoptn.ImageBase));
    memo1.Lines.Add(' -SectionAlignment=' + inttostr(peoptn.SectionAlignment));
    memo1.Lines.Add(' -FileAlignment=' + inttostr(peoptn.FileAlignment));
    memo1.Lines.Add(' -MajorOperatingSystemVersion=' +
      inttostr(peoptn.MajorOperatingSystemVersion));
    memo1.Lines.Add(' -MinorOperatingSystemVersion=' +
      inttostr(peoptn.MinorOperatingSystemVersion));
    memo1.Lines.Add(' -MajorImageVersion=' + inttostr(peoptn.MajorImageVersion));
    memo1.Lines.Add(' -MinorImageVersion=' + inttostr(peoptn.MinorImageVersion));
    memo1.Lines.Add(' -MajorSubsystemVersion=' +
      inttostr(peoptn.MajorSubsystemVersion));
    memo1.Lines.Add(' -MinorSubsystemVersion =' +
      inttostr(peoptn.MinorSubsystemVersion));
    memo1.Lines.Add(' -Reserved1 =' + inttostr(peoptn.Reserved1));
    memo1.Lines.Add(' -SizeOfImage =' + inttostr(peoptn.SizeOfImage));
    memo1.Lines.Add(' -SizeOfHeaders =' + inttostr(peoptn.SizeOfHeaders));
    memo1.Lines.Add(' -CheckSum =' + inttostr(peoptn.CheckSum));
    memo1.Lines.Add(' -SubSystem =' + inttostr(peoptn.Subsystem));
    memo1.Lines.Add(' -DllCharacteristics =' + inttostr(peoptn.DllCharacteristics));
    memo1.Lines.Add(' -SizeOfStackReserve =' + inttostr(peoptn.SizeOfStackReserve));
    memo1.Lines.Add(' -SizeOfStackCommit =' + inttostr(peoptn.SizeOfStackCommit));
    memo1.Lines.Add(' -SizeOfHeapReserve =' + inttostr(peoptn.SizeOfHeapReserve));
    memo1.Lines.Add(' -SizeOfHeapCommit =' + inttostr(peoptn.SizeOfHeapCommit));
    memo1.Lines.Add(' -LoaderFlags =' + inttostr(peoptn.LoaderFlags));
    memo1.Lines.Add(' -NumberOfRvaAndSizes =' + inttostr(peoptn.NumberOfRvaAndSizes));
    memo1.lines.add('------------------------------------------');
    setlength(sectionheads, pehd.NumberOfSections);
    for i := 0 to pehd.NumberOfSections - 1 do
    begin
      gptr := pbyte(peoptn);
      inc(gptr, sizeof(IMAGE_OPTIONAL_HEADER) + i * sizeof(IMAGE_SECTION_HEADER));
      sectionheads[i] := PIMAGE_SECTION_HEADER(gptr);
    end;
    if peoptn.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT].Size = 0 then
    begin
      memo1.lines.add('No Export Table Present');
      memo1.lines.add('------------------------------------------');
    end
    else
    begin
      memo1.lines.add('Export Table Present');
      for i := pehd.NumberOfSections - 1 downto 0 do
      begin
        if peoptn.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT].VirtualAddress >=
          sectionheads[i].VirtualAddress then
        begin
          offsetmem := sectionheads[i].PointerToRawData -
            sectionheads[i].VirtualAddress;
          break;
        end;
      end;
      gptr := bptr;
      inc(gptr, offsetmem +
        peoptn.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT].VirtualAddress);
      pexpdir := PIMAGE_EXPORT_DIRECTORY(gptr);
      pexpnames := pdword(longint(bptr) +
        integer(PIMAGE_EXPORT_DIRECTORY(gptr).pAddressOfNames));
      for i := 0 to pexpdir.NumberOfNames - 1 do
      begin
        expfname := pchar(integer(bptr) + integer(pexpnames^));
        memo1.lines.add(' -' + expfname);
        inc(pexpnames);
      end;
      memo1.lines.add('------------------------------------------');
    end;
    if peoptn.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].Size = 0 then
      memo1.lines.add('No Import Table Present')
    else
    begin
      memo1.lines.add('Import Table Present');
      for i := pehd.NumberOfSections - 1 downto 0 do
      begin
        if peoptn.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress >=
          sectionheads[i].VirtualAddress then
        begin
          offsetmem := sectionheads[i].PointerToRawData -
            sectionheads[i].VirtualAddress;
          break;
        end;
      end;
      gptr := bptr;
      inc(gptr, offsetmem +
        peoptn.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress);
      idataphysicaladress := gptr;
      i := 0;
      j := 0;
      while true do
      begin
        gptr := idataphysicaladress;
        inc(gptr, i * sizeof(IMAGE_IMPORT_DESCRIPTOR));
        idata := PIMAGE_IMPORT_DESCRIPTOR(gptr);
        if idata.Name = 0 then
          break;
        gptr := bptr;
        inc(gptr, offsetmem + idata.Name);
        modulename := pchar(gptr);
        memo1.Lines.Add('Module Name:' + modulename);
        while true do
        begin
          if (idata.FirstThunk + j * 4) = 0 then
            break;
          gptr := bptr;
          inc(gptr, offsetmem + idata.FirstThunk + j * 4);
          dptr := plongword(gptr);
          gptr := bptr;
          inc(gptr, offsetmem + dptr^);
          if isbadcodeptr(gptr) then
            break;
          ord := pword(gptr)^;
          inc(gptr, 2);
          functionname := pchar(gptr);
          if isbadcodeptr(functionname) then
            break;
          if functionname = nil then
            break;
          memo1.Lines.Add('  -Ord:' + inttohex(ord, 3) + ' Function Name:' +
            functionname);
          inc(j);
        end;
        inc(i);
      end;
    end;
  end;
  UnmapViewOfFile(bptr);
  closehandle(hmap);
  fileclose(h1);
end;

end.

Handling Winsock errors

Problem/Question/Abstract:

For any of the following exception handling methods to work, the VCL must in some way become aware that an error condition exists. If a call to the Winsock does not return, or does not provide information to the TCustomWinSocket descendant that called it, then there is no mechanism to handle the condition. OnError exception handler.

Answer:

One method for trapping exception conditions in a descendant of TCustomWinSocket is to use an OnError exception handler. This method will only handle a limited set of conditions because the mechanism provided by the Winsock for event notification only reacts to a limited list of conditions.  To be notified of an exception condition within the Winsock, TCustomWinSocket registers user message CM_SocketMessage to be sent to the component, and the CMSocketMessage message handler raises an exception.  The message is registered with the Winsock by an API call to WSASyncSelect. WSASyncSelect is a request for event notification of socket read, writes, connect, close, and accept events.  If the exception condition is not read, write, connect, close or accept, or if the CM_SocketMessage is not sent by the Winsock for any reason, the error handler will not fire.

Usage:

procedure TChatForm.ClientSocketError(Sender: TObject;
  Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
  var ErrorCode: Integer);
const
  ErrorEvents: array[eeGeneral..eeAccept] of string = (
    'eeGeneral',
    'eeSend',
    'eeReceive',
    'eeConnect',
    'eeDisconnect',
    'eeAccept'
    );
begin
  ListBox1.Items.Add('ClientSocketError.   TErrorEvent: ' +
    ErrorEvents[ErrorEvent] + '    ErrorCode: ' + IntToStr(ErrorCode));
  ErrorCode := 0; // don't raise an exception
end;

Definition:

procedure TCustomWinSocket.CMSocketMessage(var Message: TCMSocketMessage);

  function CheckError: Boolean;
  var
    ErrorEvent: TErrorEvent;
    ErrorCode: Integer;
  begin
    if Message.SelectError <> 0 then
    begin
      Result := False;
      ErrorCode := Message.SelectError;
      case Message.SelectEvent of
        FD_CONNECT: ErrorEvent := eeConnect;
        FD_CLOSE: ErrorEvent := eeDisconnect;
        FD_READ: ErrorEvent := eeReceive;
        FD_WRITE: ErrorEvent := eeSend;
        FD_ACCEPT: ErrorEvent := eeAccept;
      else
        ErrorEvent := eeGeneral;
      end;
      Error(Self, ErrorEvent, ErrorCode);
      if ErrorCode <> 0 then
        raise ESocketError.CreateFmt(sASyncSocketError, [ErrorCode]);
    end
    else
      Result := True;
  end;

begin
  with Message do
    if CheckError then
      case SelectEvent of
        FD_CONNECT: Connect(Socket);
        FD_CLOSE: Disconnect(Socket);
        FD_READ: Read(Socket);
        FD_WRITE: Write(Socket);
        FD_ACCEPT: Accept(Socket);
      end;
end;

Object Pascal Exception Handling
You can also wrap a specific call in a try..except block or setting an application level exception handler.  For this to
work, the component must in some way become aware of the exception condition and an exception must be raised for the exception to be trapped here.

Example of Application Exception Handler:

TChatForm = class(TForm)
  {.
  . }
public
  procedure AppException(Sender: TObject; E: Exception);
end;
{.
. }
implementation
{.
. }

procedure TChatForm.AppException(Sender: TObject; E: Exception);
begin
  ListBox1.Items.Add('AppException: ' + E.Message);
end;

procedure TChatForm.FormCreate(Sender: TObject);
begin
  Application.OnException := AppException;
end;

Example of Try..Except block:

with ClientSocket do
try
  Active := True;
except
  on E: Exception do
    ListBox1.Items.Add('Try..except during open: ' + E.Message);
end;
end;

SocketErrorProc
For calls that use the CheckSocketResult function to check the result returned by WSAGetLastError, errors can be handled in a programmer defined function by setting the SocketErrorProc.

Usage:

interface
{.
. }
procedure MySocketError(ErrorCode: Integer);

implementation
{.
. }

procedure MySocketError(ErrorCode: Integer);
begin
  ShowMessage('MySocketError: ' + IntToStr(ErrorCode));
end;

procedure TChatForm.FormCreate(Sender: TObject);
begin
  SocketErrorProc := MySocketError;
end;

Defined:

function CheckSocketResult(ResultCode: Integer; const Op: string):
  Integer;
begin
  if ResultCode <> 0 then
  begin
    Result := WSAGetLastError;
    if Result <> WSAEWOULDBLOCK then
      if Assigned(SocketErrorProc) then
        SocketErrorProc(Result)
      else
        raise ESocketError.CreateFmt(sWindowsSocketError,
          [SysErrorMessage(Result), Result, Op]);
  end
  else
    Result := 0;
end;


Help Text for SocketErrorProc:

Unit ScktComp

SocketErrorProc handles error messages that are received from a Windows socket connection.

threadvar
  SocketErrorProc: procedure(ErrorCode: Integer);

Assign a value to SocketErrorProc to handle error messages from Windows socket API calls before the socket component raises an exception. Setting SocketErrorProc prevents the socket component from raising an exception.  SocketErrorProc is a thread-local variable. It only handles errors that arise from the Windows socket API calls made within a single execution thread.

Search in MS Word file without MS Word

Problem/Question/Abstract:

How can i Search in MS Word File Without MS Word?

Answer:

You can use follow code in delphi and search in msword file without msword and office :

unit FindText;

interface

function FindTextInFile(const FileName, TextToFind: WideString): boolean;

implementation

uses ComObj, ActiveX, AxCtrls, SysUtils, Classes;

function FindTextInFile(const FileName, TextToFind: WideString): boolean;
var
  Root: IStorage;
  EnumStat: IEnumStatStg;
  Stat: TStatStg;
  iStm: IStream;
  Stream: TOleStream;
  DocTextString: WideString;
begin
  Result := False;

  if not FileExists(FileName) then
    Exit;

  // Check to see if it's a structured storage file
  if StgIsStorageFile(PWideChar(FileName)) <> S_OK then
    Exit;

  // Open the file
  OleCheck(StgOpenStorage(PWideChar(FileName), nil,
    STGM_READ or STGM_SHARE_EXCLUSIVE, nil, 0, Root));

  // Enumerate the storage and stream objects contained within this file
  OleCheck(Root.EnumElements(0, nil, 0, EnumStat));

  // Check all objects in the storage
  while EnumStat.Next(1, Stat, nil) = S_OK do

    // Is it a stream with Word data
    if Stat.pwcsName = 'WordDocument' then

      // Try to get the stream "WordDocument"
      if Succeeded(Root.OpenStream(Stat.pwcsName, nil,
        STGM_READ or STGM_SHARE_EXCLUSIVE, 0, iStm)) then
      begin
        Stream := TOleStream.Create(iStm);
        try
          if Stream.Size > 0 then
          begin
            // Move text data to string variable
            SetLength(DocTextString, Stream.Size);
            Stream.Position := 0;
            Stream.Read(pChar(DocTextString)^, Stream.Size);

            // Find a necessary text
            Result := (Pos(TextToFind, DocTextString) > 0);
          end;
        finally
          Stream.Free;
        end;
        Exit;
      end;
end;

end.

Resolution independent applications

Problem/Question/Abstract:

Have you ever wondered how to display your forms and components always the same size no matter what the screen resolution is?

Answer:

You have to modify your project�s DPR file to acomplish that:

// Modify your projects code to achieve resolution independent
// applications. I have found that this trick only works for
// resolutions greater than the resolution you design the forms, for
// example if you design at 800x600 you can use your application at
// a resolution of 1024 x 768 or greater.
// However it won�t run fine at 640x480 (altough, nowadays I don�t
// kwonw many people with thatv resolution, so I think 800X600 is
// fine)

program TestResolution;

uses
  Forms,
  Dialogs,
  Classes,
  TypInfo,
  Windows,
  Unit1 in 'Unit1.pas' {Form1},
  Unit2 in 'Unit2.pas' {Form2};

{$R *.RES}

const
  //If form is designed in 800 x 600 mode
  ScreenWidth: LongInt = 800;
  ScreenHeight: LongInt = 600;

var
  vi_Counter1, vi_Counter2: Integer;
  NewFormWidth: Integer;

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.CreateForm(TForm2, Form2);
  NewFormWidth := GetSystemMetrics(0);

  with Application do
    for vi_Counter1 := 0 to ComponentCount - 1 do
    begin
      //Find all the Auto-create forms
      if Components[vi_Counter1] is TForm then
        with (Components[vi_Counter1] as TForm) do
        begin
          Scaled := True;
          if screen.Width <> ScreenWidth then
          begin
            Height := longint(Height) * longint(screen.Height) div
              ScreenHeight;
            Width := longint(Width) * longint(screen.Width) div
              ScreenWidth;
            ScaleBy(screen.Width, ScreenWidth);

            //Now Scale the Form�s component�s Font
            for vi_Counter2 := 0 to ControlCount - 1 do
              with Components[vi_Counter2] do
                //Use RTTI information to find for a Font property
                if GetPropInfo(ClassInfo, 'font') <> nil then
                  Font.Size := (NewFormWidth div ScreenWidth)
                    * font.Size;
          end;
        end;
    end;
  Application.Run;
end.

finally some aditional considerations:

You will have to scale every form create on the fly.
Use only TrueType fonts, not Bitmapped fonts to avoid problems.
Don�t set the Form�s Position property to poDesigned, when scalling it could be off the screen.
Don't change the PixelsPerInch property of the form.
Don't crowd controls on the form - leave at least 4 pixels between controls, so that a one pixel change in border  locations (due to scaling) won't show up as ugly overlapping  controls.

Overcome a printing glitch in the EPSON 600 series driver

Problem/Question/Abstract:

How to overcome a printing glitch in the EPSON 600 series driver

Answer:

The drivers for the Epson 600-series seem to have a weird problem. If the Printer.Title property is empty (by default) the printer won't do anything. You can't get a single line of text out of the printer. So, to be sure your application prints, put the line:

{ ...}
Printer.Title := 'Some Text';
{ ...}

just before you call Printer.BeginDoc. You can replace the TitleString by any, non-empty, string you like.

TQuery vs TTable components: why upgrade?

Problem/Question/Abstract:

Using TTable was absoltely normal in a near past, when the data resided locally, but is a common (and great) mistake in a modern, network environment.

Why should I use Query components instead of  Tables? Is the change in the existing projects worth the efforts?

Answer:

Until recently, many programmers were told to use extensively in their programs Table Datasets instead of queries.

In a single user environment, where all the data resides locally, this can be an easy and rapid solution for the basic needs, and most programs  seemed to function perfectly with this approach in the near past.

But a Network Environment is NOT a Single User Environment: let&#8217;s get a brief look to the differences between them.

First of all, data stored in tables shared on a network are often by far bigger then single user&#8217;s ones, as the data in an organization are of course bigger of the data of a single user: for example, I have seen Paradox tables of more then 80 Mbytes, truncated every 6 months because they were to big to be used with the BDE.
The BDE cannot simply manage huge quantities of data with local drivers (Paradox, dBase). The problem in this case is that using tables, you have to load in memory ALL the datas: if you&#8217;re lucky enaugh, and the programs are slow and take dozens of Mbytes of RAM. If you&#8217;re not so lucky, index corruption problems affect your databases many times every day, too, as a consequence of concurrent access on big physical tables.

In a second place, you haven&#8217;t control on the fields you need: think about a catalog.db in which there is also a big BLOB field with a TIFF boxshot of a product inside&#8230; if you use tables, you have to load it in memory even if you don&#8217;t need it, for example if you are an accountant or the CEO and you are interested only in the most important aspects of a catalog (SKU, DESC, PRICE).
Using Table components, which load in memory all the fields, can fill the RAM of the PCs, so it is a great cost for the company, too. BE ADVISED: adding field definitions to the table doesn&#8217;t solve the problem! The fields not defined are anyway loaded in the PC&#8217;s RAM and their datas flow on the network creating a great traffic jam on it!

In a 3rd place: not only you have to load in memory ALL THE FIELDS, even if you don&#8217;t want some of them; you also have to load in memory from a shared network ALL THE ROWS of the table; most middlewares (BDE included) need this even if you try to &#8220;filter&#8221; the table.

Finally: if you have to calculate avarage, min, max values for categories inside a database, you have to build yourself code using a Table component; if you use Query components instead of Tables, you can use the aggregated functions of the Queries, making the server work for you and simplifying radically the development process. Using TQueries, you can make advanced statistics in a snap.

Also, if you use a Database Server like Interbase or MS-SQL, the Server takes charge of filtering the result set, reducing the CPU, Bandwith and RAM requirements of the the client up to the 95% and giving the client program a quicker response to the user&#8217;s actions.

Despite the (little) effort needed to change existing projects, I suggest all the programmers, in particular those with Ttable components in their programmer&#8217;s DNA, to use Queries also in old projects and not only in  newer ones; this is by far the best solution to achieve better performance in your EXEs.

Remember: using Queries can lead to incredible performance gains, both in CPU, Bandwith and Ram occupation on older machines, increasing their productive life and reducing costs, so the great savings achieved are by far worth the (small) effort needed.

Embedding files in a program

Problem/Question/Abstract:

Have you ever needed to distribute one or more critical data files with a program? Often only your program needs to access the data file(s) and they don't need to be changed by it. How do we stop users from deleting the files?

Answer:

One answer is to store the data file inside our executable (or in a DLL) as a custom (RCDATA) resource and to link the resource into our application using the {$R} directive.

This article shows how to create a resource file containing a copy of any file. The resource file we're going to create has the following format:

a header that introduces the file
a header for our RCDATA resource
the data itself - an RCDATA resource is simply a sequence of bytes
any padding required so that any following resource begins on a DWORD boundary

It's much simpler to create a resource file that is identified by an ordinal (eg 200) than it is to create one identified by a string (eg 'MY_RESOURCE'), since the resource header records are a fixed size in the first case and are variable in the second case. We will only consider the first case here. We will also just copy one file into the resource - it's simple to extend this to more than one.

Because we're sticking with ordinal IDs the resource header can be defined as:

TResHeader = record
  DataSize: DWORD; // size of our data
  HeaderSize: DWORD; // size of this record
  ResType: DWORD; // lo word = $FFFF => ordinal
  ResId: DWORD; // lo word = $FFFF => ordinal
  DataVersion: DWORD; // *
  MemoryFlags: WORD;
  LanguageId: WORD; // *
  Version: DWORD; // *
  Characteristics: DWORD; // *
end;

We will not be using the fields marked * .

Here's the code that creates the resource file and copies in a given file:

procedure CreateResourceFile(
  DataFile, ResFile: string; // file names
  ResID: Integer // id of resource
  );
var
  FS, RS: TFileStream;
  FileHeader, ResHeader: TResHeader;
  Padding: array[0..SizeOf(DWORD) - 1] of Byte;
begin

  { Open input file and create resource file }
  FS := TFileStream.Create(// to read data file
    DataFile, fmOpenRead);
  RS := TFileStream.Create(// to write res file
    ResFile, fmCreate);

  { Create res file header - all zeros except
    for HeaderSize, ResType and ResID }
  FillChar(FileHeader, SizeOf(FileHeader), #0);
  FileHeader.HeaderSize := SizeOf(FileHeader);
  FileHeader.ResId := $0000FFFF;
  FileHeader.ResType := $0000FFFF;

  { Create data header for RC_DATA file
    NOTE: to create more than one resource just
    repeat the following process, using a different
    resource ID each time }
  FillChar(ResHeader, SizeOf(ResHeader), #0);
  ResHeader.HeaderSize := SizeOf(ResHeader);
  // resource id - FFFF says "not a string!"
  ResHeader.ResId := $0000FFFF or (ResId shl 16);
  // resource type - RT_RCDATA (from Windows unit)
  ResHeader.ResType := $0000FFFF
    or (WORD(RT_RCDATA) shl 16);
  // data file size is size of file
  ResHeader.DataSize := FS.Size;
  // set required memory flags
  ResHeader.MemoryFlags := $0030;

  { Write the headers to the resource file }
  RS.WriteBuffer(FileHeader, sizeof(FileHeader));
  RS.WriteBuffer(ResHeader, sizeof(ResHeader));

  { Copy the file into the resource }
  RS.CopyFrom(FS, FS.Size);

  { Pad data out to DWORD boundary - any old
    rubbish will do!}
  if FS.Size mod SizeOf(DWORD) <> 0 then
    RS.WriteBuffer(Padding, SizeOf(DWORD) -
      FS.Size mod SizeOf(DWORD));

  { Close the files }
  FS.Free;
  RS.Free;
end;

The above code should be sufficient to illustrate the problem, but it is not very elegant - and the streams should be protected by try .. finally blocks. A better solution is to create a class that encapsulates the code. A further improvement would be to permit either strings or ordinals to be used to identify the resource.

On occasion you may want to write formatted data to the resource file rather than just copy a file - this is easy to do. You need to do five things:

write a placeholder header record for your resource and record its position in the stream
write the formatted data to the file (replace the code that copies the file with code that writes the data)
keep a record of the size of the data you are writing
pad the data out to a DWORD boundary
store the length of data (excluding padding) in your header record, return to the position of the placeholder header and overwrite it.

Of course there's now the problem of getting the file information back out of the executable! This is quite a trivial process and is dealt with in another article.

You can download a worked example that demonstrates what has been described here -- it uses the above code. The .zip file contains a pair of projects. The first a program that embeds a supplied rich text file in a resource file. The second program includes the resource file and displays the rich text in a rich edit component.

Exchange items in TListView

Problem/Question/Abstract:

Exchange items in TListView

Answer:

Today I want to describe how you may exchange some items in standard TListView. For example, you have 5 items and want to swap positions for first and third items

Problem that standard TListView component haven't such method and you must realize it yourself.

We remember that the standard way from old Pascal times (for numbers) is:

procedure Swap(X, Y: Integer);
var
  s: Integer;
begin
  s := X;
  X := Y;
  Y := X
end;

Something similar we can do with TListItem too. But just to save all strings (caption+sub items) somewhere is not enough because TListItem class have a lot of other information (image indexes, pointer as Data, etc)

So correct way is to use Assign method:

procedure ExchangeItems(lv: TListView; const i, j: Integer);
var
  tempLI: TListItem;
begin
  lv.Items.BeginUpdate;
  try
    tempLI := TListItem.Create(lv.Items);
    tempLI.Assign(lv.Items.Item[i]);
    lv.Items.Item[i].Assign(lv.Items.Item[j]);
    lv.Items.Item[j].Assign(tempLI);
    tempLI.Free;
  finally
    lv.Items.EndUpdate
  end;
end;

So structure is a same as in our sample for Integer. All what we added are BeginUpdate and EndUpdate (just allow to reduce a flickering)

So if you want to exchange items in any ListView, just call this procedure...

Exploring web services in Delphi

Problem/Question/Abstract:

How to write a Web Services Server in Delphi?

Answer:

This article is a continuation of my previous article "Accessing web services using SOAP". In that article, we have seen how can we write a Web Services Client in Delphi using a WSDL file and now we are going to see how can we write a Web Services Server itself in Delphi 6.

Why Web Services?

Web services are basically designed to allow loose coupling between client and server and also they dont require clients to use a specific platform or language. i.e. it's language neutral. Mainly for these reasons among others, these services are becoming more popular and no doubt, they are going to dominate the industry in future.

How Delphi is implementing these services?

Web services server developed in Delphi are using Invokable interfaces. These are interfaces that contain Run Time Type Information(RTTI) and this information will help interpreting calls from clients. There is a separate class defined in Delphi called IInvokable and whenever we write a web services server in Delphi, it should  use this class. This class is basically derived from IInterface class.

Whenever a client uses a service by calling one of its methods, that method has to be identified and a proper response has to be given to the client. Right? For that purpose, there are two more components in addition to Invokable interfaces.

1. Dispatcher

Whenever a client requests a service by calling a specific method in the server, that request has been passed on to the Invoker. No need to say, the request will always be a SOAP message.  This dispatcher is implemented in Delphi using a separate class called THTTPSoapDispather.

2. Invoker

Once it receives the SOAP message from the Dispatcher, it finds the relevant interface and executes the call and send a response as another SOAP message. This Invoker is implemented using another class called THTTPSoapPascalInvoker.

And one more thing, as of now these two classes are designed to support only HTTP request and response.

In total, all we need is nothing but interfaces and classes that implement those interfaces. That's all. Once you desinged both, you need to register them. After that, all the request/response will be handled by both the Dispatcher and Invoker. Pretty simple?   huh?

Now let us try writing a simple Web Services Server in Delphi 6. I'm not going to give fully functionaly example of a web service server rather i'm just going to discuss what are all the steps in developing a Web services server in Delphi with some sample units.

The following is a sample Interface unit :

unit uConversionIntf;

interface

type
  ITConversion = interface(IInvokable)
    ['{878DD241-526E-48CD-90B4-2749471D2DE5}']
    //A sample function to convert Celcius to Farenheit
    function CelciusToFahrenheit(Celcius: Real): Real; stdcall;
    {Here you can define your services}
  end;

implementation

uses
  InvokeRegistry; // Unit contains methods on how to register the interface

initialization
  InvRegistry.RegisterInterface(TypeInfo(ITConversion));

end.

The unit above is a sample having some sample methods that define the web services. Here I added a function to convert Celcius to Farenheit. Like that you can define as many functions as possible. And the "['{878DD241-526E-48CD-90B4-2749471D2DE5}']" is nothing but the GUID for that interface ITConversion. This you can generate in the Delphi IDE by pressing Ctrl+Shift+G, the easiest way of creating GUID in Delphi.

The unit InvokeRegistry contains methods needed to register the interface with your system. We need to register that interface in the initialization section. That's all about defining the interface.

Then the next step is to implement the interface in a class. For that we need to create another unit with the implementation class.

Here is the sample implementation class:

unit ConversionImpl;

interface

uses
  InvokeRegistry;

type
  TConversionService = class(TInvokableClass, ITConversion)
  public
    function CelciusToFahrenheit(Celcius: Real): Real; stdcall;
  end;

implementation

function CelciusToFahrenheit(Celcius: Real): Real; stdcall;
begin
  //Here you can write the code to convert the celcius to farenheit.
end;

initialization
  InvRegistry.RegisterInvokableClass(TConversionService);
end.

Here also you can see in the initialization section that you need to register the implementation class with the invokation registry. Now we have two units, one defining the interface and the other implementing that interface in a class.

As of now, we need to create these two units by hand and add code to register both the interfaces and implementation classes; It would be nice if we have a wizard of some kind to create these two units automatically. I dont see any such wizard right now in Delphi 6 Trial Edition downloaded version. And I heard that there is a wizard available in Delphi 6 to generate these two files. If not, I'm thinking of writing such a wizard. Please keep me informed if you know anything further on this.

Next step is to create a SOAP application in Delphi and include these two units into that application. Once you are done that, the Web services server in Delphi in ready to use.

How to create a SOAP server application?

In the Delphi IDE, select New | Other | Web Services and select SOAP Server Application.
Then there will be a dialog showing you the types of web servers.
You can choose the type you want; for our example purpose, letz choose ISAPI/NSAPI Dynamic Link Library
This will create a web module with three components, out of that we discussed two of 'em already and the new component is the TWSDLHTMLPublish. (Let us see about this later in this article)

The sample source of the web module would look like this:

unit uConversion;

interface

uses
  SysUtils, Classes, HTTPApp;

type
  TWebModule1 = class(TWebModule)
    HTTPSoapDispatcher1: THTTPSoapDispatcher;
    HTTPSoapPascalInvoker1: THTTPSoapPascalInvoker;
    WSDLHTMLPublish1: TWSDLHTMLPublish;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  WebModule1: TWebModule1;

implementation

{$R *.DFM}

end.

In this unit, you can see both the dispatcher and invoker in addition to the WSDL publisher component.

Now add both the Interface and the implementation units we created before to this newly created project.
Once you added those two unit, build the application and this will result in a DLL;

How can we use this server in Delphi?

This is pretty simple. You just need to add the Interface unit into your normal Delphi application and call the functions implemented in the server.

How can we use this server in applications other than Delphi?

Here comes the WSDL file. You just need to generate the WSDL with the server you have written. How can we do that? Now comes the WSDLHTMLPublish component. This component will help you generate that WSDL file.

What you need to generate/publish that WSDL file?

You need a web server, atleast a Personal Web Server and should be running.
You just need to put that DLL in the C:\Inetpub\Scripts directory and browse that DLL through a web server. i.e. http://localhost/scripts/

So when you browse through a web server, you will be getting the WSDL file. Also if you set the AdminEnabled property of the WSDLHTMLPublish component to true, you would be able to see the administrator previleges with a click of an additional button on the browser.

This is a simple type of web server without any much complexities. The example I have explained involved only simple data types like Real, String etc., but actually you can write a server that return complex types like returning an object etc., But this would be the basic that you need to understand before writing such complex ones.

P.S.: One of our members reported me of a problem viewing the WSDL file while browsing the dll through a web server. Actually I forgot to mention one thing about that. We need to specify WSDL after the dll name while browing through a web server. i.e. http://localhost/scripts/ConversionService.dll/WSDL.

And the other problem is unloading the DLL from memory after first use. The solution for this is to stop the web server and try building the dll again. It should normally work. Because when you use for the first time through a web server, that web server will hold a reference to that dll; so if you stop the web server that reference should be freed. This is been a problem with PWS and IIS; sometimes works sometimes not!! In that case, we may need to restart the entire machine itself(which is not a solution for this) ; I have been experiencing such problems often; so if anyone has any experience on this, please keep our members posted.

OpenGL III: Moving and rotating 3D shapes

Problem/Question/Abstract:

In this article I'll show you how to create 3D shapes, which is just an extension of the last article, also you'll see how to rotate around the same shape axis or rotate around other object (like the solar system)

Answer:

Ok, this is the 3rd of a series of articles on OpenGL, so far we have seen:

OpenGL I: Hello World, Setup a Delphi OpenGL Application
OpenGL II: Moving and rotating 2D shapes

Now we're gonna expand on the last article to create 3D shapes, rotate them around their own axis and rotating objects around some other object (like a solar system)

To accomplish such thing we're still going to use the same basic OpenGL instructions but because this is graphics, one line in the wrong place makes a huge difference As I stated in my last article, OpenGL just follows instructions like "move forward", "turn left X degrees", etc, so just with that you know is not the same:

"move forward 10 units", "turn left 90 degrees"
than:
"turn left 90 degrees", "move forward 10 units"

simple, right??
well, just those simple rules will make a difference when you want to rotate an object around it's own axis or around other object axis

Rotating in the object own axis would be something like:

"move to 0, 0, 0", "move forward 10 units", "turn left X degrees", "draw a shape", "inc(X, 1.0)"

very simple, we move to a fixed position (10 units forward) turn X degrees, X gets incremented later, so that makes the shape rotate around its own axis and then we draw the shape, and increment the angle

In Delphi would be something like:

glTranslatef(-0.5, 0.0, -15.0); // Move 0.5 Units Left And 15.0 units Into The Screen
glRotatef(rquad, 0.0, 1.0, 1.0); // Rotate The Quad On The Y and Z axis ( NEW )
glBegin(GL_QUADS); // We are going to draw a cube, so let's use QUADS
glColor3f(0.0, 1.0, 0.0);
glVertex3f(0.5, 0.5, -0.5); // Top Left
glVertex3f(-0.5, 0.5, -0.5); // Top Right
{.
.
.}
glEnd();

rquad := rquad + 1.0;

Now to rotate around that object we just drew, we would have to do the following:

"cancel previous rotation", "turn left X degrees", "move 3 units into screen",  "turn right Y degrees", "draw shape"
The first important thing to notice here is that we didn't use "move 0, 0, 0", which means we're going to keep drawing from the position where we drew the last shape
The second thing is cancelling the previous rotation, why is that? Because if you don't, when you move forward X units, is going to move into whatever direction the last angle was, that might be what you want, but if you want your shape to rotate in a different axis, then you have to cancel the rotation, and then rotate to where you want and then move... confusing? luckily you'll get to play with the source code and see what happens when you cancel and when you don't.
The third thing is rotating to the angle that you want (this actually makes the rotation around the first object posible)
Move 3 units into screen, This to separate the new shape from the last, if we don't move to any direction, we will draw this shape in the same place!, maybe rotated to a different angle but in the same coordinates
Finally we do a last rotation around a new variable angle and draw the shape. This last rotation will make the new object rotate around it's own axis just like the solar system, the earth rotates around the sun, and then also rotates around it's own axis, makes sense? I hope so

let's look at the Delphi code:

//Notice we don't use glLoadIdentity here, which means we are at whatever position we drew the quad
glRotatef(-rquad, 0.0, 1.0, 1.0); // Cancel the previous rotation!!!
glRotatef(rtri, 0.0, 1.0, 0.0); // Rotate The Triangle On The Y axis (around the quad)
glTranslatef(0.0, 0.0, 3.0); // Move 3.0 Units Into The screen
glRotatef(rtri, 0.0, 0.0, 1.0);
// Let's rotate the pyramid, while we rotate around the quad
glBegin(GL_TRIANGLES); // We're gonna draw a pyramid, so let's use TRIANGLES
glColor3f(1.0, 0.0, 0.0); // Red
glVertex3f(0.0, 0.5, 0.0); // Top Of Triangle (Front)
{.
.
.}
glEnd();

rtri := rtri + 2.0;

ok, that's it on explanations, here's the source code for the drawing procedure I added a polygon to the scene just to show you how to create them Also check the coloring mix on the pyramid

function DrawGLScene(): Bool; { All Rendering Done Here }
begin
glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); //Clear Screen and Depth Buffer
glLoadIdentity(); //Reset The View

glTranslatef(-0.5, 0.0, -15.0); // Move 0.5 Units Left And 15.0 units Into The Screen
glRotatef(rquad, 0.0, 1.0, 1.0); // Rotate The Quad On The Y and Z axis ( NEW )
glBegin(GL_QUADS); // We are going to draw a cube, so let's use QUADS
glColor3f(0.0, 1.0, 0.0);
glVertex3f(0.5, 0.5, -0.5); // Top Left
glVertex3f(-0.5, 0.5, -0.5); // Top Right
glVertex3f(-0.5, 0.5, 0.5); // Bottom Right
glVertex3f(0.5, 0.5, 0.5); // Bottom Left

glColor3f(1.0, 0.5, 0.0);
glVertex3f(0.5, -0.5, -0.5); // Top Left
glVertex3f(-0.5, -0.5, -0.5); // Top Right
glVertex3f(-0.5, -0.5, 0.5); // Bottom Right
glVertex3f(0.5, -0.5, 0.5); // Bottom Left

glColor3f(1.0, 0.0, 0.0);
glVertex3f(0.5, 0.5, 0.5); // Top Left
glVertex3f(-0.5, 0.5, 0.5); // Top Right
glVertex3f(-0.5, -0.5, 0.5); // Bottom Right
glVertex3f(0.5, -0.5, 0.5); // Bottom Left

glColor3f(1.0, 1.0, 0.0);
glVertex3f(0.5, -0.5, -0.5); // Top Left
glVertex3f(-0.5, -0.5, -0.5); // Top Right
glVertex3f(-0.5, 0.5, -0.5); // Bottom Right
glVertex3f(0.5, 0.5, -0.5); // Bottom Left

glColor3f(0.0, 0.0, 1.0);
glVertex3f(-0.5, 0.5, 0.5); // Top Left
glVertex3f(-0.5, 0.5, -0.5); // Top Right
glVertex3f(-0.5, -0.5, -0.5); // Bottom Right
glVertex3f(-0.5, -0.5, 0.5); // Bottom Left

glColor3f(1.0, 0.0, 1.0);
glVertex3f(0.5, 0.5, -0.5); // Top Left
glVertex3f(0.5, 0.5, 0.5); // Top Right
glVertex3f(0.5, -0.5, 0.5); // Bottom Right
glVertex3f(0.5, -0.5, -0.5); // Bottom Left
glEnd();

//Notice we don't use glLoadIdentity here, which means we are at whatever position we drew the quad
glRotatef(-rquad, 0.0, 1.0, 1.0); // Cancel the previous rotation!!!
glRotatef(rtri, 0.0, 1.0, 0.0);
// Rotate The Triangle On The Y axis (around the quad)
glTranslatef(0.0, 0.0, 3.0); // Move 3.0 Units Into The screen
glRotatef(rtri, 0.0, 0.0, 1.0);
// Let's rotate the pyramid, while we rotate around the quad
glBegin(GL_TRIANGLES); // We're gonna draw a pyramid, so let's use TRIANGLES
glColor3f(1.0, 0.0, 0.0); // Red
glVertex3f(0.0, 0.5, 0.0); // Top Of Triangle (Front)
glColor3f(0.0, 1.0, 0.0); // Green
glVertex3f(-0.5, -0.5, 0.5); // Left Of Triangle (Front)
glColor3f(0.0, 0.0, 1.0); // Blue
glVertex3f(0.5, -0.5, 0.5); // Right Of Triangle (Front)

glColor3f(1.0, 0.0, 0.0); // Red
glVertex3f(0.0, 0.5, 0.0); // Top Of Triangle (Right)
glColor3f(0.0, 0.0, 1.0); // Blue
glVertex3f(0.5, -0.5, 0.5); // Left Of Triangle (Right)
glColor3f(0.0, 1.0, 0.0); // Green
glVertex3f(0.5, -0.5, -0.5); // Right Of Triangle (Right)

glColor3f(1.0, 0.0, 0.0); // Red
glVertex3f(0.0, 0.5, 0.0); // Top Of Triangle (Back)
glColor3f(0.0, 1.0, 0.0); // Green
glVertex3f(0.5, -0.5, -0.5); // Left Of Triangle (Back)
glColor3f(0.0, 0.0, 1.0); // Blue
glVertex3f(-0.5, -0.5, -0.5); // Right Of Triangle (Back)

glColor3f(1.0, 0.0, 0.0); // Red
glVertex3f(0.0, 0.5, 0.0); // Top Of Triangle (Left)
glColor3f(0.0, 0.0, 1.0); // Blue
glVertex3f(-0.5, -0.5, -0.5); // Left Of Triangle (Left)
glColor3f(0.0, 1.0, 0.0); // Green
glVertex3f(-0.5, -0.5, 0.5); // Right Of Triangle (Left)
glEnd();

glLoadIdentity(); // Move to (0, 0, 0)
glTranslatef(1.5, 0.0, -6.0); // Move 1.5 Right and -6.0 intro screen
glRotatef(rpol, 0.0, 0.0, 1.0); // rotate on Z axis
glColor3f(0.0, 0.0, 1.0); // Add some color
glBegin(GL_POLYGON); // Draw A Polygon (I can put many points in here)
glVertex3f(-0.5, 0.5, 0.0); // Top Left
glVertex3f(0.0, 0.75, 0.0); // Upper point
glVertex3f(0.5, 0.5, 0.0); // Top Right
glVertex3f(0.5, -0.5, 0.0); // Bottom Right
glVertex3f(0.0, -0.75, 0.0); // Lower point
glVertex3f(-0.5, -0.5, 0.0); // Bottom Left
glEnd();

rtri := rtri + 2.0;
rquad := rquad + 1.0;
rpol := rpol + 1.0;

Result := True
end;

That's it, I hope it wasn't too confusing, play with the code, see what happens when you comment this or that line.

Convert HTML to RTF

Problem/Question/Abstract:

How to convert HTML to RTF?

Answer:

{ HTML to RTF by Falk Schulze }

procedure HTMLtoRTF(html: string; var rtf: TRichedit);
var
i, dummy, row: Integer;
cfont: TFont; { Standard sschrift }
Tag, tagparams: string;
params: TStringList;

function GetTag(s: string; var i: Integer; var Tag, tagparams: string): Boolean;
var
a_tag: Boolean;
begin
GetTag := False;
Tag := '';
tagparams := '';
a_tag := False;

while i <= Length(s) do
begin
Inc(i);
// es wird nochein tag ge�ffnet --> das erste war kein tag;
if s[i] = '<' then
begin
GetTag := False;
Exit;
end;

if s[i] = '>' then
begin
GetTag := True;
Exit;
end;

if not a_tag then
begin
if s[i] = ' ' then
begin
if Tag <> '' then
a_tag := True;
end
else
Tag := Tag + s[i];
end
else
tagparams := tagparams + s[i];
end;
end;

procedure GetTagParams(tagparams: string; var params: TStringList);
var
i: Integer;
s: string;
gleich: Boolean;

// kontrolliert ob nach dem zeichen bis zum n�chsten zeichen ausser
// leerzeichen ein Ist-Gleich-Zeichen kommt
function notGleich(s: string; i: Integer): Boolean;
begin
notGleich := True;
while i <= Length(s) do
begin
Inc(i);
if s[i] = '=' then
begin
notGleich := False;
Exit;
end
else if s[i] <> ' ' then
Exit;
end;
end;
begin
Params.Clear;
s := '';
for i := 1 to Length(tagparams) do
begin
if (tagparams[i] <> ' ') then
begin
if tagparams[i] <> '=' then
gleich := False;
if (tagparams[i] <> '''') and (tagparams[i] <> '"') then
s := s + tagparams[i]
end
else
begin
if (notGleich(tagparams, i)) and (not Gleich) then
begin
params.Add(s);
s := '';
end
else
Gleich := True;
end;
end;
params.Add(s);
end;

function HtmlToColor(Color: string): TColor;
begin
Result := StringToColor('$' + Copy(Color, 6, 2) + Copy(Color, 4,
2) + Copy(Color, 2, 2));
end;

procedure TransformSpecialChars(var s: string; i: Integer);
var
c: string;
z, z2: Byte;
i2: Integer;
const
nchars = 9;
chars: array[1..nchars, 1..2] of string =
(('�', '�'), ('�', '�'), ('�', '�'), ('�', '�'),
('�', '�'), ('�', '�'), ('�', '�'), ('<', '<'),
('>', '>'));
begin
// Maximal die n�chsten 7 zeichen auf sonderzeichen �berpr�fen
c := '';
i2 := i;
for z := 1 to 7 do
begin
c := c + s[i2];
for z2 := 1 to nchars do
begin
if chars[z2, 1] = c then
begin
Delete(s, i, Length(c));
Insert(chars[z2, 2], s, i);
Exit;
end;
end;
Inc(i2);
end;
end;

// HtmlTag Schriftgr��e in pdf gr��e umwandeln
function CalculateRTFSize(pt: Integer): Integer;
begin
case pt of
1: Result := 6;
2: Result := 9;
3: Result := 12;
4: Result := 15;
5: Result := 18;
6: Result := 22;
else
Result := 30;
end;
end;

// Die Font-Stack Funktionen
type
fontstack = record
Font: array[1..100] of tfont;
Pos: Byte;
end;

procedure CreateFontStack(var s: fontstack);
begin
s.Pos := 0;
end;

procedure PushFontStack(var s: Fontstack; fnt: TFont);
begin
Inc(s.Pos);
s.Font[s.Pos] := TFont.Create;
s.Font[s.Pos].Assign(fnt);
end;

procedure PopFontStack(var s: Fontstack; var fnt: TFont);
begin
if (s.Font[s.Pos] <> nil) and (s.Pos > 0) then
begin
fnt.Assign(s.Font[s.Pos]);
// vom stack nehmen
s.Font[s.Pos].Free;
Dec(s.Pos);
end;
end;

procedure FreeFontStack(var s: Fontstack);
begin
while s.Pos > 0 do
begin
s.Font[s.Pos].Free;
Dec(s.Pos);
end;
end;
var
fo_cnt: array[1..1000] of tfont;
fo_liste: array[1..1000] of Boolean;
fo_pos: TStringList;
fo_stk: FontStack;
wordwrap, liste: Boolean;
begin
CreateFontStack(fo_Stk);

fo_Pos := TStringList.Create;

rtf.Lines.BeginUpdate;
rtf.Lines.Clear;
// Das wordwrap vom richedit merken
wordwrap := rtf.wordwrap;
rtf.WordWrap := False;

// erste Zeile hinzuf�gen
rtf.Lines.Add('');
Params := TStringList.Create;

cfont := TFont.Create;
cfont.Assign(rtf.Font);

i := 1;
row := 0;
Liste := False;
// Den eigentlichen Text holen und die Formatiorung merken
rtf.selstart := 0;
if Length(html) = 0 then
Exit;
repeat;

if html[i] = '<' then
begin
dummy := i;
GetTag(html, i, Tag, tagparams);
GetTagParams(tagparams, params);

// Das Font-Tag
if Uppercase(Tag) = 'FONT' then
begin
// Schrift auf fontstack sichern
pushFontstack(fo_stk, cfont);
if params.Values['size'] <> '' then
cfont.Size := CalculateRTFSize(StrToInt(params.Values['size']));

if params.Values['color'] <> '' then
cfont.Color :=
htmltocolor(params.Values['color']);
end
else if Uppercase(Tag) = '/FONT' then
popFontstack(fo_stk, cfont)
else {// Die H-Tags-�berschriften } if Uppercase(Tag) = 'H1' then
begin
// Schrift auf fontstack sichern
pushFontstack(fo_stk, cfont);
cfont.Size := 6;
end
else if Uppercase(Tag) = '/H1' then
popFontstack(fo_stk, cfont)
else {// Die H-Tags-�berschriften } if Uppercase(Tag) = 'H2' then
begin
// Schrift auf fontstack sichern
pushFontstack(fo_stk, cfont);
cfont.Size := 9;
end
else if Uppercase(Tag) = '/H2' then
popFontstack(fo_stk, cfont)
else {// Die H-Tags-�berschriften } if Uppercase(Tag) = 'H3' then
begin
// Schrift auf fontstack sichern
pushFontstack(fo_stk, cfont);
cfont.Size := 12;
end
else if Uppercase(Tag) = '/H3' then
popFontstack(fo_stk, cfont)
else {// Die H-Tags-�berschriften } if Uppercase(Tag) = 'H4' then
begin
// Schrift auf fontstack sichern
pushFontstack(fo_stk, cfont);
cfont.Size := 15;
end
else if Uppercase(Tag) = '/H4' then
popFontstack(fo_stk, cfont)
else {// Die H-Tags-�berschriften } if Uppercase(Tag) = 'H5' then
begin
// Schrift auf fontstack sichern
pushFontstack(fo_stk, cfont);
cfont.Size := 18;
end
else if Uppercase(Tag) = '/H5' then
popFontstack(fo_stk, cfont)
else {// Die H-Tags-�berschriften } if Uppercase(Tag) = 'H6' then
begin
// Schrift auf fontstack sichern
pushFontstack(fo_stk, cfont);
cfont.Size := 22;
end
else if Uppercase(Tag) = '/H6' then
popFontstack(fo_stk, cfont)
else {// Die H-Tags-�berschriften } if Uppercase(Tag) = 'H7' then
begin
// Schrift auf fontstack sichern
pushFontstack(fo_stk, cfont);
cfont.Size := 27;
end
else if Uppercase(Tag) = '/H7' then
popFontstack(fo_stk, cfont)
else // Bold-Tag
if Uppercase(Tag) = 'B' then
cfont.Style := cfont.Style + [fsbold]
else if Uppercase(Tag) = '/B' then
cfont.Style := cfont.Style - [fsbold]
else // Italic-Tag
if Uppercase(Tag) = 'I' then
cfont.Style := cfont.Style + [fsitalic]
else if Uppercase(Tag) = '/I' then
cfont.Style := cfont.Style - [fsitalic]
else // underline-Tag
if Uppercase(Tag) = 'U' then
cfont.Style := cfont.Style + [fsunderline]
else if Uppercase(Tag) = '/U' then
cfont.Style := cfont.Style - [fsunderline]
else // underline-Tag
if Uppercase(Tag) = 'UL' then
liste := True
else if Uppercase(Tag) = '/UL' then
begin
liste := False;
rtf.Lines.Add('');
Inc(row);
rtf.Lines.Add('');
Inc(row);
end
else // BR - Breakrow tag
if (Uppercase(Tag) = 'BR') or (Uppercase(Tag) = 'LI')
then
begin
rtf.Lines.Add('');
Inc(row);
end;

// unbekanntes tag als text ausgeben
// else rtf.Lines[row]:=RTF.lines[row]+'<'+tag+' '+tagparams+'>';

fo_pos.Add(IntToStr(rtf.selstart));
fo_cnt[fo_pos.Count] := TFont.Create;
fo_cnt[fo_pos.Count].Assign(cfont);
fo_liste[fo_pos.Count] := liste;
end
else
begin
// Spezialzeichen �bersetzen
if html[i] = '&' then
Transformspecialchars(html, i);

if (Ord(html[i]) <> 13) and (Ord(html[i]) <> 10) then
rtf.Lines[row] := RTF.Lines[row] + html[i];
end;

Inc(i);

until i >= Length(html);
// dummy eintragen
fo_pos.Add('999999');

// Den fertigen Text formatieren
for i := 0 to fo_pos.Count - 2 do
begin
rtf.SelStart := StrToInt(fo_pos[i]);
rtf.SelLength := StrToInt(fo_pos[i + 1]) - rtf.SelStart;
rtf.SelAttributes.Style := fo_cnt[i + 1].Style;
rtf.SelAttributes.Size := fo_cnt[i + 1].Size;
rtf.SelAttributes.Color := fo_cnt[i + 1].Color;

// die font wieder freigeben;
fo_cnt[i + 1].Free;
end;

// die Paragraphen also Listen setzen
i := 0;
while i <= fo_pos.Count - 2 do
begin
if fo_liste[i + 1] then
begin
rtf.SelStart := StrToInt(fo_pos[i + 1]);
while fo_liste[i + 1] do
Inc(i);
rtf.SelLength := StrToInt(fo_pos[i - 1]) - rtf.SelStart;
rtf.Paragraph.Numbering := nsBullet;
end;
Inc(i);
end;
rtf.Lines.EndUpdate;
Params.Free;
cfont.Free;
rtf.WordWrap := wordwrap;
FreeFontStack(fo_stk);
end;

Drawing a line without using the LineTo function

Problem/Question/Abstract:

How can I draw a line without using the LineTo function?

Answer:

{
Enables you do draw a line if for some reason you
cannot use the delphi LineTo procedure.
For example, for drawing higher resolution lines
or drawing lines in 2D arrays.
}

procedure DrawLine(APoint1, APoint2: TPoint; ACanvas: TCanvas);
var
Lpixel, LMaxAxisLength: integer;
LRatio: Real;
begin
LMaxAxisLength := Max(abs(APoint1.X - APoint2.X), abs(APoint1.Y - APoint2.Y));
for Lpixel := 0 to LMaxAxisLength do
begin
LRatio := Lpixel / LMaxAxisLength;
ACanvas.Pixels[APoint1.X + Round((APoint2.X - APoint1.X) * LRatio),
APoint1.Y + Round((APoint2.Y - APoint1.Y) * LRatio)] :=
ACanvas.Pen.Color;
end;
end;

// Draw a double resolution line

procedure DrawLineDouble(APoint1, APoint2: TPoint; ACanvas: TCanvas);
var
Lpixel, LMaxAxisLength: integer;
LRatio: Real;
LPoint: TPoint;
begin
LMaxAxisLength := max(abs(APoint1.X - APoint2.X), abs(APoint1.Y - APoint2.Y));
for Lpixel := 0 to LMaxAxisLength do
begin
LRatio := Lpixel / LMaxAxisLength;
LPoint.X := APoint1.X + Round((APoint2.X - APoint1.X) * LRatio);
LPoint.Y := APoint1.Y + Round((APoint2.Y - APoint1.Y) * LRatio);
with ACAnvas do
begin
Pixels[LPoint.X * 2, LPoint.Y * 2] := clBlack;
Pixels[(LPoint.X * 2) + 1, LPoint.Y * 2] := clBlack;
Pixels[LPoint.X * 2, (LPoint.Y * 2) + 1] := clBlack;
Pixels[(LPoint.X * 2) + 1, (LPoint.Y * 2) + 1] := clBlack;
end;
end;
end;

Safety Design with a Static Instance

Problem/Question/Abstract:

The Singelton Pattern is widely used, on the other side OP lacks of statics, means one instance for all classes. No problem with the following design which acts like a time-server.

Answer:

Sometimes operations are performed on a class itself, rather than on instances of a class (that is, objects). This happens, for example, when you call a constructor method using a class reference.

TTimeKeeper = class;
TTimeKeeperClass = class of TTimeKeeper;

You can always refer to a specific class using its name, but at times it is necessary to declare variables or parameters that take classes as values, and in these situations you need class-reference types.
In our case we need a class-method and a global function too to get the one and only instance:

class function Instance: TTimeKeeper;

function TimeKeeper: TTimeKeeper; //global function

When this function is called, a safety instance is returned:

function TimeKeeper: TTimeKeeper;
begin
Result := TTimeKeeper.Instance;
end;

A class method is a method (other than a constructor) that operates on classes instead of objects. The definition of a class method must begin with the reserved word class. A class method can be called through a class reference or an object reference.
So the client calls the class method first:

procedure TMainDlg.NewBtnClick(Sender: TObject);
var
myTimer: TTimeKeeper;
begin
myTimer := TimeKeeper;
StatusBar.Panels[0].Text := timeToStr(myTimer.now);
end;

And the class method returns the protected and local instance:

class function TTimeKeeper.Instance: TTimeKeeper;
// Single Instance function - create when first needed
begin
Assert(Assigned(TimeKeeperClass));
if not Assigned(TimeKeeperInstance) then
TimeKeeperInstance := TimeKeeperClass.SingletonCreate;
Result := TimeKeeperInstance;
end;

unit SafetyTimeKeeper;

interface

uses
SysUtils;

type
ESingleton = class(Exception);

TInvalidateDestroy = class(TObject)
protected
class procedure SingletonError;
public
destructor Destroy; override;
end;

TTimeKeeper = class;
TTimeKeeperClass = class of TTimeKeeper;
TTimeKeeper = class(TInvalidateDestroy)
private
class procedure Shutdown;
function GetTime: TDateTime;
function GetDate: TDateTime;
function GetNow: TDateTime;
protected
// Allow descendents to set a new class for the instance:
class procedure SetTimeKeeperClass(aTimeKeeperClass: TTimeKeeperClass);
// Actual constructor and destructor that will be used:
constructor SingletonCreate; virtual;
destructor SingletonDestroy; virtual;
public
// Not for use - for obstruction only:
class procedure Create;
class procedure Free(Dummy: integer);
{$IFNDEF VER120}{$WARNINGS OFF}{$ENDIF}
// This generates warning in D3. D4 has reintroduce keyword to solve this
class procedure Destroy(Dummy: integer);
{$IFDEF VER120} reintroduce;
{$ENDIF}
// Simple interface:
class function Instance: TTimeKeeper;
property Time: TDateTime read GetTime;
property Date: TDateTime read GetDate;
property Now: TDateTime read GetNow;
end;
{$IFNDEF VER120}{$WARNINGS ON}{$ENDIF}

function TimeKeeper: TTimeKeeper;

implementation

class procedure TInvalidateDestroy.SingletonError;
// Raise an exception in case of illegal use
begin
raise ESingleton.CreateFmt('Illegal use of %s singleton instance!', [ClassName]);
end;

destructor TInvalidateDestroy.Destroy;
// Protected against use of default destructor
begin
SingletonError;
end;

{ TTimeKeeper }
var
TimeKeeperInstance: TTimeKeeper = nil;
TimeKeeperClass: TTimeKeeperClass = TTimeKeeper;

class procedure TTimeKeeper.SetTimeKeeperClass(aTimeKeeperClass: TTimeKeeperClass);
// Allow change of instance class
begin
Assert(Assigned(aTimeKeeperClass));
if Assigned(TimeKeeperInstance) then
SingletonError;
TimeKeeperClass := aTimeKeeperClass;
end;

class function TTimeKeeper.Instance: TTimeKeeper;
// Single Instance function - create when first needed
begin
Assert(Assigned(TimeKeeperClass));
if not Assigned(TimeKeeperInstance) then
TimeKeeperInstance := TimeKeeperClass.SingletonCreate;
Result := TimeKeeperInstance;
end;

class procedure TTimeKeeper.Shutdown;
// Time to close down the show
begin
if Assigned(TimeKeeperInstance) then
begin
TimeKeeperInstance.SingletonDestroy;
TimeKeeperInstance := nil;
end;
end;

constructor TTimeKeeper.SingletonCreate;
// Protected constructor
begin
inherited Create;
end;

destructor TTimeKeeper.SingletonDestroy;
// Protected destructor
begin
// We cannot call inherited Destroy; here!
// It would raise an ESingleton exception
end;

// Protected against use of default constructor

class procedure TTimeKeeper.Create;
begin
SingletonError;
end;
// Protected against use of Free

class procedure TTimeKeeper.Free(Dummy: integer);
begin
SingletonError;
end;

class procedure TTimeKeeper.Destroy(Dummy: integer);
begin
SingletonError;
end;

// Property access methods

function TTimeKeeper.GetDate: TDateTime;
begin
Result := SysUtils.Date;
end;

function TTimeKeeper.GetNow: TDateTime;
begin
Result := SysUtils.Now;
end;

function TTimeKeeper.GetTime: TDateTime;
begin
Result := SysUtils.Time;
end;

// Simplified functional interface

function TimeKeeper: TTimeKeeper;
begin
Result := TTimeKeeper.Instance;
end;

initialization
finalization
// Destroy when application closes
TTimeKeeper.Shutdown;
end.

Add a horizontal scrollbar to a TListBox

Problem/Question/Abstract:

How to add a horizontal scrollbar to a TListBox

Answer:

A quick way to add the horizontal scroll bar and set its scroll range is to use SendMessage. Put the following command in the OnCreate or OnActivate methods to make the TListbox 300 pixels wide.

uses
ShellAPI

{ ... }
SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, 300, 0);
{ ... }

Create a menu item into the Delphi menu?

Problem/Question/Abstract:

How to create a menu item into the Delphi menu?

Answer:

uses ToolsApi, Menus;

{....}

var
item: TMenuItem;
begin
{get reference to delphi's mainmenu. You can handle it like a common TMainMenu}
with (BorlandIDEServices as INTAServices).GetMainMenu do
begin
item := TMenuItem.Create(nil);
item.Caption := 'A Mewn caption';
Items.Add(item);
end;
end;

Check if the mouse cursor is outside a TForm

Problem/Question/Abstract:

How can I find out if the cursor is leaving a Delphi form?

Answer:

Solve 1:

Add a handler for the CM_MOUSELEAVE message to the form:

unit Unit1;

interface

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

type
TForm1 = class(TForm)
Memo1: TMemo;
private
{ Private declarations }
procedure CMMouseEnter(var msg: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.CMMouseEnter(var msg: TMessage);
begin
if msg.lparam = 0 then
memo1.Lines.add('Entered ' + Name)
else
memo1.Lines.add('Entered ' + TControl(msg.lparam).Name);
end;

procedure TForm1.CMMouseLeave(var msg: TMessage);
begin
if msg.lparam = 0 then
memo1.Lines.add('Left ' + Name)
else
memo1.Lines.add('Left ' + TControl(msg.lparam).Name);
end;

end.


Solve 2:

Place the following code in your form's OnMouseMove event handler, and you'll see SetCapture/ ReleaseCapture in action (plus its side-effects):

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if (GetCapture < > Handle) then {OnMouseEnter}
begin
Beep;
Caption := 'Hello';
SetCapture(Handle);
end
else if (PtInRect(ClientRect, Point(X, Y))) then {OnMouseOver}
Caption := 'X=' + IntToStr(X) + ':Y=' + IntToStr(Y)
else {OnMouseOut}
begin
Beep;
Caption := 'Goodbye!';
ReleaseCapture;
end;
end;


Solve 3:

You can use a timer (the smaller the interval the more sensitive the program) and in the OnTimer event handler control the mouse position to check if the mouse is inside or outside the form:

procedure TForm1.Timer1Timer(Sender: TObject);
var
pt: TPoint;
begin
GetCursorPos(pt);
if (pt.x < Left) or (pt.x > left + Width) then
Caption := 'Out'
else if (pt.y < Top) or (pt.y > Top + Height) then
Caption := 'Out'
else
Caption := 'In';
end;