Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PCTV2N3.ZIP/SHADES.ZIP/SHADES.PAS

Pascal/Delphi Source File | 1991-06-13 | 5.5 KB | 232 lines

{ shades.pas -- Sample After Dark TPW DLL by Tom Swan }

{$X+}                   { Enable extended syntax }

library Shades;

{$R shades.res}         { Link in resources from this file }

uses WinTypes, WinProcs, ADUnit;

const
  max_Index    = 100;   { Maximum number of shapes visible }
  dx1: Integer = 4;     { Delta values for controlling }
  dy1: Integer = 10;    {  the animation's personality. }
  dx2: Integer = 3;
  dy2: Integer = 9;

type
  ShapeRec = record     { Describes each graphic shape }
    X1, Y1, X2, Y2 : Integer;     { Location }
    Color: TColorRef;             { RGB color }
  end;

var
  ShapeArray: array[0 .. max_Index - 1] of ShapeRec;
  Index: Integer;       { Index for ShapeArray }
  Erasing: Boolean;     { True if erasing old Shapes }

{----- Shades Graphics Routines -----}

{- Return -1 if N < 0 or +1 if N >= 0 }
function Sign(N: Integer): Integer;
begin
  if N < 0 then Sign := -1 else Sign := 1
end;

{- Create new shape, direction, and color }
procedure MakeNewShape(Dc: HDC; R: TRect; Index: Integer);
  procedure NewCoord(var C, Change: Integer; Max: Integer;
    var Color: TColorRef);
  var
    Temp: Integer;
  begin
    Temp := C + Change;
    if (Temp < 0) or (Temp > Max) then
    begin
      Change := Sign(-Change) * (3 + Random(12));
      repeat
        Color := GetNearestColor(Dc,
          RGB(Random(256), Random(256), Random(256)))
      until Color <> GetBkColor(Dc)
    end else
      C := Temp
  end;
begin
  with ShapeArray[Index] do
  begin
    NewCoord(X1, dx1, R.Right, Color);
    NewCoord(Y1, dy1, R.Bottom, Color);
    NewCoord(X2, dx2, R.Right, Color);
    NewCoord(Y2, dy2, R.Bottom, Color)
  end
end;

{- Draw or erase a shape identified by Index }
procedure DrawShape(Dc: HDC; Index: Integer);
var
  OldPen, Pen: HPen;
  OldROP: Integer;
begin
  with ShapeArray[Index] do
  if X1 >= 0 then
  begin
    Pen := CreatePen(ps_Solid, 1, Color);
    OldPen := SelectObject(Dc, Pen);
    OldROP := SetROP2(Dc, r2_XorPen);
    Rectangle(Dc, X1, Y1, X2, Y2);
    SelectObject(Dc, OldPen);
    DeleteObject(Pen);
    SetROP2(Dc, OldROP)
  end
end;

{- Initialize graphics variables }
procedure InitShades;
var
  I: Integer;
begin
  Index := 0;
  Erasing := False;
  for I := 0 to max_Index - 1 do
    ShapeArray[I].X1 := -1
end;

{----- After Dark Functions -----}

{- Early initializations. Not used }
function DoPreInitialize: Integer;
begin
  DoPreInitialize := 1
end;

{- Initialize new graphics }
function DoInitialize: Integer;
begin
  InitShades;
  DoInitialize := noError
end;

{- Blank the display. Optional }
function DoBlank: Integer;
var
  R: TRect;
begin
  with LpModule^.ptRgnSize do
    SetRect(R, 0, 0, X, Y);
  FillRect(DC, R, GetStockObject(black_Brush))
end;

{- Draw one "frame" of the animation }
function DoDrawFrame: Integer;
var
  R: TRect;
  OldIndex: Integer;
begin
  with LPSystem^.ptScreenSize do
    SetRect(R, 0, 0, X, Y);
  OldIndex := Index;
  if Index = max_Index - 1 then
  begin
    Index := 0;
    Erasing := True
  end else
    Inc(Index);
  if Erasing then DrawShape(Dc, Index);
  ShapeArray[Index] := ShapeArray[OldIndex];
  MakeNewShape(Dc, R, Index);
  DrawShape(Dc, Index);
  DoDrawFrame := noError
end;

{- Shutdown animation }
function DoClose: Integer;
begin
  InitShades;  { Reinitialize }
  DoClose := noError
end;

{- Initialize control panel. Not used }
function DoSelected: Integer;
begin
  DoSelected := noError
end;

{- Perform custom about-box graphics. Not used }
function DoAbout: Integer;
begin
  DoAbout := noError
end;

{- Respond to control panel buttons. Not used }
function DoButtonMessage(IButtonID: Integer): Integer;
begin
  DoButtonMessage := noError
end;

{- Message dispatcher. DO NOT MODIFY! }
function Module(IMessage: Integer; HDrawDC: HDC;
  HADSystem: THandle): Integer; export;
var
  IError: Integer;
  I: Integer;
begin
  DC := HDrawDC;         { Save display context in global var }
  HSystem := HADSystem;  { Save AD system handle in global var }
  IError := 0;           { Unless changed by a function result }
  LpSystem := GlobalLock(HSystem);
  if LpSystem <> nil then
  begin
    LpModule := GlobalLock(LpSystem^.hModuleInfo);
    if LpModule <> nil then
    begin
      case IMessage of
        preInitialize:
          IError := DoPreInitialize;
        initialize:
          begin
            Randomize;
            IError := Initialize
          end;
        blank:
          IError := DoBlank;
        drawFrame:
          IError := DoDrawFrame;
        adClose:
          IError := DoClose;
        moduleSelected:
          begin
            LpModule^.hModule := hLibInst;
            for I := 0 to 3 do
              LpModule^.iControlID[I] := I + 1;
            IError := DoSelected
          end;
        about:
          IError := DoAbout;
        buttonMessage .. buttonMessage + 3:
          IError := DoButtonMessage(IMessage - buttonMessage);
      end;
      GlobalUnlock(LpSystem^.HModuleInfo)
    end;
    GlobalUnlock(HSystem)
  end;
  Module := IError
end;

{- Export DLL public routines }

exports
  Module index 1;

{- DLL entry code }

begin
  HLibInst := HInstance
end.


{--------------------------------------------------------------
  Copyright (c) 1991 by Tom Swan. All rights reserved.
  Revision 1.00    Date: 6/12/1991
---------------------------------------------------------------}