Option Explicit
Private Type DOCINFO
cbSize As Long
lpszName As String
lpszOutput As Long
End Type
Private Declare Function FindWindow Lib "user32.dll" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" _
Alias "FindWindowExA" _
(ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hDc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hDc As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hDc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" _
(ByVal hDestDC As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hSrcDC As Long, _
ByVal xSrc As Long, _
ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
Private Declare Function CreateDC Lib "gdi32" _
Alias "CreateDCA" _
(ByVal lpDriverName As String, _
ByVal lpDeviceName As String, _
ByVal lpOutput As String, _
ByVal lpInitData As Any) As Long
Private Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hDc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hDc As Long, ByVal nIndex As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function StartDoc Lib "gdi32" _
Alias "StartDocA" (ByVal hcs As Long, lpDI As DOCINFO) As Long
Private Declare Function EndDoc Lib "gdi32" (ByVal hcs As Long) As Long
Private Declare Function GetDefaultPrinter Lib "winspool.drv" _
Alias "GetDefaultPrinterA" _
(ByVal sPrinterName As String, _
lPrinterNameBufferSize As Long) As Long
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const PointsPerInch = 72
Private Const SRCCOPY As Long = &HCC0020
'---------------'
'Public routine.'
'---------------'
Public Sub PrintVisibleRange()
Const ZOOM_FACTOR = 3 '<--- Change this value as needed.
Dim MyDoc As DOCINFO
Dim hwnd As Long
Dim lBmp As Long
Dim lMemoryDC As Long
Dim lwbDC As Long
Dim lDC As Long
Dim wd As Single
Dim hg As Single
Dim bHeadings As Boolean
'Store the workbook hwnd.
hwnd = FindWindow("XLMAIN", Application.Caption)
hwnd = FindWindowEx(Application.hwnd, 0&, "XLDESK", vbNullString)
hwnd = FindWindowEx(hwnd, 0&, "EXCEL7", vbNullString)
'Store the Visible Range height & width.
wd = Application.ActiveWindow.VisibleRange.Width
hg = Application.ActiveWindow.VisibleRange.Height
'store the row & column headers visible state.
bHeadings = Application.ActiveWindow.DisplayHeadings
'hide the row & column headers.
If bHeadings Then Application.ActiveWindow.DisplayHeadings = False
'Store the workbook window dc.
lwbDC = GetDC(hwnd)
'create a memory dc.
lMemoryDC = CreateCompatibleDC(lwbDC)
'create a compatible bmp.
lBmp = CreateCompatibleBitmap _
(lwbDC, PTtoPX(wd, False), PTtoPX(hg, True))
'select the bmp to the memory dc.
DeleteObject SelectObject(lMemoryDC, lBmp)
'copy the visible range onto the memory dc.
BitBlt lMemoryDC, 0, 0, PTtoPX(wd, False), PTtoPX(hg, True), _
lwbDC, 0, 0, SRCCOPY
'restore the row & column headers.
Application.ActiveWindow.DisplayHeadings = bHeadings
'retrieve the default printer dc.
lDC = GetPrinterDC
If lDC <> 0 Then
'Initialize the DOCINFO srtucture.
MyDoc.lpszName = "VisibleRange_PrintOut"
MyDoc.lpszOutput = 0
MyDoc.cbSize = Len(MyDoc)
'Start a new print job.
Call StartDoc(lDC, MyDoc)
'Print the visible range.( May need to adjust the zoom factor ! )
BitBlt lDC, PTtoPX(0, False), PTtoPX(0, True), _
PTtoPX(wd, False) * ZOOM_FACTOR, PTtoPX(hg, True) * ZOOM_FACTOR, _
lMemoryDC, 0, 0, SRCCOPY
'End the printing.
Call EndDoc(lDC)
'CleanUp.
Call DeleteDC(lDC)
Call ReleaseDC(0, lwbDC)
Call ReleaseDC(lMemoryDC, 0)
End If
End Sub
'------------------'
'Private routines .'
'------------------'
Private Function GetPrinterDC() As Long
Dim sBuffer As String
Dim sPrinterName As String
Dim hPrinter As Long
sBuffer = Space(128)
If GetDefaultPrinter(sBuffer, 128) Then
sPrinterName = Left(sBuffer, 128 - 1)
GetPrinterDC = CreateDC("WINSPOOL", sPrinterName, vbNullString, 0&)
End If
End Function
Private Function ScreenDPI(bVert As Boolean) As Long
Static lDPI(1), lDC
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
PTtoPX = Points * ScreenDPI(bVert) / PointsPerInch
End Function
ffice
