ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/WINDOWS/PROGRAM/PCHART.ZIP/PCHART.PAS

Pascal/Delphi Source File | 1991-05-02 | 16.0 KB | 588 lines

{**************************************************}
{                    Chart 1.0                     }
{                    Written in                    }
{             Turbo Pascal for Windows             }
{                Copyright (c) 1991                }
{                  Zack Urlocker                   }
{                    05/02/91                      }
{**************************************************}

program PCharts;

{ This is a simple implementation of a charting program written
  in Turbo Pascal for Windows using the ObjectWindows application
  framework.  The program is divided into several object types:

  TChartApplication      --creates and shows the main window
  TChartDialog           --allows editing of data items
  TChartWindow           --responds to Windows messages, menu commands,
                           keyboard and mouse events
  TChart and descendants --chart objects that can draw, rescale etc
                           these are in the Charts unit
  TDict and TAssoc       --data management objects
                           these are in the Dicts unit
}

{$R PChart.res}        { Link in resources }

{$IFDEF Final}        { Remove debug code for final version}
{$D-,I-,L-,R-,S-}
{$ELSE}
{$D+,I+,L+,R+,S+}
{$ENDIF}

uses Dicts, WObjects, WinTypes, WinProcs, Strings, StdDlgs, Charts;

const
 cm_New    = 501;       { Menu items }
 cm_Open   = 502;
 cm_Save   = 503;
 cm_SaveAs = 504;
 cm_Exit   = 508;
 cm_About  = 509;
 cm_HBar   = 555;
 cm_VBar   = 556;
 cm_V3DBar = 557;
 cm_Pie    = 558;
 cm_Change = 552;
 cm_SetName= 553;
 cm_Help   = 600;
 cm_CmdMode= 601;      { For Lotus style slash (/) key commands }

 id_Label  = 101;       { Dialog box fields}
 id_Value  = 102;
 id_Delete = 104;
 fieldLen  = 16;

type

  { The application defines startup behavior for the window. }
  TChartApplication = object(TApplication)
    procedure InitInstance; virtual;
    procedure InitMainWindow; virtual;
  end;

  { Dialog transfer record }
  ItemTransferBuffer = record
    LabelStr, ValueStr : array[0..FieldLen-1] of char;
  end;

  { The dialog is used for input of new data items. }
  PChartDialog = ^TChartDialog;
  TChartDialog = object(TDialog)
    LabelEdit, valueEdit : PEdit;
    constructor Init(AParent: PWindowsObject; ATitle:PChar);
    procedure Delete(var Msg:TMessage); virtual id_First + id_Delete;
  end;

  { The window responds to messages and controls the game board. }
  PChartWindow = ^TChartWindow;
  TChartWindow = object(TWindow)
    Name : PChar;     { Name for file I/O     }
    Chart : PChart;   { Pointer to a chartl   }
    Saved : Boolean;  { has chart been saved? }
    ItemBuffer : ItemTransferBuffer; { for ChartDialog }
    constructor Init(AParent: PWindowsObject; ATitle: PChar);
    procedure GetWindowClass(var WndClass: TWndClass); virtual;
    procedure redraw;
    function CanClose: Boolean; virtual;
    procedure IOError(ErrMessage : PChar);
    procedure SetCaption(FName : PChar);
    function Read(fName : PChar): Boolean;
    function Write(fName : PChar): Boolean;

    { menu response methods }
    procedure NewFile(var Msg: TMessage); virtual cm_First + cm_New;
    procedure Open(var Msg: TMessage); virtual cm_First + cm_Open;
    procedure Save(var Msg: TMessage); virtual cm_First + cm_Save;
    procedure SaveAs(var Msg: TMessage); virtual cm_First + cm_SaveAs;
    procedure Exit(var Msg: TMessage); virtual cm_First + cm_Exit;
    procedure HBar(var Msg: TMessage); virtual cm_First + cm_HBar;
    procedure VBar(var Msg: TMessage); virtual cm_First + cm_VBar;
    procedure V3DBar(var Msg: TMessage); virtual cm_First + cm_V3DBar;
    procedure Pie(var Msg: TMessage); virtual cm_First + cm_Pie;
    procedure Change(var Msg: TMessage); virtual cm_First + cm_Change;
    procedure SetName(var Msg: TMessage); virtual cm_First + cm_SetName;
    procedure About(var Msg: TMessage); virtual cm_First + cm_About;
    procedure Help(var Msg: TMessage); virtual cm_First + cm_Help;
    procedure CmdMode(var Msg: TMessage); virtual cm_First + cm_CmdMode;

    { windows message response methods }
    procedure Paint(DC: HDC; var PaintInfo: TPaintStruct); virtual;
    procedure wmSetFocus(var Msg: TMessage); virtual wm_SetFocus;
    procedure wmKillFocus(var Msg: TMessage); virtual wm_KillFocus;
    procedure wmLButtonDown(var Msg: TMessage); virtual wm_LButtonDown;
    procedure wmKeyDown(var Msg: TMessage); virtual wm_KeyDown;
    procedure wmSize(var Msg: TMessage); virtual wm_Size;
  end;


{--------------------------------------------------}
{ TChartApplication's method implementations:      }
{--------------------------------------------------}

{ Load the accelerator table for hotkeys }
procedure TChartApplication.InitInstance;
begin
  Tapplication.InitInstance;
  HAccTable := LoadAccelerators(HInstance, 'ChartKeys');
end;

{ Start the main window }
procedure TChartApplication.InitMainWindow;
begin
  MainWindow := New(PChartWindow,
                Init(nil, 'PChart : (untitled)'));
end;


{--------------------------------------------------}
{ TChartDialog method implementations:             }
{--------------------------------------------------}

{ The edit controls will contain the transfer data. }
constructor TChartDialog.Init(AParent: PWindowsObject; ATitle:PChar);
begin
  TDialog.Init(AParent, ATitle);
  new(LabelEdit, initResource(@Self, id_Label, fieldLen));
  new(ValueEdit, initResource(@Self, id_Value, fieldLen));
end;

{ Respond to Delete Button by transfering data out.
  This is automatically done if the user presses Ok. }
procedure TChartDialog.Delete(var Msg:TMessage);
begin
  TransferData(tf_GetData);
  EndDlg(id_Delete);
end;


{--------------------------------------------------}
{ TChartWindow's method implementations:           }
{--------------------------------------------------}

{ Initialize all fields to starting values }
constructor TChartWindow.Init(AParent: PWindowsObject; ATitle: PChar);
var Msg : TMessage;
begin
  TWindow.Init(AParent, ATitle);
  Chart := new(PVbarChart, init);
  Saved := True;
  getMem(Name, 255);
  StrPcopy(ItemBuffer.LabelStr, 'Item');
  StrPCopy(ItemBuffer.ValueStr, '50');
  redraw;
  with attr do
  begin
    w:=400;          { Force window size }
    h:=300;
  end;
end;

{ Override default cursor, icon, menu }
procedure TChartWindow.GetWindowClass(var WndClass: TWndClass);
begin
  TWindow.GetWindowClass(WndClass);
  WndClass.Style := 0;
  WndClass.hCursor := LoadCursor(hInstance, 'ChartCur');
  WndClass.hIcon := LoadIcon(hInstance, 'ChartIco');
  WndClass.lpszMenuName := 'ChartMenu';
end;

{ Update the chart by rescaling, redrawing }
procedure TChartWindow.redraw;
begin
  Chart^.area.x := attr.w;
  Chart^.area.y := attr.h;
  Chart^.reScale;
  invalidateRect(HWindow, nil, True);
end;

{ Make sure the user has saved his work before closing }
function TChartWindow.CanClose: Boolean;
var Reply : Integer;
    Msg : TMessage;
begin
  if not Saved then
  begin
    Reply := MessageBox(HWindow, 'File has not been saved. Save file before closing?',
             'Warning', mb_IconStop or mb_YesNoCancel);
    if Reply = id_Yes then
      Save(Msg);
  end;
  CanClose := Saved or (Reply <> id_Cancel);
end;

{ Create a New chart }
procedure TChartWindow.NewFile(var Msg: TMessage);
begin
  Chart := new(PVbarChart, init);
  Saved := True;
  StrDispose(Name);
  GetMem(Name, 255);
  setName(Msg);
  StrPcopy(ItemBuffer.LabelStr, 'Item');
  StrPCopy(ItemBuffer.ValueStr, '50');
  redraw;
end;

{ Open a chart file }
procedure TChartWindow.Open(var Msg: TMessage);
var FName : PChar;
begin
  GetMem(FName, 255);
  strPCopy(FName, '*.cht');
  if application^.execDialog(New(PFileDialog,
   init(@Self, PChar(sd_FileOpen), FName))) = ID_Ok then
   begin
     Chart := new(PChart, init);
     StrCopy(Name, FName);
     if Read(FName) then
       redraw
     else
       newFile(Msg);
   end;
  Strdispose(FName);
end;

{ Save the chart with existing name.  Call SaveAs if necessary. }
procedure TChartWindow.Save(var Msg: TMessage);
begin
  if strScan(Name, '.') = nil then
    strCat(Name, '.cht');
  if strLen(Name) > 4 then
    write(Name)
  else
    SaveAs(Msg);
end;

{ Save the chart under a new name }
procedure TChartWindow.SaveAs(var Msg: TMessage);
var len : Integer;
  OldName : PChar;  { in case user cancels command }
begin
  getMem(OldName, 255);
  strCopy(OldName, Name);
  { give a default name and extension }
  if strLen(Name) = 0 then
  begin
    len := StrLen(Chart^.Name);
    if len > 8 then len := 8;
    StrLCopy(Name, Chart^.Name, len);
  end;
  if StrScan(Name, '.') = nil then
    StrCat(Name, '.cht');
  if StrLen(Name) < 5 then
    StrPCopy(Name, 'Chart.cht');

  if application^.execDialog(New(PFileDialog,
     init(@Self, PChar(sd_FileSave), Name))) = ID_Ok then
       write(Name)
  else
       StrCopy(Name, OldName);
  strDispose(OldName);
end;

{ Report an I/O Error }
procedure TChartWindow.IOError(ErrMessage : PChar);
var Msg : Array[0..255] of Char;
begin
  MessageBeep(0);
  strCopy(Msg, ErrMessage);
  MessageBox(0, StrCat(Msg, Name), 'File Error', mb_IconExclamation);
end;

{ Set the caption of the window to the filename }
procedure TChartWindow.SetCaption(FName : PChar);
var Caption : PChar;
begin
  getMem(Caption, 255);
  strPCopy(Caption, 'PChart : ');
  SetWindowText(Hwindow, strCat(Caption, FName));
  strDispose(Caption);
end;

{ Read a chart from a file. }
function TChartWindow.Read(FName : PChar) : Boolean;
var S : TBufStream;
begin
  S.Init(FName, StOpenRead, 1024);
  if S.Status <> stOk then
    IOError('Can''t open file ')
  else
    begin
      Chart := PChart(S.Get);
      if S.Status <> stOk then
    IOError('Can''t read file ')
      else
        setCaption(Name);
    end;
  S.Done;
  Read := (S.Status = stOk);
end;

{ Store a chart onto a file by storing onto a stream. }
function TChartWindow.Write(FName : PChar) : Boolean;
var S : TBufStream;
begin
  S.Init(FName, stCreate, 1024);
  if S.Status <> stOk then
    IOError('Can''t create file ')
  else
    begin
      S.put(Chart);
      if S.Status <> stOk then
    IOError('Can''t write file ')
      else
      begin
        setCaption(Name);
        Saved := True;
      end;
    end;
  S.Done;
  Write := (S.status = StOk);
end;

{ Make it a Horizontal Bar chart }
procedure TChartWindow.HBar(var Msg: TMessage);
Var Chart2 : PChart;
begin
  Chart2 := new(PHBarChart, init);
  Chart2^.Items := Chart^.items;
  Chart2^.Name := Chart^.Name;
  Chart := PHBarChart(Chart2);
  redraw;
end;

{ Make it a Vertical Bar chart }
procedure TChartWindow.VBar(var Msg: TMessage);
Var Chart2 : PChart;
begin
  Chart2 := new(PVBarChart, init);
  Chart2^.Items := Chart^.items;
  Chart2^.Name := Chart^.Name;
  Chart := PVBarChart(Chart2);
  redraw;
end;

{ Make it a Vertical Bar chart }
procedure TChartWindow.V3DBar(var Msg: TMessage);
Var Chart2 : PChart;
begin
  Chart2 := new(PV3DBarChart, init);
  Chart2^.Items := Chart^.items;
  Chart2^.Name := Chart^.Name;
  Chart := PV3DBarChart(Chart2);
  redraw;
end;

{ Make it a Pie chart }
procedure TChartWindow.Pie(var Msg: TMessage);
Var Chart2 : PChart;
begin
  Chart2 := new(PPieChart, init);
  Chart2^.Items := Chart^.items;
  Chart2^.Name := Chart^.Name;
  Chart := PPieChart(Chart2);
  redraw;
end;

{ Change, add or delete an item }
procedure TChartWindow.Change(var Msg: TMessage);
var  Dlg: TChartDialog;
     Reply, Value, errorPos : Integer;
begin
  Dlg.Init(@Self, 'ChartDlg');
  Dlg.TransferBuffer := @ItemBuffer;
  Reply := Dlg.Execute;
  Dlg.Done;
  if Reply = id_Ok then
  begin
    { If valid, add the item to the chart }
    val(ItemBuffer.ValueStr, value, errorPos);
    if errorPos = 0 then
    begin
      if Chart = nil then
        Chart := new(PVBarChart, init);
      Chart^.add(ItemBuffer.LabelStr, Value);
    end
    else
      MessageBeep(0);
  end
  else if Reply = id_Delete then
     if Chart = nil then
       MessageBeep(0)
     else
       Chart^.Remove(ItemBuffer.LabelStr);
  { Adjust the chart }
  if Reply <> id_Cancel then
  begin
    redraw;
    Saved := False;
  end;
end;

{ Set or change the name of the chart }
procedure TChartWindow.SetName(var Msg: TMessage);
var TempName : PChar;
begin
  GetMem(TempName, 40);
  if Chart^.Name <> nil then
    strLCopy(TempName, Chart^.Name, 40);
  if application^.ExecDialog(New(PInputDialog,
      Init(@Self, 'Chart', 'Enter chart name:',
      TempName, 40))) = id_Ok then
  begin
     if chart^.Name <> nil then
       strDispose(Chart^.Name);
     getMem(Chart^.Name, 40);
     strCopy(Chart^.Name, TempName);
     redraw;
  end;
  strDispose(TempName);
end;

{ Display About box }
procedure TChartWindow.About(var Msg: TMessage);
var  Dlg: TDialog;
begin
  Dlg.Init(@Self, 'AboutDlg');
  Dlg.Execute;
  Dlg.Done;
end;

{ Display Help dialog }
procedure TChartWindow.Help(var Msg: TMessage);
var  Dlg: TDialog;
begin
  Dlg.Init(@Self, 'HelpDlg');
  Dlg.Execute;
  Dlg.Done;
end;

{ Respond to Lotus style commands from slash (/) accelerator }
procedure TChartWindow.CmdMode(var Msg: TMessage);
begin
  sendMessage(HWindow, WM_SYSCOMMAND, $F100, 0);
end;

{ Exit the program }
procedure TChartWindow.Exit(var Msg: TMessage);
begin
  if CanClose then postQuitMessage(0);
end;

{ Draw the chart if it exists }
procedure TChartWindow.Paint(DC: HDC; var PaintInfo: TPaintStruct);
var s : array[0..16] of Char;
begin
  if Chart <> nil then
    Chart^.draw(DC)
  else
  begin
    strPCopy(s, 'Error: No chart');
    TextOut(DC, 10, 10, s, strLen(s));
  end;
end;

{ Ensure that cursor is visible even when no mouse }
procedure TChartWindow.wmSetFocus(var Msg: TMessage);
begin
  ShowCursor(True);
end;

{ Return cursor to previous state for other windows }
procedure TChartWindow.wmKillFocus(var Msg: TMessage);
begin
  ShowCursor(False);
end;

{ Select and item in the chart and edit it }
procedure TChartWindow.wmLButtonDown(var Msg: TMessage);
var Item : PAssoc;
    S : String;
begin
{ First locate the item clicked on }
  Item := Chart^.getItem(Msg.LParamLo, Msg.LParamHi);
  if Item <> nil then
  begin
    { Update the edit buffer and edit }
    strLCopy(ItemBuffer.LabelStr, Item^.key, fieldLen-1);
    str(Item^.value,S);
    strPCopy(ItemBuffer.ValueStr, S);
    Change(Msg);
  end
  else
    MessageBeep(0);
end;

{ Simulate mouse movement with cursor keys }
procedure TChartWindow.wmKeyDown(var Msg: TMessage);
var x, y : Integer;
    pos : TPoint;
    key : word;
begin
  { Determine position of cursor in Window }
  getCursorPos(pos);
  screenToClient(HWindow, pos);
  x:=pos.x;
  y:=pos.y;
  { move the cursor position }
  key := Msg.WParam;
  case key of
    VK_UP    : y := y - 10;
    VK_DOWN  : y := y + 10;
    VK_RIGHT : x := x + 10;
    VK_LEFT  : x := x - 10;
    VK_HOME  :
      begin
    x := 10;
    y := 10;
      end;
    VK_END :
      begin
    x := attr.w - 10;
    y := attr.h - 10;
      end;
    VK_RETURN,
    VK_SPACE,
    VK_F2:
      begin
        { Simulate mouse pressing at cursor position }
        Msg.LParam := LongInt(pos);
    wmLButtonDown(Msg);
      end;
    end;
    { Update position of cursor in window with clipping }
    if x < 1 then x := 10;
    if y < 1 then y := 10;
    if x >= attr.w then x:= attr.w - 10;
    if y >= attr.h then y:= attr.h - 10;
    pos.x := x;
    pos.y := y;
    clientToScreen(HWindow, pos);
    setCursorPos(pos.x, pos.y);
end;

{ update internal information when resizing then redraw }
procedure TChartWindow.wmSize(var Msg: TMessage);
begin
  attr.h := Msg.lParamHi;
  attr.w := Msg.lParamLo;
  redraw
end;


{--------------------------------------------------}
{ Main program:                                    }
{--------------------------------------------------}

var
  ChartApp: TChartApplication;

begin
  ChartApp.Init('PChart');
  ChartApp.Run;
  ChartApp.Done;
end.