advertisement moved to bottom of page to improve page loading time
9  Interesting Q&A from various newsgroups
unsorted, uncommented, simply copied from NG - mails (without written permission of the authors)
Please mail me if you do not agree - want to have removed your mail here.


last updated: Feb-22 1999    Index 1QA go to 1QA index page


   Subject: Re: How to make a gradient bar?
      Date: Wed, 03 Feb 1999 15:14:33 -0600
      From: "Joe C. Hecht" <joehecht@gte.net>
 Organization: Offshore Technology
 Newsgroups: borland.public.delphi.graphics
 

Hunte Swee wrote:
>
> Can any one tell me how to make a component that has gradient color such
> as from darkgray to lightgray. Mostly like Netscape Communicator
> Preference options?
>
> Hunte
> Hunte Information Technologies (HIT)
 

This may be of some help...

Q) How do I paint the color spectrum of a rainbow, and if the spectrum
is clicked on, how do I calculate what color was clicked on?

A) The following example demonstrates painting a color spectrum, and
calculating the color of a given a point on the spectrum. Two procedures
are presented: PaintRainbow() and ColorAtRainbowPoint(). the
PaintRainbow()
procedure paints a spectrum from red to magenta if the WrapToRed
parameter
is false, or paint red to red if the WrapToRed parameter is true. The
rainbow can
progress either in a horizontal or vertical progression. The
ColorAtRainbowPoint()
function returns a TColorRef containing the color at a given point in
the rainbow.

Example:

procedure PaintRainbow(Dc : hDc; {Canvas to paint to}
                       x : integer; {Start position X}
                       y : integer;  {Start position Y}
                       Width : integer; {Width of the rainbow}
                       Height : integer {Height of the rainbow};
                       bVertical : bool; {Paint verticallty}
                       WrapToRed : bool); {Wrap spectrum back to red}
var
  i : integer;
  ColorChunk : integer;
  OldBrush : hBrush;
  OldPen : hPen;
  r : integer;
  g : integer;
  b : integer;
  Chunks : integer;
  ChunksMinus1 : integer;
  pt : TPoint;
begin
  OffsetViewportOrgEx(Dc,
                      x,
                      y,
                      pt);

  if WrapToRed = false then
    Chunks := 5 else
    Chunks := 6;
  ChunksMinus1 := Chunks - 1;

  if bVertical = false then
    ColorChunk := Width div Chunks else
    ColorChunk := Height div Chunks;

 {Red To Yellow}
  r := 255;
  b := 0;
  for i := 0 to ColorChunk do begin
    g:= (255 div ColorChunk) * i;
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc, i, 0, 1, Height, PatCopy) else
      PatBlt(Dc, 0, i, Width, 1, PatCopy);
    DeleteObject(SelectObject(Dc, OldBrush));
  end;

 {Yellow To Green}
  g:=255;
  b:=0;
  for i := ColorChunk  to (ColorChunk * 2) do begin
    r := 255 - (255 div ColorChunk) * (i - ColorChunk);
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc, i, 0, 1, Height, PatCopy) else
      PatBlt(Dc, 0, i, Width, 1, PatCopy);
    DeleteObject(SelectObject(Dc, OldBrush));
  end;

 {Green To Cyan}
  r:=0;
  g:=255;
  for i:= (ColorChunk * 2) to (ColorChunk * 3) do begin
    b := (255 div ColorChunk)*(i - ColorChunk * 2);
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc, i, 0, 1, Height, PatCopy) else
      PatBlt(Dc, 0, i, Width, 1, PatCopy);
    DeleteObject(SelectObject(Dc,OldBrush));
  end;

 {Cyan To Blue}
  r := 0;
  b := 255;
  for i:= (ColorChunk * 3) to (ColorChunk * 4) do begin
    g := 255 - ((255 div ColorChunk) * (i - ColorChunk * 3));
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc, i, 0, 1, Height, PatCopy) else
      PatBlt(Dc, 0, i, Width, 1, PatCopy);
    DeleteObject(SelectObject(Dc, OldBrush));
  end;

 {Blue To Magenta}
  g := 0;
  b := 255;
  for i:= (ColorChunk * 4) to (ColorChunk * 5) do begin
    r := (255 div ColorChunk) * (i - ColorChunk * 4);
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc, i, 0, 1, Height, PatCopy) else
      PatBlt(Dc, 0, i, Width, 1, PatCopy);
    DeleteObject(SelectObject(Dc, OldBrush))
  end;

  if WrapToRed <> false then begin
   {Magenta To Red}
    r := 255;
    g := 0;
    for i := (ColorChunk * 5) to ((ColorChunk * 6) - 1) do begin
      b := 255 -((255 div ColorChunk) * (i - ColorChunk * 5));
      OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r,g,b)));
      if bVertical = false then
        PatBlt(Dc, i, 0, 1, Height, PatCopy) else
        PatBlt(Dc, 0, i, Width, 1, PatCopy);
      DeleteObject(SelectObject(Dc,OldBrush));
    end;
  end;

 {Fill Remainder}
  if (Width - (ColorChunk * Chunks) - 1 ) > 0 then begin
    if WrapToRed <> false then begin
      r := 255;
      g := 0;
      b := 0;
    end else begin
      r := 255;
      g := 0;
      b := 255;
    end;
    OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b)));
    if bVertical = false then
      PatBlt(Dc,
             ColorChunk * Chunks,
             0,
             Width - (ColorChunk * Chunks),
             Height,
             PatCopy) else
      PatBlt(Dc,
             0,
             ColorChunk * Chunks,
             Width,
             Height - (ColorChunk * Chunks),
             PatCopy);
    DeleteObject(SelectObject(Dc,OldBrush));
  end;
  OffsetViewportOrgEx(Dc,
                      Pt.x,
                      Pt.y,
                      pt);
end;

function ColorAtRainbowPoint(ColorPlace : integer; {place on the rainbow
to get the color}
                             RainbowWidth : integer; {width of the
rainbow}
                             WrapToRed : bool) : TColorRef; {does the
rainbow wrap back around to red}
var
  ColorChunk : integer;
  ColorChunkIndex : integer;
  ColorChunkStart : integer;
begin
  if ColorPlace = 0 then begin
    result := RGB(255, 0, 0);
    exit;
 end;
{WhatChunk}
  if WrapToRed <> false then
    ColorChunk := RainbowWidth div 6 else
    ColorChunk := RainbowWidth div 5;
    ColorChunkStart := ColorPlace div ColorChunk;
    ColorChunkIndex := ColorPlace mod ColorChunk;
  case ColorChunkStart of
   0 : result := RGB(255,
                     (255 div ColorChunk) * ColorChunkIndex,
                     0);
   1 : result := RGB(255 - (255 div ColorChunk) * ColorChunkIndex,
                     255,
                     0);
   2 : result := RGB(0, 255, (255 div ColorChunk) * ColorChunkIndex);
   3 : result := RGB(0,
                     255 - (255 div ColorChunk) * ColorChunkIndex,
                     255);
   4 : result := RGB((255 div ColorChunk) * ColorChunkIndex,
                     0,
                     255);
   5 : result := RGB(255,
                     0,
                     255 - (255 div ColorChunk) * ColorChunkIndex);
  else
    if WrapToRed <> false then
      result := RGB(255, 0, 0) else
      result := RGB(255, 0, 255);
  end;{Case}
end;
 

procedure TForm1.FormPaint(Sender: TObject);
begin
  PaintRainbow(Form1.Canvas.Handle,
               0,
               0,
               Form1.ClientWidth,
               Form1.ClientHeight,
               false,
               true);

end;

procedure TForm1.FormResize(Sender: TObject);
begin
  InvalidateRect(Form1.Handle, nil, false);
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  Color : TColorRef;
begin
  Color := ColorAtRainbowPoint(y,
                               Form1.ClientWidth,
                               true);
  ShowMessage(IntToStr(GetRValue(Color)) + #32 +
              IntToStr(GetGValue(Color)) + #32 +
              IntToStr(GetBValue(Color)));
end;
 

Joe
--
Joe C. Hecht
http://home1.gte.net/joehecht/index.htm



   Subject: Re: How to add button in title bar ?
      Date: 3 Feb 1999 21:26:05 GMT
      From: nolenj@aol.com (NolenJ)
 Newsgroups: comp.lang.pascal.delphi.misc

unit Main;

interface

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

type
  TForm1 = class(TForm)
    procedure FormResize(Sender: TObject);
  private
    CaptionBtn : TRect;
    procedure DrawCaptButton;
    procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint;
    procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE;
    procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT;
    procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;
    procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message
WM_NCLBUTTONDOWN;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

const
  htCaptionBtn = htSizeLast + 1;
{$R *.DFM}

procedure TForm1.DrawCaptButton;
var
  xFrame,
  yFrame,
  xSize,
  ySize  : Integer;
  R : TRect;
begin
  //Dimensions of Sizeable Frame
  xFrame := GetSystemMetrics(SM_CXFRAME);
  yFrame := GetSystemMetrics(SM_CYFRAME);

  //Dimensions of Caption Buttons
  xSize  := GetSystemMetrics(SM_CXSIZE);
  ySize  := GetSystemMetrics(SM_CYSIZE);

  //Define the placement of the new caption button
  CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2,
                       yFrame + 2, xSize - 2, ySize - 4);

  //Get the handle to canvas using Form's device context
  Canvas.Handle := GetWindowDC(Self.Handle);

  Canvas.Font.Name := 'Symbol';
  Canvas.Font.Color := clBlue;
  Canvas.Font.Style := [fsBold];
  Canvas.Pen.Color := clYellow;
  Canvas.Brush.Color := clBtnFace;

  try
    DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect, False, False, False);
    //Define a smaller drawing rectangle within the button
    R := Bounds(Width - xFrame - 4 * xSize + 2,
                       yFrame + 3, xSize - 6, ySize - 7);
    with CaptionBtn do
      Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W');
  finally
    ReleaseDC(Self.Handle, Canvas.Handle);
    Canvas.Handle := 0;
  end;
end;

procedure TForm1.WMNCPaint(var Msg : TWMNCPaint);
begin
  inherited;
  DrawCaptButton;
end;

procedure TForm1.WMNCActivate(var Msg : TWMNCActivate);
begin
  inherited;
  DrawCaptButton;
end;

procedure TForm1.WMSetText(var Msg : TWMSetText);
begin
  inherited;
  DrawCaptButton;
end;

procedure TForm1.WMNCHitTest(var Msg : TWMNCHitTest);
begin
  inherited;
  with Msg do
    if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top)) then
      Result := htCaptionBtn;
end;

procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown);
begin
  inherited;
  if (Msg.HitTest = htCaptionBtn) then
    ShowMessage('You hit the button on the caption bar');
end;
 

I got this from the web site:
http://www.alpine.net/~robert     or    http://www.delumpa.com

I don't remember which one.
If you go there you can download the project to see it work.

procedure TForm1.FormResize(Sender: TObject);
begin
  //Force a redraw of caption bar if form is resized
  Perform(WM_NCACTIVATE, Word(Active), 0);
end;

end.



   Subject: Re: Writing/reading from serial ports
      Date: Mon, 08 Feb 1999 15:36:59 GMT
      From: pandeng@telepath.com (Steve Schafer (TeamB))
 Organization: TeamB
 Newsgroups: borland.public.turbopascal

On 8 Feb 1999 13:27:53 GMT, "Antony" <agiles@tin.it> wrote:

>I've read everything I have on Turbo Pascal, but I still can't find how to
>read/write from a serial port or, better still, 2 serial ports. Can anyone
>give me a simple example to get me started?

The reason you haven't found anything is that there isn't much in the
way of support for serial ports in Turbo Pascal, and the reason for
that is that there isn't much support for serial ports from DOS. Any
kind of serious serial port work requires either getting your hands
dirty with writing interrupt service routines, or using a third-party
toolkit. For an example of the latter, visit the Turbo Power Software
web site (www.turbopower.com) and look at Async Pro. I strongly
recommend that you use a third-party toolkit if this is anything more
than a "hobbyist" sort of application.

For an example of the former technique, here is some very bare-bones
code for accessing serial ports:

First, the main workhorse unit, TC_COMM.PAS. This file was written
many years ago for a specific application, so there may be a few
places where it's not as generic as it could be:

--------8<--------
unit Tc_Comm;  { RS-232C communications }

interface

uses Dos;

const
  CommBufMin = 256;
  CommBufMax = 65000;

  { comm port constants }

  cpComm1 = $00;
  cpComm2 = $01;

  { baud rate constants }

  br110  = $00;
  br150  = $20;
  br300  = $40;
  br600  = $60;
  br1200 = $80;
  br2400 = $A0;
  br4800 = $C0;
  br9600 = $E0;

  { parity constants }

  paNone = $00;
  paOdd  = $08;
  paEven = $18;

  { stop bits constants }

  sb1 = $00;
  sb2 = $04;

  { data bits constants }

  db7 = $02;
  db8 = $03;

  { comm error constants }

  ceOK      =  0;  { no error }
  ceInUse   = -1;  { can't initialize a comm port already in use }
  ceBuffer  = -2;  { unable to allocate comm buffer }

type
  TCommPort = cpComm1..cpComm2;

  PComm = ^TComm;
  TComm = object
    CommPort: TCommPort;
    constructor Init (ACommPort: TCommPort; ABaudRate, AParity,
      ADataBits, AStopBits: Byte; BufferSize: Word);
    destructor Done; virtual;
    function BufEmpty: Boolean; virtual;
    function Read: Char; virtual;
    procedure Write (C: Char); virtual;
    end;

function CommError: Integer;

implementation

const
  PICReg = $20;
  PICMask = $21;
  PICClear = $20;
  BIOSSerialIntNo = $14;
  CommIntNo: array[TCommPort] of Byte = ($0C,$0B);
  CommIntBit: array[TCommPort] of Byte = ($10,$08);
  CommData: array[TCommPort] of Word = ($03F8,$02F8);
  CommInt: array[TCommPort] of Word = ($03F9,$02F9);
  CommIntID: array[TCommPort] of Word = ($03FA,$02FA);
  CommLineCtl: array[TCommPort] of Word = ($03FB,$02FB);
  CommModemCtl: array[TCommPort] of Word = ($03FC,$02FC);
  CommLineSts: array[TCommPort] of Word = ($03FD,$02FD);
  CommModemSts: array[TCommPort] of Word = ($03FE,$02FE);
  BufSize: array[TCommPort] of Word = (0,0);

var
  BufTail,BufHead,BufSeg,BufOfs: array[TCommPort] of Word;
  BufPtr,CommISRSave: array[TCommPort] of Pointer;
  CommErrorVar: Integer;

procedure SetCommError (Value: Integer);

begin
CommErrorVar := Value;
end;

function CommError: Integer;

begin
CommError := CommErrorVar;
SetCommError (ceOK);
end;

procedure EnableInterrupts;
Inline ($FB);  { sti }

{$S-}

procedure Comm1ISR;  interrupt;

begin
Mem[BufSeg[cpComm1]:BufOfs[cpComm1]+BufTail[cpComm1]]
  := Port[CommData[cpComm1]];
Inc (BufTail[cpComm1]);
if BufTail[cpComm1] >= BufSize[cpComm1] then BufTail[cpComm1] := 0;
EnableInterrupts;
Port[PICReg] := PICClear;
end;

procedure Comm2ISR;  interrupt;

begin
Mem[BufSeg[cpComm2]:BufOfs[cpComm2]+BufTail[cpComm2]]
  := Port[CommData[cpComm2]];
Inc (BufTail[cpComm2]);
if BufTail[cpComm2] >= BufSize[cpComm2] then BufTail[cpComm2] := 0;
EnableInterrupts;
Port[PICReg] := PICClear;
end;

{$S+}

constructor TComm.Init (ACommPort: TCommPort;
ABaudRate,AParity,ADataBits,
  AStopBits: Byte; BufferSize: Word);

var
  R: Registers;
  Mask: Byte;
  TempPtr: Pointer;

begin
SetCommError (ceOK);
if BufSize[ACommPort] <> 0 then
  begin
  SetCommError (ceInUse);
  Fail;
  end;
CommPort := ACommPort;
BufHead[CommPort] := 0;
BufTail[CommPort] := 0;
if BufferSize < CommBufMin then BufferSize := CommBufMin
else if BufferSize > CommBufMax then BufferSize := CommBufMax;
GetMem (TempPtr,BufferSize);
if TempPtr = nil then
  begin
  SetCommError (ceBuffer);
  Fail;
  end;
BufSize[CommPort] := BufferSize;
BufSeg[CommPort] := Seg (TempPtr^);
BufOfs[CommPort] := Ofs (TempPtr^);
asm
  xor ah,ah
  mov al,ABaudRate
  or al,AParity
  or al,AStopBits
  or al,ADataBits
  xor dx,dx
  mov dl,CommPort
  int BIOSSerialIntNo
  end;
case CommPort of
  cpComm1: SetIntVec (CommIntNo[CommPort],@Comm1ISR);
  cpComm2: SetIntVec (CommIntNo[CommPort],@Comm2ISR);
  end;
Port[CommModemCtl[CommPort]] := $0B;
Port[CommInt[CommPort]] := 1;
Mask := Port[PICMask];
Mask := Mask and (not CommIntBit[CommPort]);
Port[PICMask] := Mask;
end;

destructor TComm.Done;

var
  Mask: Byte;
  TempPtr: Pointer;

begin
Mask := Port[PICMask];
Mask := Mask or CommIntBit[CommPort];
Port[PICMask] := Mask;
TempPtr := Ptr (BufSeg[CommPort],BufOfs[CommPort]);
SetIntVec (CommIntNo[CommPort],CommISRSave[CommPort]);
FreeMem (TempPtr,BufSize[CommPort]);
BufSize[CommPort] := 0;
end;

function TComm.BufEmpty;

begin
BufEmpty := BufTail[CommPort] = BufHead[CommPort];
end;

function TComm.Read;

var
  C: Char;

begin
repeat { do nothing }
  until BufHead[CommPort] <> BufTail[CommPort];
Read := Char (Mem[BufSeg[CommPort]:BufOfs[CommPort] +
BufHead[CommPort]]);
Inc (BufHead[CommPort]);
if BufHead[CommPort] >= BufSize[CommPort] then BufHead[CommPort] := 0;
end;

procedure TComm.Write (C: Char);

begin
repeat { do nothing }
  until (Port[CommLineSts[CommPort]] and $20) <> 0;
Port[CommData[CommPort]] := Byte (C);
end;

var
  ExitSave: Pointer;

procedure CommExit; far;

var
  Mask: Byte;

begin
ExitProc := ExitSave;
Mask := Port[PICMask];
Mask := Mask or CommIntBit[cpComm1] or CommIntBit[cpComm2];
Port[PICMask] := Mask;
SetIntVec (CommIntNo[cpComm1],CommISRSave[cpComm1]);
SetIntVec (CommIntNo[cpComm2],CommISRSave[cpComm2]);
end;

begin
ExitSave := ExitProc;
ExitProc := @CommExit;
GetIntVec (CommIntNo[cpComm1],CommISRSave[cpComm1]);
GetIntVec (CommIntNo[cpComm2],CommISRSave[cpComm2]);
end.
--------8<--------

And here's a simple terminal emulator program that demonstrates use of
the above unit:

--------8<--------
program TerminalEmulator;

uses Crt,Tc_Comm;

const
  kbNull  = #$00;
  kbAltX  = #$2D;
  kbCtrlT = #$14;
  kbCtrlX = #$18;
  kbEnter = #$0D;

var
  Comm: TComm;

procedure MainLoop;

var
  Quit: Boolean;
  C: Char;

begin
Quit := False;
repeat
  while not (Comm.BufEmpty) do
    begin
    C := Comm.Read;
    Write (C);
    if C = kbEnter then WriteLn;
    end;
  if Keypressed then
    begin
    C := ReadKey;
    case C of
      kbNull: case ReadKey of
        kbAltX: Quit := True;
        end;
      ' '..'~': Comm.Write (C);
      kbCtrlT,kbCtrlX,kbEnter: Comm.Write (C);
      end;
    end;
  until Quit;
end;

begin
Comm.Init (cpComm1,br9600,paNone,db8,sb1,1024);
MainLoop;
end.
--------8<--------
-Steve



   Subject: Re: Musical Notes Do - Re - Mi etc
      Date: Sun, 07 Feb 1999 14:39:18 -0800
      From: Rich Pasco <pasco@best.com>
Newsgroups: comp.lang.pascal.borland

Ing. Franz Glaser wrote:

> Sound expects the frequency in Hertz. A (in German we name it
> so, not La) has 440 Hz and all the other notes have frequencies
> with a factor of the 12th root of 2.

Correct.  The 12th root of two includes the black keys and white keys,
but the names Do Re Mi etc. apply only to the major keys (the white keys
in the key of C.)  The American names are:

   Do    Re    Mi Fa    So     La     Ti Do
   C  C# D  D# E  F  F# G  G#  A  A#  B  C
261.6                          440        523.3
  Hz                            Hz         Hz

(view in fixed-pitch font)

     - Rich



   Subject: Re: Musical Notes Do - Ray - Me etc
      Date: Sun, 07 Feb 1999 14:32:45 +0100
      From: "Frédéric" <fb@rz-online.de>
 Newsgroups: comp.lang.pascal.borland

odtaa wrote:

> Help!! Does anyone know the codes I should put into Sound to get Do Ray
> Me etc.

Here are the frequencies for the different notes. Consider that the
procedure Sound does not allow floating point numbers to be passed a a
parameter. I recommend you use Round instead of Trunc, or better, you round
it yourself, that's some code less in your program.

C  : 261.63
C# : 277.20
D  : 293.66
D# : 311.60
E  : 329.63
F  : 349.23
F# : 370
G  : 392
G# : 416
A  : 440
B  : 493.88
C  : 523.25
C# : 554.80

You can double these values to obtain the frequency of the same note on the
next octave. The result is not always exact, but it's a simple formula.



   Subject: Re: Smallest time measuring time unit
      Date: Mon, 15 Feb 1999 17:26:36 GMT
      From: christoph.roschger@usa.net (Christoph Roschger)
 Organization: Chello Austria
 Newsgroups: comp.lang.pascal.borland

On Thu, 11 Feb 1999 23:38:25 +0800, "HK Chang" <hkchang@bigfoot.com>
wrote:

>Is there any one know if turbo pascal has a more fine measuring time unit? I
>only know that it can measure down to 1/100 second. How I have more fine
>measuring unit?
>
>HK Chang.

Hi!
Just try the following unit. The handling is very easy:
- Turn the timer on with 'timer_on'
- Read the counter by using 'readtimer'. It returns a longint value
  which shows, how many milliseconds  the timer is already running.
  When you set 'freq' to a higher value, you can even get higher
  precision.
- After using the timer, you should turn it off by using 'timer_off'.

I hope, this unit works,
Bye, Christoph
------------Code-------------
unit timer;
interface
 procedure timer_on;
 function readtimer: longint;
 procedure timer_off;

const freq=1000;

implementation
uses dos;

Var OTimerInt: pointer;
    counter:word;
    on: boolean;

procedure SetFrequency(Proc : pointer; Freq : word);
var izaehler : word;
    oldv : pointer;
begin;
 asm cli end;
 izaehler := 1193180 DIV Freq;
 Port[$43] := $36;
 Port[$40] := Lo(IZaehler);
 Port[$40] := Hi(IZaehler);
 Getintvec(8,OTimerInt);
 SetIntVec(8,Proc);
 counter:=0;
 asm sti end;
end;
 

procedure timer_off;
begin;
  asm cli end;
  port[$43] := $36;
  Port[$40] := 0;
  Port[$40] := 0;
  SetIntVec(8,OTimerInt);
  asm sti end;
  on:=false;
end;

procedure Timer_interrupt; interrupt;
begin;
  inc(counter);
  port[$20] := $20;
end;

procedure timer_on;
begin
 if on=true then
   Timer_off;
 on:=true;
 setfrequency(@Timer_Interrupt,freq);
end;

function readtimer;
begin
  readtimer:=counter;
end;
 

begin
 on:=false;
end.



   Subject: Re: Turbo Pascal and error 163    (RTE 150..170)
      Date: Fri, 19 Feb 1999 09:47:27 GMT
      From: horst.kraemer@snafu.de (Horst Kraemer)
 Newsgroups: borland.public.turbopascal

On Fri, 19 Feb 1999 08:52:21 GMT, Mivi@OCCData.Dk (Michael Vilhelmsen)
wrote:

> The last few months our programs have broked down with error 163.
> This error is not mentioned by Turbo Pascal (It stops at 162 and continueds at 200).
>
> Do anyone know what this error code means ??
> Or maybe where I can find some information on the subject ??
 

TP I/O errors from 150 up to 170  are  errors reported to INT_$24
(critical error handler). TP's handler extracts the error code, adds
150 and "implants" this error code as a return value to the library
function in which this error occurs. Thus you encountered "critical
error 13 = 0Dh, sharing violation".

See Ralph Browns interrupt list for a complete reference.



Table 2233
Values for critical error code:
 00h  150  write-protection violation attempted
 01h  151  unknown unit for driver
 02h  152  drive not ready
 03h  153  unknown command given to driver
 04h  154  data error (bad CRC)
 05h  155  bad device driver request structure length
 06h  156  seek error
 07h  157  unknown media type
 08h  158  sector not found
 09h  159  printer out of paper
 0Ah  160  write fault
 0Bh  161  read fault
 0Ch  162  general failure
 0Dh  163  (DOS 3.0+) sharing violation
 0Eh  164  (DOS 3.0+) lock violation
 0Fh  165  invalid disk change
 10h  166  (DOS 3.0+) FCB unavailable
 11h  167  (DOS 3.0+) sharing buffer overflow
 12h  168  (DOS 4.0+) code page mismatch
 13h  169  (DOS 4.0+) out of input
 14h  170  (DOS 4.0+) insufficient disk space

Copied from Ralf Brown's Interrupt List, #s 150..170 included by Franz Glaser



Regards
Horst


   Subject: Re: Struktur BMP   (German, BMP file structure)
      Date: Tue, 23 Feb 1999 15:05:41 GMT
      From: haugk@usa.net (Steffen Haugk)
 Newsgroups:de.comp.lang.pascal.delphi, z-netz.sprachen.delphi

Hallo Jens,

ich möchte die Struktur des BMP Formates noch etwas herausheben:

In einem Bitmap file kann ein Bitmap (BMP), ein Pointer (PTR) oder ein
Icon (ICO) stecken.

Im File hast DU

File Header
Bitmap Header
Color Palette
Bitmap Data

Der FILE HEADER ist 14 bytes lang:

Bytes
2       FileType (4D42h "BM" für einzelnes Bitmap)
4       FileSize (größe des fileheaders + größe des bitmap headers -
meistens Null)
2       XHotSpot (für pointer und icons)
2       YHotSpot (für pointer und icons)
4       BitmapOffset hier fängt die BitmapData an gemessen vom
Dateianfang

Bitmap Header
hier gibt es version 1.x und version 2.x Header
die ersten 4 bytes geben dir die größe des bitmap headers
ist der bitmap neader 12 byte lang, so ist es ein version 1.x bitmap,
größer 12 (mindestens 16) bedeutet Version 2.x bitmap.

Es ist wichtig das abzufragen, den die nächsten beiden Felder sind
Breite und Höhe, in Version 1.x je 2 byte, in Version 2.x je 4 byte
lang.

BITMAP HEADER version 1.x:
bytes
4       size of bitmapheader    wie der name schon sagt
2       breite  wie der name schon sagt
2       höhe    wie der name schon sagt
2       numplanes       Anzahl Farbebenen = 1
2       BitsPerPixel    1 (schwarz/weiß), 4, 8 oder 24 (true colour)

Gescanned wird in Zeilen, beachte, daß Breite kein scan-line-padding
berücksichtigt

Es scheint so, als ob eine Farbebene die Größe
Breite * Höhe * BitsPerPixel hätte, in Wirklichkeit aber kommt
scan-line-padding für jede Zeile dazu (siehe unten)

BITMAP HEADER version 2.x

Byte
4       Size    Größe bitmapheader (16 <= size <= 64)
4       Breite
4       Höhe
2       numplanes
2       BitsPerPixel
   und nun zusätzliche Felder
4       Kompression     0-unkomprmiert
                        1- 8-bit RLE
                        2- 4-bit RLE
                        3- Hufman 1D algorithmus
                        4- 24-Bit RLE
4       imagesize       Größe der eigentlichen bitmap Daten
4       x-resolution    Bildschirmauflösung x, kann man benutzen zum
   genaueren Anzeigen
4       y-resolution    Bildschirmauflösung y
4       ColorsUsed      Anzahl der benutzen Farbeinträge (bitte
  beachten, falls ColorsUsed=0 und BitsperPixel<24 dann beinhaltet die
  Palette alle möglichen Farben für die Pixeltiefe (siehe Palette weiter
  unten))
4       ColorsImportant Anzahl der wichtigen Farbeinträge (wenn man zB
   nicht alle darstellen kann, kann man wenigstens die wichtigen Farben
   dabei haben)
2       Units           muß 0 sein
2       Reserved        padding, um eine 4 Bytegrenze zu erhalten, immer 0
2       Recording       muß 0 sein, bedeutet von links nach rechts,
   von unten nach oben
2       Rendering       bezeichnet Halbtonalgorithmus
                        0- ohne
                        1- error diffusion halftonig
                        2- processing  Algorithm for Noncoded Document
Acquisition (PANDA)
                        3- super-circle halftonig
4       Size1           benutzt bei halftoning
4       Size2           benutzt bei halftoning
4       ColorEncoding   muß 0 sein, bedeutet RGB
4       Identifier      anwednungsspezifisch

Du musst zuerst Size lesen, denn nicht alle Felder sind immer
enthalten, Bei Size=16 zB geht es bloß bis BitsPerPixel. Header größer
als 64 sollte wahrscheinlich ein neues Format sein.
 

PALETTE version 1.x
Jedes Palettenelement hat 3 byte
Byte
1       Blau (0-255)
1       Grün (0-255)
1       Rot (0-255)

Die Gröse der Palette ist
BitPerPixel     Palettengröße
1               2
4               16
8               256
24              0 (true color)

Man kann diese angabe auch überprüfen:
anzahlpaletteneinträge=(BitmapOffset - BMPFileHeaderGröße -
BitmapHeaderGröße) / GrößePalettenElement

GrößePalettenElement=3 wie wir wissen

Es ist sinnvoll zu überprüfen, den ColorsUsed kann kleiner sein als
die oben berechnete anzahlpaletteneinträge (habe ich schon gehabt, bei
RLE komprimierten Bitmaps)

PALETTE version 2.x
Jedes Palettenelement hat 4 byte
Byte
1       Blau (0-255)
1       Grün (0-255)
1       Rot (0-255)
0       padding (immer 0)

Ein Paletten-Element hat also 4 Byte, sonst alles wie oben. Um zu
wissen ob 3Byte oder 4Byte Paletteneinträge mußt du also unbedingt die
größe des bitmap headers überprüfen

IMAGE DATA
Ich will jetzt nicht auf Kompression kommen, aber vielleicht doch noch
kurz zu den eigentlichen Bitmap Daten.

Die bitmap daten  sind eine Serie von entweder paletteindizes oder den
eigentlichen RGB Farbwerten (nämlich bei True Color).

Gescanned wird in Zeilen von oben nach unten  /?), beginnend links. Eine
Scanzeile muß auf einer 4Byte Grenze enden, deshalb gibt es padding
wenn nötig, Beim Lesen ignorieren!

Der Bildursprung liegt also links unten.

Schwarz-weiß bilder haben 8 Pixel in einem Byte, wenn eine Zeile
fertig ist wird nicht nur das Byte aufgefült, sondern auch bis zu drei
weitere, bis man an eine 4Byte grenze kommt.

4Bit pixel sind zu zwei pixel pro byte gepackt
8BitPixel sind ein Pixel pro Byte
Die werte sind geweils Palettenindizes
24BitPixel  speichern nacheinander Rot,Grün und BlauWerte ab, es gibt
keine Palette,

Das war die kleine Einführung, bei weiteren Fragen bitte email (es sei
denn, es ist von generellem Interesse)

HTH,
Steffen


tpqa index tpqa_8 back  tpqa_10 forward tp_index faq_page

Get your own FREE HOMEPAGE