{************************************************}
{                                                }
{   Turbo Pascal for Windows                     }
{   Tips & Techniques Demo Program               }
{   Copyright (c) 1991 by Borland International  }
{                                                }
{************************************************}

unit HCopy;

interface

uses WinTypes;

procedure PrintBitMap(HWindow: HWnd; BitMap: HBitMap);

implementation

uses WinProcs, Strings;

procedure PrintBitMap(HWindow: HWnd; BitMap: HBitMap);
var
  DC, ScreenDC, MemDC: HDC;
  BM: TBitMap;
  OldBitMap: HBitMap;
  Driver, PrintDevice, Port: array[0..40] of Char;
  S: array[0..10] of Char;
  DCaps: Word;

procedure GetIniInfo(ADriver, ADevice, Port: PChar);
var
  PrinterString: array[0..80] of char;
  Device, Driver, OutPut: PChar;
begin
  GetProfileString('Windows', 'Device', ',,,', PrinterString, 80);
  Device := PrinterString;
  Driver := StrScan(Device, ',');
  Driver[0] := #0;
  Inc(Driver);
  OutPut := StrScan(Driver, ',');
  OutPut[0] := #0;
  Inc(OutPut);
  StrCopy(Port, OutPut);
  StrCopy(ADevice, Device);
  StrCopy(ADriver, Driver);
end;

begin
  GetIniInfo(Driver, PrintDevice, Port);
  DC := CreateDC(Driver, PrintDevice, Port, Nil);
  StrCopy(S,'HardCopy'#0);
  Escape(DC, STARTDOC, 8, @S, nil);
  ScreenDC := GetDC(HWindow);
  MemDC := CreateCompatibleDC(ScreenDC);
  OldBitMap := SelectObject(MemDC, BitMap);
  GetObject(BitMap, SizeOf(BM), @BM);
  BitBlt(DC, 0, 0, BM.bmWidth, BM.bmHeight, MemDC, 0, 0, SRCCOPY);
  Escape(DC, NEWFRAME, 0, nil, nil);
  Escape(DC, ENDDOC, 0, nil, nil);
  SelectObject(MemDC, OldBitMap);
  ReleaseDC(HWindow, ScreenDC);
  DeleteDC(MemDC);
  DeleteDC(DC);
end;
END.