ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/MAGAZINE/MISC/PCTV2N4.ZIP/PRSETUP.PAS

Pascal/Delphi Source File | 1991-08-13 | 6.0 KB | 225 lines

{ prsetup.pas -- Demonstrate printer setup dialogs }

program prSetup;

{$R prsetup.res}

uses WinTypes, WinProcs, WObjects, Strings;

const
  id_Menu        = 100;  { Menu resource ID }
  cm_FileSetup   = 101;  { File:Printer setup command ID }
  cm_FileExit    = 102;  { File:Exit command ID }
  id_Setup       = 100;  { Setup dialog resource ID }
  id_ListBox     = 101;  { Setup's listbox control ID }
  id_SetupButton = 102;  { Setup's setup button control ID }

type
  TAppObject = object(TApplication)
    procedure InitMainWindow; virtual;
  end;

  PTMainWindow = ^TMainWindow;
  TMainWindow = object(TWindow)
    DefaultDevice: array[0 .. 40] of Char;  { Default printer }
    constructor Init(AParent: PWindowsObject; ATitle: PChar);
    procedure CMFileSetup(var Msg: TMessage);
      virtual cm_First + cm_FileSetup;
    procedure CMFileExit(var Msg: TMessage);
      virtual cm_First + cm_FileExit;
  end;

  PTSetupDialog = ^TSetupDialog;
  TSetupDialog = object(TDialog)
    Selection: PChar;             { Selected device }
    constructor Init(AParent: PWindowsObject;
      AName: PChar; OwnerSelection: PChar);
    procedure SetupWindow; virtual;
    procedure Ok(var Msg: TMessage);
      virtual id_First + id_Ok;
    procedure Setup(var Msg: TMessage);
      virtual id_First + id_SetupButton;
  end;

  TExtDeviceMode = function(HWindow: HWnd; HDriver: THandle;
      DevModeOutput: PDevMode; DeviceName, OutputName: PChar;
      DevModeInput: PDevMode; Profile: PChar;
      Mode: Word): Integer;

var
  ExtDeviceMode: TExtDeviceMode;
  DeviceMode: TDeviceMode;


{- Return pointer to next token in P or previous P if P = nil }
function NextToken(P: PChar; C: Char): PChar;
const
  Next: PChar = nil;
begin
  if P = nil then P := Next;
  Next := StrScan(P, C);
  if Next <> nil then
  begin
    Next^ := #0;
    Next := @Next[1]
  end;
  NextToken := P
end;


{ TAppObject }

{- Initialize the application }
procedure TAppObject.InitMainWindow;
begin
  MainWindow := New(PTMainWindow,
    Init(nil, 'Printer Setup Demonstration'))
end;


{ TMainWindow }

{- Construct main window object }
constructor TMainWindow.Init(AParent: PWindowsObject;
  ATitle: PChar);
var
  P: PChar;
  Buffer: array[0 .. 1024] of Char;
begin
  TWindow.Init(AParent, ATitle);
  Attr.Menu := LoadMenu(HInstance, PChar(id_Menu));
  GetProfileString('windows', 'device', ',,', Buffer,
    Sizeof(Buffer));
  P := NextToken(Buffer, ',');
  if P <> nil then
    StrLCopy(DefaultDevice, P, 40)
  else
    DefaultDevice[0] := #0;
end;

{- Execute File:Printer setup command }
procedure TMainWindow.CMFileSetup(var Msg: TMessage);
begin
  Application^.ExecDialog(New(PTSetupDialog,
    Init(@Self, PChar(id_Setup), DefaultDevice)))
end;

{- Execute File:Exit command }
procedure TMainWindow.CMFileExit(var Msg: TMessage);
begin
  CloseWindow
end;


{ TSetupDialog }

{- Construct TSetupDialog object }
constructor TSetupDialog.Init(AParent: PWindowsObject;
  AName: PChar; OwnerSelection: PChar);
begin
  TDialog.Init(AParent, AName);
  Selection := OwnerSelection;
end;

{- Insert DeviceNames strings into dialog list box }
procedure TSetupDialog.SetupWindow;
var
  I: Integer;
  P: PChar;
  Buffer: array[0 .. 4096] of Char;
begin
  GetProfileString('devices', nil, #0'', Buffer,Sizeof(Buffer));
  I := 0;
  P := NextToken(Buffer, #0);
  while StrLen(P) <> 0 do
  begin
    SendDlgItemMsg(id_ListBox, lb_AddString, 0, LongInt(P));
    if StrComp(Selection, P) = 0 then
      SendDlgItemMsg(id_ListBox, lb_SetCurSel, I, 0);
    P := NextToken(nil, #0);
    Inc(I)
  end;
end;

{- Respond to Ok button selection }
procedure TSetupDialog.Ok(var Msg: TMessage);
var
  Item: Word;   { Selected listbox-item index }
  Len: Integer; { Length of selected item }
  Buffer: array[0 .. 80] of Char;
begin
  Item := SendDlgItemMsg(id_Listbox, lb_GetCurSel, 0, 0);
  if Item <> lb_Err then
    SendDlgItemMsg(id_Listbox, lb_GetText, Item,
      LongInt(Selection));
  TDialog.Ok(Msg)
end;

{- Respond to Setup button selection }
procedure TSetupDialog.Setup(var Msg: TMessage);
var
  Item: Word;
  DriverName, OutputName: PChar;
  Buffer: array[0 .. 80] of Char;
  DeviceName: array[0 .. 40] of Char;
  HDriver: THandle;
  Size: Integer; { Size of DevMode structure }
  DriverExtName: array[0 .. 12] of Char;
  DevModeOutput: PDevMode;
  P: TFarProc;
begin
  Item := SendDlgItemMsg(id_Listbox, lb_GetCurSel, 0, 0);
  if Item <> lb_Err then
  begin
    SendDlgItemMsg(id_Listbox, lb_GetText, Item,
      LongInt(@DeviceName));
    GetProfileString('devices', DeviceName, ',,', Buffer,
      Sizeof(Buffer));
    DriverName := NextToken(Buffer, ',');
    OutputName := NextToken(nil, ',');
    if (StrLen(DriverName) = 0) or (StrLen(OutputName) = 0) then
    begin
      MessageBox(HWindow, 'Bad device format', 'Error', mb_Ok);
      Exit
    end;
    StrLCat(StrCopy(DriverExtName, DriverName), '.DRV', 12);
    HDriver := LoadLibrary(DriverExtName);
    if HDriver < 32 then
      MessageBox(HWindow, 'Failed to load driver', 'Error',
        mb_IconExclamation or mb_Ok)
    else begin
      P := GetProcAddress(HDriver, 'ExtDeviceMode');
      if P <> nil then
      begin
        ExtDeviceMode := TExtDeviceMode(P);
        Size := ExtDeviceMode(HWindow, HDriver, nil, DeviceName,
          OutputName, nil, nil, 0);
        GetMem(DevModeOutput, Size);
        ExtDeviceMode(HWindow, HDriver, DevModeOutput,
          DeviceName, OutputName, nil, nil,
          dm_Prompt or dm_Copy);
        FreeMem(DevModeOutput, Size)
      end else
      begin
        P := GetProcAddress(HDriver, 'DeviceMode');
        if P <> nil then
        begin
          DeviceMode := TDeviceMode(P);
          DeviceMode(HWindow, HDriver, DeviceName, OutputName)
        end
      end;
      FreeLibrary(HDriver);
    end;
  end;
end;

var

  App: TAppObject;

begin
  App.Init('PrSetup');
  App.Run;
  App.Done
end.