Tweet
PrintConsoleWindow(x) is a subroutine to print in "text" (x = %True) and "graphic" (x = %False) mode.
Console should be in "window".
Remarks:
1) Use latest (dec, 1999) winapi.inc, which you can find on http://www.powerbasic.com/files/pub/pbwin/
2) Tested under Win2000 only, but should work everywhere.
If you'll find any problem, pls, let me know.
[This message has been edited by Semen Matusovski (edited November 09, 2000).]
Console should be in "window".
Remarks:
1) Use latest (dec, 1999) winapi.inc, which you can find on http://www.powerbasic.com/files/pub/pbwin/
2) Tested under Win2000 only, but should work everywhere.
If you'll find any problem, pls, let me know.
Code:
#Compile Exe
#Register None
#Dim All
#Include "Win32Api.Inc"
#Include "ComDlg32.Inc"
$FileBmp = "F:\WinNt\WinNt.bmp" ' <------------ Change
Global hWndConsole As Long, hConsoleDC As Long, rcfConsole As RECT
Sub GetConsoleDCRC
Dim pt As POINTAPI
hConsoleDC = GetWindowDC(hWndConsole)
GetWindowRect hWndConsole, rcfConsole
ClientToScreen hWndConsole, pt
pt.x = pt.x - rcfConsole.nLeft
pt.y = pt.y - rcfConsole.nTop
GetClientRect hWndConsole, rcfConsole
rcfConsole.nLeft = rcfConsole.nLeft + pt.x
rcfConsole.nRight = rcfConsole.nRight + pt.x
rcfConsole.nTop = rcfConsole.nTop + pt.y
rcfConsole.nBottom = rcfConsole.nBottom + pt.y
End Sub
Function PrintConsoleWindow (TextMode As Long) As Long
Dim hMemDC As Long, hMemBmp As Long, hMemBmpOld As Long, _
bmi As BITMAPINFO, bm As BITMAP, rctConsole As RECT, _
lf As Logfont, hFont As Long, hFontOld As Long, tm As TEXTMETRIC, _
i As Long, hFile As Long, _
PrinterName As Asciiz * %MAX_PATH, _
pd As PRINTER_DEFAULTS, hPrinter As Long, _
hGlobal As Long, hGlobal2 As Long, dwNeeded As Long, pi2 As PRINTER_INFO_2 Ptr, _
hPrDC As Long, hBmpDC As Long, di As DOCINFO, dn As Asciiz * 64
GetConsoleDCRC
Do
If TextMode Then
hFile = CreateFile("CONOUT$", %GENERIC_READ Or %GENERIC_WRITE, _
%FILE_SHARE_READ Or %FILE_SHARE_WRITE, ByVal 0&, %OPEN_ALWAYS, _
%FILE_ATTRIBUTE_NORMAL, ByVal 0&)
If hFile = %INVALID_HANDLE_VALUE Then Exit Do
ReDim lpCharacter (0 To ScreenX - 1, 0 To ScreenY - 1) As Byte
ReadConsoleOutputCharacter hFile, ByVal VarPtr(lpCharacter (0, 0)), ScreenX * ScreenY, ByVal MakDwd(0, 0), i
CloseHandle hFile
i = GetStockObject(%OEM_FIXED_FONT)
GetObject i, SizeOf(lf), ByVal VarPtr(lf)
lf.lfWeight = %FW_BOLD
lf.lfCharset = %RUSSIAN_CHARSET
hFont = CreateFontIndirect(lf)
End If
hMemDC = CreateCompatibleDC (hConsoleDC)
If TextMode Then
hFontOld = SelectObject(hMemDC, hFont)
GetTextMetrics hMemDC, tm
rctConsole.nRight = tm.tmAveCharWidth * ScreenX
rctConsole.nBottom = tm.tmHeight * ScreenY
Else
rctConsole = rcfConsole
End If
'--- DIB-section for console screen ----
bmi.bmiHeader.biSize = SizeOf(bmi.bmiHeader)
bmi.bmiHeader.biWidth = (rctConsole.nRight - rctConsole.nLeft)
bmi.bmiHeader.biHeight = (rctConsole.nBottom - rctConsole.nTop)
bmi.bmiHeader.biPlanes = 1
bmi.bmiHeader.biBitCount = 24
bmi.bmiHeader.biCompression = %BI_RGB
hMemBmp = CreateDIBSection(hMemDC, bmi, %DIB_RGB_COLORS, 0, 0, 0)
GlobalLock hMemBmp
hMemBmpOld = SelectObject (hMemDC, hMemBmp)
GetObject hMemBmp, SizeOf(bm), bm
If TextMode Then
For i = 0 To ScreenY - 1
TextOut hMemDc, 0, i * tm.tmHeight, ByVal VarPtr(lpCharacter(0, i)), ScreenX
Next
SelectObject hMemDC, hFontOld: DeleteObject hFont
Else
BitBlt hMemDC, 0, 0, bm.bmWidth, bm.bmHeight, hConsoleDC, rctConsole.nLeft, rctConsole.nTop, %SRCCOPY
End If
SelectObject hMemDC, hMemBmpOld
DeleteDC hMemDC
'--- Default printer ---
GetProfileString "WINDOWS", "DEVICE", ",,,", PrinterName, SizeOf(PrinterName)
PrinterName = Left$(PrinterName, Instr(PrinterName$, ",") - 1)
If PrinterName = "" Then Exit Do
'----------------- Test/set page orientation --------
pd.DesiredAccess = %PRINTER_ALL_ACCESS
If IsFalse(OpenPrinter(PrinterName, hPrinter, pd)) Then Exit Do
If IsFalse(hPrinter) Then Exit Do
GetPrinter hPrinter, 2, 0, 0, dwNeeded: If IsFalse(dwNeeded) Then Exit Do
hGlobal = GlobalAlloc(%GHND, dwNeeded): If IsFalse(hGlobal) Then Exit Do
pi2 = GlobalLock(hGlobal): If IsFalse(pi2) Then Exit Do
If IsFalse(GetPrinter(hPrinter, 2, ByVal pi2, ByVal dwNeeded, dwNeeded)) Then Exit Do
If @pi2.pDevMode = 0 Then
dwNeeded = DocumentProperties(hWndConsole, hPrinter, PrinterName, ByVal 0&, ByVal 0&, 0)
If dwNeeded <= 0 Then Exit Do
hGlobal2 = GlobalAlloc(%GHND, dwNeeded)
If IsFalse(hGlobal2) Then Exit Do
@pi2.pDevMode = GlobalLock(hGlobal2)
If IsFalse(@pi2.pDevMode) Then Exit Do
If (DocumentProperties(hWndConsole, hPrinter, PrinterName, _
ByVal @pi2.pDevMode, ByVal 0&, %DM_OUT_BUFFER)) <> %IDOK Then Exit Do
End If
Dim OrientationOld As Long, OrientationNew As Long
Dim szConsole_X As Double, szConsole_Y As Double
szConsole_X = (rctConsole.nRight - rctConsole.nLeft) / _
GetDeviceCaps(hConsoleDC, %LOGPIXELSX) ' sm
szConsole_Y = (rctConsole.nBottom - rctConsole.nTop) / _
GetDeviceCaps(hConsoleDC, %LOGPIXELSY)
If szConsole_X > szConsole_Y Then OrientationNew = %DMORIENT_LANDSCAPE Else _
OrientationNew = %DMORIENT_PORTRAIT
OrientationOld = @[email protected]
If @[email protected] <> OrientationNew Then
@[email protected] = %DM_ORIENTATION
@[email protected] = OrientationNew
If DocumentProperties(hwndConsole, hPrinter, PrinterName, _
ByVal @pi2.pDevMode, ByVal @pi2.pDevMode, _
%DM_IN_BUFFER Or %DM_OUT_BUFFER) <> %IDOK Then Exit Do
If IsFalse(SetPrinter(hPrinter, 2, ByVal pi2, 0)) Then Exit Do
' SendMessage %HWND_BROADCAST, %WM_DEVMODECHANGE, 0&, VarPtr(PrinterName)
End If
'----------------- Printing ------------
hPrDC = CreateDC(ByVal %Null, PrinterName$, ByVal %Null, ByVal %Null)
If hPrDC Then
Dim PrLogPixelsX As Long, PrLogPixelsY As Long, PrPageX As Long, PrPageY As Long
PrLogPixelsX = GetDeviceCaps(hPrDC, %LOGPIXELSX)
PrLogPixelsY = GetDeviceCaps(hPrDC, %LOGPIXELSY)
PrPageX = GetDeviceCaps(hPrDC, %HORZRES)
PrPageY = GetDeviceCaps(hPrDC, %VERTRES)
Dim szPrinter_X As Double, szPrinter_Y As Double
szPrinter_X = PrPageX / PrLogPixelsX ' sm (max)
szPrinter_Y = PrPageY / PrLogPixelsY
Dim kScale As Double ' 10% for borders
kScale = 0.9 * Min(szPrinter_X / szConsole_X, szPrinter_Y / szConsole_Y)
szPrinter_X = kScale * szConsole_X ' sm
szPrinter_Y = kScale * szConsole_Y
Dim x As Long, y As Long ' pixels
x = PrLogPixelsX * szPrinter_X
y = PrLogPixelsY * szPrinter_Y
dn = "Ltr"
di.cbSize = SizeOf(di)
di.lpszDocName = VarPtr(dn)
hBmpDC = CreateCompatibleDC(hPrDC)
SelectObject hBmpDC, hMemBmp
If StartDoc(hPrDC, di) > 0 Then
If StartPage(hPrDC) > 0 Then
StretchBlt hPrDC, (PrPageX - x) / 2, (PrPageY - y) / 2, _
x, y, hBmpDC, 0, 0, _
rctConsole.nRight - rctConsole.nLeft, _
rctConsole.nBottom - rctConsole.nTop, %SRCCOPY
EndPage hPrDC
End If
EndDoc hPrDC
End If
DeleteDC hPrDC
DeleteDC hBmpDC
End If
'----------- Restore old settings -------------
If @[email protected] <> OrientationOld Then
@[email protected] = %DM_ORIENTATION
@[email protected] = OrientationOld
If DocumentProperties(hwndConsole, hPrinter, PrinterName, _
ByVal @pi2.pDevMode, ByVal @pi2.pDevMode, _
%DM_IN_BUFFER Or %DM_OUT_BUFFER) <> %IDOK Then Exit Do
If IsFalse(SetPrinter(hPrinter, 2, ByVal pi2, 0)) Then Exit Do
' SendMessage %HWND_BROADCAST, %WM_DEVMODECHANGE, 0&, VarPtr(PrinterName)
End If
Exit Do
Loop
If pi2 Then GlobalUnlock hGlobal: If hGlobal2 Then _
If @pi2.pDevMode Then GlobalUnlock hGlobal2
If hGlobal Then GlobalFree hGlobal
If hGlobal2 Then GlobalFree hGlobal2
If hPrinter Then ClosePrinter hPrinter
DeleteObject hMemBmp
ReleaseDc hWndConsole, hConsoleDC
End Function
Function PbMain
hWndConsole = GetForegroundWindow ' <-------------- For test only
GetConsoleDCRC
Local hBmp As Long, hBmpDC As Long
hBmp = LoadImage(ByVal %NULL, $FileBmp, %IMAGE_BITMAP, _
rcfConsole.nRight - rcfConsole.nLeft, rcfConsole.nBottom - rcfConsole.nTop, %LR_LOADFROMFILE)
hBmpDC = CreateCompatibleDC(hConsoleDC)
SelectObject hBmpDC, hBmp
BitBlt hConsoleDC, rcfConsole.nLeft, rcfConsole.nTop, _
rcfConsole.nRight - rcfConsole.nLeft, rcfConsole.nBottom - rcfConsole.nTop, _
hBmpDC, 0, 0, %SRCCOPY
DeleteDC hBmpDC
ReleaseDc hWndConsole, hConsoleDC
Local i As Long
Color 0, 15: Cursor Off
For i = 1 To ScreenY
Locate i, 1: Print "|";
Locate i, 11: Print " Line " + Format$(i, "00") + " ";
Locate i, ScreenX: Print "|";
Next
PrintConsoleWindow %True
PrintConsoleWindow %False
Sleep 2000
End Function