Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

PBCC: Print Screen

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • PBCC: Print Screen

    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.

    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
    [This message has been edited by Semen Matusovski (edited November 09, 2000).]
Working...
X