Code:
'---------------------------------------------------------------------------- ' ' printscr.bas for PB/DLL 5.0 ' ' Print screen (or invert screen) to printer (or/and) clipboard. ' '---------------------------------------------------------------------------- ' 'Based on a "printbmp.bas" by Don Dickinson, May, 1999 on the PowerBasic BBS 'Based on a "fonts.bas" by Don Dickinson January 22, 1998 on the PowerBasic BBS ' 'Based on a "Capture Desktop image and Print to Printer" by Dave Navarro October 18, 1999 on the PowerBasic BBS ' ' 'Program by Jozsef Hegyi ' 'Use at your own risk. ' '---------------------------------------------------------------------------- ' usage : ' ' Start : printscr.exe [/i] [/c] [/-p] ' ' Options: ' /i invert screen ' /c copy screen to clipboard ' /-p not print to printer ' ' Left button press on the tray icon --->> print screen ' '---------------------------------------------------------------------------- ' $DIM ALL $COMPILE EXE $OPTION VERSION4 $INCLUDE "WIN32API.INC" $INCLUDE "COMDLG32.INC" $INCLUDE "printscr.inc" $RESOURCE "printscr.pbr" '---------------------------------------------------------------------------- FUNCTION WinMain (BYVAL hInstance AS LONG, _ BYVAL hPrevInstance AS LONG, _ lpszCmdLine AS ASCIIZ PTR, _ BYVAL iCmdShow AS LONG) AS LONG LOCAL Msg AS tagMsg GLOBAL zCommand AS ASCIIZ * 255 GLOBAL hBitmap as LONG zCommand = @lpszCmdLine IF ISFALSE(InitApplication(hInstance)) THEN FUNCTION = 0 EXIT FUNCTION END IF IF ISFALSE(InitInstance(hInstance,iCmdShow)) THEN FUNCTION = 0 EXIT FUNCTION END IF WHILE GetMessage(Msg, %NULL, 0, 0) TranslateMessage Msg DispatchMessage Msg WEND FUNCTION = msg.wParam END FUNCTION ' WinMain '---------------------------------------------------------------------------- FUNCTION InitApplication( BYVAL hInstance AS LONG) AS LONG LOCAL wndclass AS WndClassEx LOCAL szClassName AS ASCIIZ * 80 szClassName = "PrintScreen" wndclass.cbSize = SIZEOF(WndClass) wndclass.style = %CS_HREDRAW OR %CS_VREDRAW OR %CS_DBLCLKS OR %CS_BYTEALIGNCLIENT wndclass.lpfnWndProc = CODEPTR( WndProc ) wndclass.cbClsExtra = 0 wndclass.cbWndExtra = 0 wndclass.hInstance = hInstance wndclass.hIcon = %NULL wndclass.hCursor = %NULL wndclass.hbrBackground = %NULL wndclass.lpszMenuName = %NULL wndclass.lpszClassName = VARPTR( szClassName ) wndclass.hIconSm = %NULL FUNCTION = RegisterClassEx ( wndclass ) END FUNCTION '---------------------------------------------------------------------------- FUNCTION InitInstance( BYVAL hInstance AS LONG, BYVAL iCmdShow AS LONG) AS LONG LOCAL szClassName AS ASCIIZ * 80 szClassName = "PrintScreen" hInst = hInstance hWndMain = CreateWindow(szClassName, _ ' window class name "Print Screen", _ ' window caption %WS_POPUP, _ ' window style 0, _ ' initial x position 0, _ ' initial y position 0, _ ' initial x size 0, _ ' initial y size %HWND_DESKTOP, _ ' parent window handle BYVAL %NULL, _ ' window menu handle hInstance, _ ' program instance handle BYVAL %NULL) ' creation parameters FUNCTION = %TRUE END FUNCTION '---------------------------------------------------------------------------- Function WndProc( BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, BYVAL wParam AS LONG, BYVAL lParam AS LONG ) EXPORT As Long static ti as NOTIFYICONDATA static p as POINTAPI static hActiveWindow as long static lNyomtatas as long local DlgRect as Rect '---- local hDC as long local iAngle as Integer local fontName as String local fontStyle as Integer local fontSize as Double '---- Select Case wMsg CASE %WM_CREATE ' ** Get Menu Handle hMenu = GetSubMenu(LoadMenu(hInst, "POPUPMENU"), 0) ' ** Add tray icon ti.cbSize = SIZEOF(ti) ti.hWnd = hWnd ti.uID = hInst ti.uFlags = %NIF_ICON OR %NIF_MESSAGE OR %NIF_TIP ti.uCallbackMessage = %WM_TRAYICON ' ti.hIcon = LoadIcon(hInst, "APPLICATION_ICON") ti.hIcon = LoadIcon(%NULL, BYVAL MAKEINTRESOURCE(%IDI_EXCLAMATION)) ti.szTip = "Print screen to printer (or/and) clipboard" Shell_NotifyIcon %NIM_ADD, ti DestroyIcon ti.hIcon '---------------------------- hDC = GetDC(hWnd) fontName = "Times New Roman" fontStyle = %FONT_BOLD OR %FONT_ITALIC fontSize = 14.0 iAngle = 0 hFont1 = CreateAngleFont_ROMAN( hDC, fontName, fontStyle, fontSize, iAngle) ReleaseDC hWnd, hDC '---------------------------- hdcPrint = GetPrinterDC() '---------------------------- FUNCTION = 1 CASE %WM_TRAYICON SELECT CASE LOWRD(lParam) ' ** Left button press CASE %WM_LBUTTONDOWN call Print_screen () ' ** Right button press CASE %WM_RBUTTONDOWN IF IsWindowVisible(hWnd) = %FALSE THEN SetForegroundWindow hWnd GetCursorPos p TrackPopupMenu hMenu, 0, p.x, p.y, 0, hWnd, ByVal %NULL Postmessage hWnd, %WM_NULL, 0, 0 END IF END SELECT CASE %WM_DESTROY ' ** Remove the tray icon if the application is closed deleteobject hFont1 DeleteDC hdcPrint DeleteObject hBitmap Shell_NotifyIcon %NIM_DELETE, ti PostQuitMessage 0 FUNCTION = 0 CASE %WM_COMMAND SELECT CASE LOWRD(wParam) CASE %IDM_PRINTER CALL Print_Setup () FUNCTION = 1 CASE %IDM_EXIT ' ** Make sure they want to exit IF MessageBox(hWnd,"Are you sure you want to quit ?" , "Print screen", %MB_ICONEXCLAMATION OR %MB_OKCANCEL) = %IDOK THEN DestroyWindow hWnd FUNCTION = 1 END IF CASE %IDOK ' ** Display the about box DialogBox hInst, "ABOUTDIALOG", %HWND_DESKTOP, CODEPTR(AboutProc) CASE %IDCANCEL ShowWindow hWnd, %SW_HIDE FUNCTION = 1 EXIT FUNCTION END SELECT CASE %WM_SYSCOMMAND ' ** If either the minimize or close buttons are pressed, hide the ' window so it doesn't appear in the task bar. SELECT CASE LOWRD(wParam) CASE %SC_MINIMIZE ShowWindow hWnd, %SW_HIDE FUNCTION = 1 EXIT FUNCTION CASE %SC_CLOSE ShowWindow hWnd, %SW_HIDE FUNCTION = 1 EXIT FUNCTION END SELECT END SELECT FUNCTION = DefWindowProc( hWnd, wMsg, wParam, lParam ) End Function ' '---------------------------------------------------------------------------- ' FUNCTION AboutProc(BYVAL hDlg AS LONG, BYVAL wMsg AS LONG, BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG SELECT CASE wMsg CASE %WM_INITDIALOG FUNCTION = 1 CASE %WM_COMMAND IF LOWRD(wParam) = %IDOK THEN EndDialog hDlg, 0 FUNCTION = 1 END IF END SELECT END FUNCTION '---------------------------------------------------------------------------- ' **** IMPORTANT **** ' You need to go into your win32api.inc file and change the declaration ' for the BITMAPINFO structure s bmi Colors member to 256. If you don t ' you ll gpf on all bitmaps that aren t monochrome. ' ' TYPE BITMAPINFO ' bmiHeader AS BITMAPINFOHEADER ' bmiColors(256) AS RGBQUAD ' END TYPE '---------------------------------------------------------------------------- ' FUNCTION BltImage(zFile AS ASCIIZ, BYVAL iPrinting AS LONG, _ BYVAL x AS DOUBLE, BYVAL y AS DOUBLE, BYVAL wid AS DOUBLE, _ BYVAL hgt AS DOUBLE, BYVAL dcOut AS LONG) EXPORT AS LONG DIM ppiX AS LONG DIM ppiY AS LONG DIM x1 AS LONG DIM y1 AS LONG DIM w1 AS LONG DIM h1 AS LONG DIM hDesktop AS LONG DIM dcWindow AS LONG DIM dcBitmap AS LONG DIM hOldBM AS LONG DIM bmSize AS LONG DIM ptrMem AS LONG DIM gMemory AS STRING DIM rBitmap AS BITMAP DIM bmInfo AS BITMAPINFO '------ LOCAL hWnd_Src AS LONG LOCAL hDC_Src AS LONG LOCAL hBmp_Src AS LONG LOCAL hBmpDC_Src AS LONG LOCAL r_Src AS RECT '------ LOCAL hdc AS LONG LOCAL x_dcOut AS LONG LOCAL y_dcOut AS LONG STATIC nBITSPIXEL AS long STATIC hBmp_Clip AS LONG '---------------------------------------------- hdc = CreateIC ("DISPLAY", BYVAL %NULL, BYVAL %NULL, BYVAL %NULL) nBITSPIXEL = GetDeviceCaps(hdc, %BITSPIXEL) IF SIZEOF(bmInfo) < 40 + 256 * 4 THEN MsgBox "The BITMAPINFO structure doesn't have enough space in the " + _ "bmiColors array. Please define it with at least 256 array members." FUNCTION = %False ELSE ppiX = GetDeviceCaps(dcOut, %LOGPIXELSX) ppiY = GetDeviceCaps(dcOut, %LOGPIXELSY) x1 = ppiX * x y1 = ppiY * y hWnd_Src = GetDeskTopWindow() GetWindowRect hWnd_Src , r_Src x_dcOut = GetDeviceCaps(dcOut, %HORZRES) - x1 y_dcOut = CLNG((x_dcOut / r_Src.nRight) * r_Src.nBottom) w1 = x_dcOut if (GetDeviceCaps(dcOut, %VERTRES) - y1) < y_dcOut then h1 = GetDeviceCaps(dcOut, %VERTRES) - y1 else h1 = y_dcOut end if '- Copy screen to BMP hWnd_Src = GetDeskTopWindow() GetWindowRect hWnd_Src , r_Src hDC_Src = GetDC(%NULL) hBmpDC_Src = CreateCompatibleDC(hDC_Src) hBitmap = CreateCompatibleBitmap(hDC_Src, r_Src.nRight-r_Src.nLeft, r_Src.nBottom-r_Src.nTop) CALL GetObject (hBitmap, SIZEOF(rBitmap),rBitmap) hOldBM = SelectObject(hBmpDC_Src, hBitmap) if instr(ucase$(zCommand),"/I") > 0 then BitBlt hBmpDC_Src, 0, 0, r_Src.nRight-r_Src.nLeft, _ r_Src.nBottom-r_Src.nTop, hDC_Src, r_Src.nLeft, _ r_Src.nTop, %NOTSRCCOPY else BitBlt hBmpDC_Src, 0, 0, r_Src.nRight-r_Src.nLeft, _ r_Src.nBottom-r_Src.nTop, hDC_Src, r_Src.nLeft, _ r_Src.nTop, %SRCCOPY end if SelectObject hBmpDC_Src, hOldBM '------------------------------ if instr(ucase$(zCommand),"/C") > 0 then '- Copy BMP to clipboard OpenClipboard Byval 0 EmptyClipboard if hBmp_Clip > 0 then DeleteObject hBmp_Clip end if SetClipboardData %CF_BITMAP, hBitmap CloseClipboard hBmp_Clip = hBitmap end if '------------------------------ IF hBitmap = 0 THEN MsgBox "Bitmap not found error" FUNCTION = %FALSE ELSE IF iPrinting = %True THEN hDesktop = GetDesktopWindow() dcWindow = GetDC(hDesktop) dcBitmap = CreateCompatibleDC(dcWindow) ReleaseDC hDesktop, dcWindow GetObject hBitmap, sizeof(rBitmap), rBitmap bmInfo.bmiHeader.biSize = len(bmInfo.bmiHeader) bmInfo.bmiHeader.biWidth = rBitmap.bmWidth bmInfo.bmiHeader.biHeight = rBitmap.bmHeight bmInfo.bmiHeader.biPlanes = 1 bmInfo.bmiHeader.biBitCount = rBitmap.bmBitsPixel if ( nBITSPIXEL = 8 or nBITSPIXEL = 24 ) then bmInfo.bmiHeader.biCompression = %BI_RGB elseif ( nBITSPIXEL = 16 or nBITSPIXEL = 32 ) then bmInfo.bmiHeader.biCompression = %BI_BITFIELDS end if bmSize = bmInfo.bmiHeader.biWidth bmSize = (bmSize + 1) * (bmInfo.bmiHeader.biBitCount / 8) bmSize = ((bmSize + 3) / 4) * 4 bmSize = bmSize * bmInfo.bmiHeader.biHeight ON ERROR RESUME NEXT gMemory = STRING$(bmSize, CHR$(0)) ON ERROR GOTO 0 IF ERR THEN '- Couldn't get the memory msgbox "Couldn't get the memory" FUNCTION = %FALSE ELSE ptrMem = STRPTR(gMemory) GetDIBits dcBitmap, hBitmap, 0, bmInfo.bmiHeader.biHeight, _ BYVAL ptrMem, bmInfo, %DIB_RGB_COLORS StretchDIBits dcOut, x1, y1, w1, h1, 0, 0, bmInfo.bmiHeader.biWidth, _ bmInfo.bmiHeader.biHeight, BYVAL ptrMem, bmInfo, _ %DIB_RGB_COLORS, %SRCCOPY FUNCTION = %True END IF DeleteDC hDC_Src DeleteDC dcBitmap DeleteObject hOldBM gMemory = "" END IF END IF END IF END FUNCTION '---------------------------------------------------------------------------- FUNCTION Print_screen () AS LONG DIM i AS LONG DIM iCopies AS LONG DIM rDocInfo AS DOCINFO DIM zString AS ASCIIZ * 256 DIM zString1 AS ASCIIZ * 256 DIM iPrinting AS LONG iCopies = 1 iPrinting = %True '------------------------------ if instr(ucase$(zCommand),"/-P") > 0 then iPrinting = %False end if '------------------------------ IF hdcPrint THEN zString = "Print screen" rDocInfo.lpszDocName = VARPTR(zString) rDocInfo.lpszOutput = %NULL if iPrinting then StartDoc hdcPrint, rDocInfo end if FOR i = 1 TO iCopies if iPrinting then StartPage hdcPrint end if zString1 = "Print screen / " +date$+" "+time$ call BltImage (zCommand, %True, 0.5, 0.5, 9, 6.75, hdcPrint) if iPrinting then call SelectObject (hdcPrint, hFont1) TextOut hdcPrint, 150, 50, zString1, LEN(zString1) EndPage hdcPrint end if NEXT i if iPrinting then EndDoc hdcPrint end if FUNCTION = 1 END IF END FUNCTION '---------------------------------------------------------------------------- FUNCTION Print_Setup () AS LONG DIM iCopies AS LONG, iFrom AS LONG, iTo AS LONG DIM iMin AS LONG, iMax AS LONG, iOptions AS LONG '- Prompt the user for a printer iOptions = %PD_COLLATE + %PD_HIDEPRINTTOFILE + %PD_RETURNDC + _ %PD_NOSELECTION + %PD_PAGENUMS iFrom = 1: iTo = 1: iMin = 1: iMax = 1: iCopies = 1 PrinterDialog %NULL, iOptions, hdcPrint, iCopies, iFrom, iTo, iMin, iMax END FUNCTION '---------------------------------------------------------------------------- '---------------------------------------------------------------------------- ' ' printscr.inc ' '---------------------------------------------------------------------------- ' %WM_TRAYICON = %WM_USER + 400 %IDM_MENU_DIALOG = 100 %IDM_EXIT = 2048 %IDM_PRINTER = 2049 '---------------------------------------------------------------------------- ' Font Parameter Contants '---------------------------------------------------------------------------- %FONT_NORMAL = 0 %FONT_BOLD = 1 %FONT_ITALIC = 2 %FONT_UNDER = 4 %FONT_STRIKE = 8 '---------------------------------------------------------------------------- GLOBAL hInst AS LONG GLOBAL hWndMain AS LONG GLOBAL hMenu AS LONG GLOBAL nIkon AS LONG GLOBAL hFont1 AS LONG GLOBAL hdcPrint AS LONG '---------------------------------------------------------------------------- DECLARE FUNCTION GetPrinterDC () AS LONG DECLARE FUNCTION MakeIntResource (iRcID AS LONG) AS DWORD DECLARE Function CreateAngleFont_ROMAN ( dcOutput as LONG, fontName as String, fontStyle as Integer, _ fontSize as Double, degrees as Integer ) as LONG DECLARE FUNCTION Print_screen () AS LONG DECLARE FUNCTION Print_Setup () AS LONG DECLARE FUNCTION InitApplication( BYVAL hInstance AS LONG) AS LONG DECLARE FUNCTION InitInstance( BYVAL hInstance AS LONG, BYVAL iCmdShow AS LONG) AS LONG '---------------------------------------------------------------------------- FUNCTION GetPrinterDC () AS LONG LOCAL pInfo5() AS PRINTER_INFO_5,_ dwNeeded AS LONG,_ dwReturned AS LONG,_ iUpper AS LONG,_ pByte AS BYTE PTR,_ szNull AS ASCIIZ*0 pByte = VARPTR(szNull) CALL EnumPrinters (%PRINTER_ENUM_LOCAL, BYVAL %NULL, 5, @pByte, 0, _ dwNeeded, dwReturned) iUpper = dwNeeded\SIZEOF(pInfo5(0)) REDIM pInfo5(0: iUpper) pByte = VARPTR(pInfo5(0)) if EnumPrinters (%PRINTER_ENUM_DEFAULT, BYVAL %NULL, 5, @pByte, _ (iUpper+1)*SIZEOF(pInfo5(0)), dwNeeded, dwReturned) THEN FUNCTION = CreateDC (BYVAL %NULL, pInfo5(0)[email protected], _ BYVAL %NULL, BYVAL %NULL) ELSE FUNCTION = 0 END IF END FUNCTION '---------------------------------------------------------------------------- FUNCTION MakeIntResource (iRcID AS LONG) AS DWORD FUNCTION = MAKDWD(iRcID, 0) END FUNCTION '---------------------------------------------------------------------------- Function CreateAngleFont_ROMAN ( dcOutput as LONG, _ fontName as String, fontStyle as Integer, _ fontSize as Double, degrees as Integer ) as LONG ' Dim zFontName as ASCIIZ * 100 Dim iPPIY as Integer Dim iPPIX as Integer Dim rNewFont as LOGFONT iPPIX = GetDeviceCaps(dcOutput, %LOGPIXELSX) iPPIY = GetDeviceCaps(dcOutput, %LOGPIXELSY) zFontName = trim$(fontName$) ' rNewFont.lfHeight = -1 * (fontSize * iPPIY ) / 72 rNewFont.lfWidth = 0 rNewFont.lfEscapement = degrees * 10 rNewFont.lfOrientation = degrees * 10 if (fontStyle% and %FONT_BOLD) = %FONT_BOLD then rNewFont.lfWeight = %FW_BOLD elseif (fontStyle% and %FW_THIN) = %FW_THIN then rNewFont.lfWeight = %FW_THIN elseif (fontStyle% and %FW_LIGHT) = %FW_LIGHT then rNewFont.lfWeight = %FW_LIGHT else rNewFont.lfWeight = %FW_NORMAL end if if (fontStyle% and %FONT_ITALIC) = %FONT_ITALIC then rNewFont.lfItalic = 1 else rNewFont.lfItalic = 0 end if if (fontStyle% and %FONT_STRIKE) = %FONT_STRIKE then rNewFont.lfStrikeOut = 1 else rNewFont.lfStrikeOut = 0 end if if (fontStyle% and %FONT_UNDER) = %FONT_UNDER then rNewFont.lfUnderline = 1 else rNewFont.lfUnderline = 0 end if rNewFont.lfCharSet = %DEFAULT_CHARSET ' %OEM_CHARSET rNewFont.lfOutPrecision = %OUT_DEFAULT_PRECIS rNewFont.lfClipPrecision = %CLIP_DEFAULT_PRECIS rNewFont.lfQuality = %DEFAULT_QUALITY ' %PROOF_QUALITY rNewFont.lfPitchAndFamily = %DEFAULT_PITCH + %FF_SWISS ' %FF_DONTCARE rNewFont.lfFaceName = trim$(zFontName) + chr$(0) ' zFontName = "" FUNCTION = CreateFontIndirect(rNewFont) End Function '---------------------------------------------------------------------------- // printscr.rc //--------------------------------------------------------------------------- #include "resource.h" //--------------------------------------------------------------------------- #define IDM_MENU_DIALOG 100 #define GEPESZ 1000 #define IDM_EXIT 2048 #define IDM_PRINTER 2049 //--------------------------------------------------------------------------- LANGUAGE LANG_ENGLISH, SUBLANG_DEFAULT #pragma code_page(1252) //--------------------------------------------------------------------------- // Icon //APPLICATION_ICON ICON DISCARDABLE "FENYKEP3.ICO" //GEPESZ_ICON ICON DISCARDABLE "GEPESZ1.ICO" //--------------------------------------------------------------------------- // // Dialog // IDM_MENU_DIALOG DIALOGEX 10, 10, 10, 10 CAPTION "Printscr" BEGIN END ABOUTDIALOG DIALOGEX 13, 67, 150, 88 STYLE DS_MODALFRAME | DS_3DLOOK | DS_CENTER | WS_POPUP | WS_CAPTION CAPTION "Print screen to printer (or/and) clipboard" FONT 11, "Times New Roman", 0, 0, 0x1 BEGIN CTEXT " Print screen (or invert screen) to printer (or/and) clipboard Win95/98/NT4.0 (32 bit)\r\r 1999-2000 Jozsef Hegyi", -1,28,7,118,47 DEFPUSHBUTTON "O&K",IDOK,62,62,50,19,0,WS_EX_DLGMODALFRAME | WS_EX_CLIENTEDGE | WS_EX_STATICEDGE ICON "GEPESZ_ICON",GEPESZ,10,25,20,20 END //--------------------------------------------------------------------------- // // Menu // POPUPMENU MENU DISCARDABLE BEGIN POPUP "&Print screen to printer (or/and) clipboard" BEGIN MENUITEM "Printer setup", IDM_PRINTER MENUITEM SEPARATOR MENUITEM "Exit", IDM_EXIT MENUITEM SEPARATOR MENUITEM "About", IDOK END END //--------------------------------------------------------------------------- // Version VS_VERSION_INFO VERSIONINFO FILEVERSION 1,1,0,0 PRODUCTVERSION 1,1,0,0 FILEFLAGSMASK 0x0L FILEFLAGS 0x0L FILEOS 0x4L FILETYPE 0x1L FILESUBTYPE 0x0L BEGIN BLOCK "StringFileInfo" BEGIN BLOCK "040904b0" BEGIN VALUE "Comments", "Developer tool: PowerBASIC DLL Compiler 5.0 for WIN95/98/NT4.0 (32 bit). \0" VALUE "Comments", "Not print to printer: printscr.exe /-p \0" VALUE "Comments", "Invert : printscr.exe /i \0" VALUE "Comments", "Copy to clipboard: printscr.exe /c \0" VALUE "FileDescription", "Print screen / 1999-2000 Jozsef Hegyi \0" VALUE "FileVersion", "Version 1.03\0" VALUE "InternalName", "printscr\0" VALUE "OriginalFilename", "printscr.exe\0" VALUE "LegalCopyright", "Freeware \0" VALUE "ProductName", "Print screen (or invert screen) to printer (or/and) clipboard.\0" VALUE "ProductVersion", "Version 1.03\0" END END BLOCK "VarFileInfo" BEGIN VALUE "Translation", 0x0409,0x04b0 END END //---------------------------------------------------------------------------
[This message has been edited by Jozsef Hegyi (edited August 27, 2000).]
Leave a comment: