Following code is a screen capturer, not relaying on the PrintScreen button. It can handle both the full screen (did not try with several monitors connected -only the principal-), or a portion of the screen selected by a range or a shape. This last point is really interesting, could not found nothing similar on the net, and kept me struggling for a whole day how to achieve it, but finally got it working.
The performance of the code is not that great compared to commercial software for this task, but at least, you have not to install anything.
Option Explicit
Private g_ShpID As Long
Private Const VK_SNAPSHOT = &H2C
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (ByRef PicDesc As PicBmp, ByRef RefIID As GUID, ByVal fPictureOwnsHandle As Long, ByRef IPic As IPicture) As Long
Private Declare Function CreateCompatibleDC Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "GDI32.dll" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "GDI32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "GDI32.dll" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "GDI32.dll" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, ByRef lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "GDI32.dll" (ByRef lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "GDI32.dll" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function BitBlt Lib "GDI32.dll" (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 DeleteDC Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRECT As RECT) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long ' pixels
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long
Private Type DEVMODE
DeviceName As String * 32
SpecVersion As Integer
DriverVersion As Integer
Size As Integer
DriverExtra As Integer
Fields As Long
Orientation As Integer
PaperSize As Integer
PaperLength As Integer
PaperWidth As Integer
Scale As Integer
Copies As Integer
DefaultSource As Integer
PrintQuality As Integer
Color As Integer
Duplex As Integer
YResolution As Integer
TTOption As Integer
Collate As Integer
FormName As String * 32
UnusedPadding As Integer
BitsPerPixel As Integer
PixsWidth As Long
PixsHeight As Long
DisplayFlags As Long
DisplayFrequency As Long
' The following only appear in Windows 95, 98, 2000
ICMMethod As Long
ICMIntent As Long
MediaType As Long
DitherType As Long
Reserved1 As Long
Reserved2 As Long
' The following only appear in Windows 2000
PanningWidth As Long
PanningHeight As Long
End Type
Private Declare Function EnumDisplaySettings Lib "user32.dll" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As DEVMODE) As Long
Private Const ENUM_CURRENT_SETTINGS = -1
Private Const ENUM_REGISTRY_SETTINGS = -2
'Private Const SM_CXSCREEN = 0&
'Private Const SM_CYSCREEN = 1&
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
Private Const RASTERCAPS As Long = 38
Private Const SM_CXFULLSCREEN As Long = 16
Private Const SM_CYFULLSCREEN As Long = 17
Private Const HORZRES As Long = 8&
Private Const VERTRES As Long = 10&
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Const TIFF_LZW As String = "LZW"
Private Const TIFF_RLE As String = "RLE" 'Pixel Depth must be 1.
Private Const TIFF_CCITT3 As String = "CCITT3" 'Pixel Depth must be 1.
Private Const TIFF_CCITT4 As String = "CCITT4" 'Pixel Depth must be 1.
Private Const TIFF_Uncompressed As String = "Uncompressed"
' --------------------------------
' Screen capture
' --------------------------------
Private Sub sPrntWnd()
Dim oShp As Excel.Shape
Dim oXlRng As Excel.Range
Dim oRect As RECT
Dim strFullPathFile As String
Dim Seconds As Double
Dim lgShp As Long
Dim hDC As Long
'Dim hWnd As Long
Dim lgPixelsPeriInch As Long
lgShp = 0
hDC = GetDC(0&)
With ThisWorkbook.Application
'hWnd = FindWindowEx(.Windows(1).hWnd, 0&, vbNullString, vbNullString)
'GetWindowRect .Windows(1).hWnd, oRect '--> Have to convert oRect to pixels...?
Set oXlRng = ActiveWindow.VisibleRange
oRect.Left = GetRectForExcel(oXlRng, 1) * 4 / 3
oRect.Top = GetRectForExcel(oXlRng, 2) * 4 / 3
oRect.Bottom = oRect.Top + (oXlRng.Height * 4 / 3)
oRect.Right = oRect.Left + (oXlRng.Width * 4 / 3)
lgShp = lgShp + 1
strFullPathFile = ThisWorkbook.Path & "\@" & lgShp & ".bmp"
Call fPrntSrc(oRect, strFullPathFile, 1)
End With
hDC = ReleaseDC(0, hDC)
End Sub
Public Sub sPrntSrc()
Dim oShp As Excel.Shape
Dim oXlCell As Excel.Range
Dim oRect As RECT
Dim strFullPathFile As String
Dim Seconds As Double
Dim lgShp As Long
Dim hDC As Long
Dim lgPixelsPeriInch As Long
lgShp = 0
hDC = GetDC(0&)
For Each oShp In ActiveSheet.Shapes
'If oShp.Name <> "•" Then
If oShp.Name = "x" Then
Stop
Set oXlCell = oShp.TopLeftCell
oRect.Left = GetRectForShp(oShp, 1) * 4 / 3 + (1) ' 1 pixel to avoid border
oRect.Top = GetRectForShp(oShp, 2) * 4 / 3 + (2 + 1) 'excel shape has not a good precision, 2 pixels are wrong + 1 for the border
'oRect.Left = GetRectForExcel(oXlCell, 1) * 4 / 3
'oRect.Top = GetRectForExcel(oXlCell, 3) * 4 / 3
oRect.Bottom = oRect.Top + (oShp.Height * 4 / 3) - (1 + 1) ' 1 pixel to avoid each border
oRect.Right = oRect.Left + (oShp.Width * 4 / 3) - (1 + 1) ' 1 pixel to avoid each border
lgShp = lgShp + 1
strFullPathFile = ThisWorkbook.Path & "\@" & lgShp & ".bmp"
Call fPrntSrc(oRect, strFullPathFile, 1)
Exit Sub
End If
Next oShp
hDC = ReleaseDC(0, hDC)
End Sub
Private Function fPrntSrc(ByRef oRect As RECT, _
Optional ByVal strFullPathFile As String = vbNullString, _
Optional ByVal Seconds As Double = 1) As Boolean
' Screenshots of an active window / rectangle can be captured, with/without delay
Dim oDevMode As DEVMODE ' info about the display device
Dim lgRetVal As Long ' return value
'If Seconds > 0 Then Sleep (VBA.Fix(Seconds * 1000))
With oRect
If .Bottom = .Top _
Or .Left = .Right Then
' Full screen
' Initialize the structure.
oDevMode.Size = Len(oDevMode)
' Get the display settings for the current monitor and mode.
lgRetVal = EnumDisplaySettings(vbNullString, ENUM_CURRENT_SETTINGS, oDevMode)
stdole.SavePicture hDCToPicture(GetDC(0&), 0&, 0&, oDevMode.PixsWidth, oDevMode.PixsHeight), _
strFullPathFile ' ThisWorkbook.Path & "\Screenshot.bmp"
Else
'AppActivate ThisWorkbook.Application ' bring to front Excel
'GetWindowRect GetForegroundWindow, oRect
GetWindowRect GetDC(0&), oRect
With oRect
stdole.SavePicture hDCToPicture(GetDC(0&), .Left, .Top, .Right - .Left, .Bottom - .Top), _
strFullPathFile ' ThisWorkbook.Path & "\Screenshot.bmp"
End With
End If
End With
End Function
Private Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Object
Dim Pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With Pic
.Size = Len(Pic)
.Type = 1
.hBmp = hBmp
.hPal = hPal
End With
Call OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
Set CreateBitmapPicture = IPic
End Function
Private Function hDCToPicture(ByVal hDCSrc As Long, _
ByVal LeftSrc As Long, _
ByVal TopSrc As Long, _
ByVal WidthSrc As Long, _
ByVal HeightSrc As Long) As Object
Dim hDCMemory As Long
Dim hBmp As Long, hBmpPrev As Long
Dim hPal As Long, hPalPrev As Long
Dim RasterCapsScrn As Long
Dim HasPaletteScrn As Long
Dim PaletteSizeScrn As Long
Dim LogPal As LOGPALETTE
hDCMemory = CreateCompatibleDC(hDCSrc)
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
hBmpPrev = SelectObject(hDCMemory, hBmp)
RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
HasPaletteScrn = RasterCapsScrn And RC_PALETTE
PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
With LogPal
.palVersion = &H300
.palNumEntries = 256
End With
Call GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
hPal = CreatePalette(LogPal)
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
Call RealizePalette(hDCMemory)
End If
Call BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, 13369376)
hBmp = SelectObject(hDCMemory, hBmpPrev)
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If
Call DeleteDC(hDCMemory)
Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function
'-------------------------
Private Sub fPrntSrc_2()
' if using multiple monitors, it will only capture the active monitor...
Dim oShp As Excel.Shape
Dim lgShps As Long
'AppActivate Application.caption ' select application to be captured...
AppActivate ThisWorkbook.Application ' to activate Excel
keybd_event VK_SNAPSHOT, 1, 0, 0
'Application.Wait
Application.WindowState = xlMaximized
With wsSheet1
Application.Wait (Now + TimeValue("0:00:5"))
lgShps = .Shapes.Count + 1
DoEvents
.Paste
Do Until .Shapes.Count = lgShps
DoEvents
Loop
Set oShp = .Shapes(lgShps)
With oShp
'.TopLeftCell = ActiveCell
'To Resize: once you have a handle on the shape, just assign its Height and Width properties as needed:
.Height = 600
.Width = 800
'To Position It: use the shape's TopLeftCell property.
'To Crop It: use the ".PictureFormat.Crop"
'(and/or CropLeft, CropTop, CropBottom, CropRight if you need to fine-tune what part of the screenshot is needed.
'For instance, this crops the pasted screenshot to 800x600:
.LockAspectRatio = False
.PictureFormat.CropRight = -(800 - .Width)
.PictureFormat.CropBottom = -(600 - .Height)
End With
End With
End Sub
These are other needing procedures to get the position of the range or the Excel shape.
Option Explicit
Public Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Double
Top As Double
Right As Double
Bottom As Double
End Type
Private Enum eRectBorder
eBorderLeft = 1
eBorderTop = 2
eBorderRight = 3
eBorderBottom = 4
End Enum
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Public Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
#If Win64 Then
Public Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Public Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
Public Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
#Else
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
#End If
Public Const LOGPIXELSX = 88&
Public Const LOGPIXELSY = 90&
'Private Sub SetUpProc()
' With Application
' .OnKey "z", "TestMoveShapeToMouse"
' '.Cursor = xlNorthwestArrow
' End With
'End Sub
'
'Private Sub ResetUpProc()
' With Application
' .OnKey "z"
' '.Cursor = xlDefault
' End With
'End Sub
'
'Private Sub TestMoveShapeToMouse()
''Change shape to suit
' Dim oShpRng As Excel.ShapeRange
' 'Dim oShp As Excel.Shape
'
' Set oShpRng = Selection.ShapeRange
' 'Set oShp = ActiveSheet.Shapes(oShpRng.ID - 1)
' MoveShapeToMouse ActiveSheet.Shapes(oShpRng.ID - 1)
'End Sub
'
'Private Sub MoveShapeToMouse(ByRef oShp As Excel.Shape)
' Dim oPoint As POINTAPI
' Dim xpos_0 As Double, ypos_0 As Double
' Dim z As Double
'
' On Error Resume Next
' GetCursorPos oPoint
' With ActiveWindow
' z = CorrectZoomFactor(.Zoom / 100)
' xpos_0 = .PointsToScreenPixelsX(0)
' ypos_0 = .PointsToScreenPixelsY(0)
' End With
' Application.Cursor = xlNorthwestArrow
' oShp.Left = (oPoint.x - xpos_0) / z * PointsPerPixel(LOGPIXELSX)
' oShp.Top = (oPoint.y - ypos_0) / z * PointsPerPixel(LOGPIXELSY)
' 'Application.Cursor = xlDefault
' On Error GoTo 0
'End Sub
'
'Private Function CorrectZoomFactor(ByVal z As Single) As Single
' Select Case z
' Case 2: z = 2
' Case 1.75: z = 1.765
' Case 1.5: z = 1.529
' Case 1.25: z = 1.235
' Case 1: z = 1
' Case 0.9: z = 0.882
' Case 0.85: z = 0.825
' Case 0.8: z = 0.82
' Case 0.75: z = 0.74
' Case 0.7: z = 0.705
' Case 0.65: z = 0.645
' Case 0.6: z = 0.588
' Case 0.55: z = 0.53
' Case 0.5: z = 0.5296
' Case Else
' z = 1.0069 * z + 0.0055
' End Select
' CorrectZoomFactor = z
'End Function
Public Sub Add_Shape_At_Cursor_Position()
' adds an AutoShape to the active sheet centered over the mouse position, accounting for the Excel window position and zoom.
' Currently it adds a circle (actually an oval with width 100 and height 100) but should work with any MsoAutoShapeType.
Dim PointsPerPixelX As Double, PointsPerPixelY As Double
Dim CursorPos As POINTAPI
Dim ExcelPos As POINTAPI
Dim ShapePos As POINTAPI
'Size of shape's bounding box in points
Const SHAPE_WIDTH = 100
Const SHAPE_HEIGHT = 100
'Get number of points per screen pixel, depending on screen device size
PointsPerPixelX = PointsPerScreenPixel(LOGPIXELSX)
PointsPerPixelY = PointsPerScreenPixel(LOGPIXELSY)
'Scale points per pixel according to current window zoom. The smaller the zoom, the higher the number of points per pixel
With ActiveWindow
PointsPerPixelX = PointsPerPixelX * 100 / .Zoom
PointsPerPixelY = PointsPerPixelY * 100 / .Zoom
'Get position of Excel window in screen pixels
ExcelPos.x = .PointsToScreenPixelsX(0)
ExcelPos.y = .PointsToScreenPixelsY(0)
End With
'Get mouse cursor position in screen pixels
GetCursorPos CursorPos
'Set shape position according to mouse position relative to Excel window position, scaled to the
'number of points per pixel. Since the AutoShape's position is defined by the top left corner
'of its bounding box, subtract half the shape's size to centre it over the mouse
ShapePos.x = (CursorPos.x - ExcelPos.x) * PointsPerPixelX - (SHAPE_WIDTH / 2)
ShapePos.y = (CursorPos.y - ExcelPos.y) * PointsPerPixelY - (SHAPE_HEIGHT / 2)
ActiveSheet.Shapes.AddShape msoShapeOval, ShapePos.x, ShapePos.y, SHAPE_WIDTH, SHAPE_HEIGHT
End Sub
Public Function GetRectForExcel(ByVal Target As Excel.Range, _
Optional ByVal RectBorder As Long = eRectBorder.eBorderLeft) As Double
' ----------------------------------------
' Returns the cell coordinates in points relative to the screen
'
' @param {Object} Target the cell
' @return {Rect} the cell coordinates
' ----------------------------------------
Dim Index As Integer
Dim RECT As RECT
With ActiveWindow
Set Target = Target.MergeArea
For Index = 1 To .Panes.Count
If Not Intersect(Target, .Panes(Index).VisibleRange) Is Nothing Then
With .Panes(Index)
RECT.Left = PixelsToPoints(.PointsToScreenPixelsX(Target.Left))
RECT.Top = PixelsToPoints(.PointsToScreenPixelsY(Target.Top))
End With
RECT.Right = (Target.Width * .Zoom / 100) + RECT.Left
RECT.Bottom = (Target.Height * .Zoom / 100) + RECT.Top
If RectBorder = eRectBorder.eBorderLeft Then
GetRectForExcel = RECT.Left
ElseIf RectBorder = eRectBorder.eBorderTop Then
GetRectForExcel = RECT.Top
ElseIf RectBorder = eRectBorder.eBorderRight Then
GetRectForExcel = RECT.Right
ElseIf RectBorder = eRectBorder.eBorderBottom Then
GetRectForExcel = RECT.Bottom
End If
Exit Function
End If
Next
End With
End Function
Public Function ShpRngToShp(ByVal oShpRng As Excel.ShapeRange) As Excel.Shape
Set ShpRngToShp = oShpRng.Parent.Shapes(oShpRng.Name)
End Function
Public Function GetRectForShp(ByVal oShp As Excel.Shape, _
Optional ByVal RectBorder As Long = eRectBorder.eBorderLeft) As Double
' ----------------------------------------
' Returns the cell coordinates in points relative to the screen
'
' @param {Object} Target the cell
' @return {Rect} the cell coordinates
' ----------------------------------------
Dim oXlCell As Excel.Range
Dim Index As Integer
Dim RECT As RECT
With ActiveWindow
Set oXlCell = oShp.TopLeftCell.MergeArea
For Index = 1 To .Panes.Count
If Not Intersect(oXlCell, .Panes(Index).VisibleRange) Is Nothing Then
With .Panes(Index)
RECT.Left = PixelsToPoints(.PointsToScreenPixelsX(oShp.Left))
RECT.Top = PixelsToPoints(.PointsToScreenPixelsY(oShp.Top))
End With
RECT.Right = (oShp.Width * .Zoom / 100) + RECT.Left
RECT.Bottom = (oShp.Height * .Zoom / 100) + RECT.Top
If RectBorder = eRectBorder.eBorderLeft Then
GetRectForShp = RECT.Left
ElseIf RectBorder = eRectBorder.eBorderTop Then
GetRectForShp = RECT.Top
ElseIf RectBorder = eRectBorder.eBorderRight Then
GetRectForShp = RECT.Right
ElseIf RectBorder = eRectBorder.eBorderBottom Then
GetRectForShp = RECT.Bottom
End If
Exit Function
End If
Next
End With
End Function
Public Function PointsPerScreenPixel(ByVal LOGPIXELS As Long) As Double
'Get number of points per screen pixel, depending on screen device size
Dim hDC As Long
hDC = GetDC(0)
PointsPerScreenPixel = 72 / GetDeviceCaps(hDC, LOGPIXELS)
ReleaseDC 0, hDC
End Function
Public Function TwipsToPixels(ByVal lngTwips As Long, _
ByVal blnHorizontal As Boolean) As Long
' Twip is a distance measurement - 1/1440th of an inch.
' twips = Device.TwipsPerPixelX (or Y) * pixels
' pixels = twips / Device.TwipsPerPixelX (or Y)
Const TWIPSPERINCH As Long = 1440
If blnHorizontal Then
TwipsToPixels = CLng(lngTwips / TWIPSPERINCH * DotsPerInch(True))
Else
TwipsToPixels = CLng(lngTwips / TWIPSPERINCH * DotsPerInch(False))
End If
End Function
Public Function DotsPerInch(Optional ByVal blnHorizontal As Boolean = True) As Long
Dim hDC As Long
hDC = GetDC(0)
If blnHorizontal Then
DotsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
Else
DotsPerInch = GetDeviceCaps(hDC, LOGPIXELSY)
End If
ReleaseDC 0, hDC
End Function
Public Function PixelsToPoints(ByVal Pixels As Double, _
Optional ByVal blnHorizontal As Boolean = True) As Double
' ----------------------------------------
' Converts pixels to points
' More info http://office.microsoft.com/en-us/excel-help/measurement-units-and-rulers-in-excel-HP001151724.aspx
' Measurement units and rulers in Excel
' Unlike Microsoft Word, Excel does not provide a horizontal or vertical ruler, and there is no quick way to measure the width or height of a worksheet in inches.
' Excel uses characters, points, and pixels as units of measurement.
' The width of cells is displayed in characters and pixels rather than in inches.
' • When you drag the boundary of a column heading to adjust the width of a column on the worksheet, a ScreenTip displays the width in characters and shows pixels in parentheses.
' The height of cells is displayed in points and pixels rather than in inches.
' • When you drag the boundary of a row heading to adjust the height of a row on the worksheet, a ScreenTip displays the height in points and shows pixels in parentheses.
'
' An approximate conversion of points and pixels to inches is shown in the following table.
' Points Pixels Inches
' 18 24 .25
' 36 48 .5
' 72 96 1
' 108 144 1.5
' 144 192 2
'
' @param {Double} Pixels
' @return {Double} Points
' ----------------------------------------
Dim hDC As Long
Dim iDPI As Long
hDC = GetDC(0)
If blnHorizontal Then
iDPI = GetDeviceCaps(hDC, LOGPIXELSX)
Else
iDPI = GetDeviceCaps(hDC, LOGPIXELSY)
End If
PixelsToPoints = Pixels / iDPI * 72
ReleaseDC 0, hDC
End Function
Public Function PointsToPixels(ByVal Points As Double, _
Optional ByVal blnHorizontal As Boolean = True) As Double
' ----------------------------------------
' Converts points to pixels
' More info http://office.microsoft.com/en-us/excel-help/measurement-units-and-rulers-in-excel-HP001151724.aspx
'
' @param {Double} Points
' @return {Double} Pixels
' ----------------------------------------
Dim hDC As Long
Dim iDPI As Long
hDC = GetDC(0)
If blnHorizontal Then
iDPI = GetDeviceCaps(hDC, LOGPIXELSX)
Else
iDPI = GetDeviceCaps(hDC, LOGPIXELSY)
End If
PointsToPixels = (Points / 72) * iDPI
ReleaseDC 0, hDC
End Function
Public Function PointsPerPixel(ByVal LOGPIXELS As Long) As Double
'LOGPIXELSX: The WIDTH of a pixel in Excel's userform coordinates
'LOGPIXELSY: The HEIGHT of a pixel in Excel's userform coordinates
Dim hDC As Long
hDC = GetDC(0)
'A point is defined as 1/72 of an inch and LOGPIXELS returns
'the number of pixels per logical inch, so divide them to give
'the width of a pixel in Excel's userform coordinates
PointsPerPixel = 72 / GetDeviceCaps(hDC, LOGPIXELS)
ReleaseDC 0, hDC
End Function
Following is also the code for a BMP/JPG/TIF/GIF/PNG conversion, that comes very handy with this, as the BMP format is a disk eating beast.
' --------------------------------
' Image conversion
' --------------------------------
' Option 1
Private Sub ImgConv(ByVal InFileName As String, _
ByVal OutFileName As String, _
ByVal OutFormat As String, _
Optional ByVal Quality As Integer = 100, _
Optional ByVal Compression As String = TIFF_LZW)
' Reference to: Microsoft Windows Image Acquisition Library v2.0
' XP SP1 and later
' For XP you'll need to deploy it: Windows® Image Acquisition Automation Library v2.0 Tool (http://www.microsoft.com/downloads/en/details.aspx?FamilyID=a332a77a-01b8-4de6-91c2-b7ea32537e29)
Dim Img As WIA.ImageFile
Dim ImgProc As WIA.ImageProcess
Set Img = New WIA.ImageFile
Img.LoadFile InFileName
Set ImgProc = New WIA.ImageProcess
With ImgProc.Filters
.Add ImgProc.FilterInfos("Convert").FilterID
.Item(1).Properties("FormatID").Value = OutFormat
If OutFormat = wiaFormatJPEG Then
.Item(1).Properties("Quality").Value = Quality
ElseIf OutFormat = wiaFormatTIFF Then
.Item(1).Properties("Compression").Value = Compression
End If
End With
Set Img = ImgProc.Apply(Img)
On Local Error Resume Next
'If fFileExists(OutFileName) Then
'End If
'Kill OutFileName
On Local Error GoTo 0
Img.SaveFile OutFileName
End Sub
Private Sub sImageConv_Main()
Dim strPath As String
strPath = "C:\Users\CASA\Documents\"
ImgConv strPath & "a.bmp", strPath & "a.jpg", wiaFormatJPEG, 70
ImgConv strPath & "a.bmp", strPath & "a.gif", wiaFormatGIF
ImgConv strPath & "a.bmp", strPath & "a.png", wiaFormatPNG
ImgConv strPath & "a.bmp", strPath & "a.tif", wiaFormatTIFF, , TIFF_Uncompressed
' MsgBox "Complete"
End Sub
' Option 2
Private Sub PrintToPDFCreator_Early()
'' Print to Output file using PDFCreator: http://sourceforge.net/projects/pdfcreator/
'' Designed for early bind, set reference to PDFCreator
'' http://www.vbaexpress.com/forum/archive/index.php/t-8488.html
' Dim OutputJob As PDFCreator.clsPDFCreator
' Dim sOutputName As String
' Dim sOutputPath As String
' Dim lOutputType As Long
' Dim i As Integer
' Dim lgRetVal As Long
'
' '/// Change the output file name and type here! ///
' sOutputName = "test"
'
' '0=PDF, 1=Png, 2=jpg, 3=bmp, 4=pcx, 5=tif, 6=ps, 7=eps, 8=txt
' lOutputType = 2
'
' sOutputPath = ActiveDocument.Path & Application.PathSeparator
' Set OutputJob = New PDFCreator.clsPDFCreator
'
' 'Set correct filename extension
' Select Case lOutputType
' Case Is = 0: sOutputName = sOutputName & ".pdf"
' Case Is = 1: sOutputName = sOutputName & ".png"
' Case Is = 2: sOutputName = sOutputName & ".jpg"
' Case Is = 3: sOutputName = sOutputName & ".bmp"
' Case Is = 4: sOutputName = sOutputName & ".pcx"
' Case Is = 5: sOutputName = sOutputName & ".tif"
' Case Is = 6: sOutputName = sOutputName & ".ps"
' Case Is = 7: sOutputName = sOutputName & ".eps"
' Case Is = 8: sOutputName = sOutputName & ".txt"
' End Select
'
' 'Set job defaults
' With OutputJob
' If .cStart("/NoProcessingAtStartup") = False Then
' lgRetVal = MsgBox("Can't initialize PDFCreator.", _
' vbCritical + vbOKOnly, "PrtPDFCreator")
' Exit Sub
' End If
' .cOption("UseAutosave") = 1
' .cOption("UseAutosaveDirectory") = 1
' .cOption("AutosaveDirectory") = sOutputPath
' .cOption("AutosaveFilename") = sOutputName
' .cOption("AutosaveFormat") = lOutputType
' .cClearCache
' End With
'
' 'Print the document to PDF
' With ThisDocument
' .ActivePrinter = "PDFCreator"
' .PrintOut
' End With
'
' 'Wait until the print job has entered the print queue
' Do Until OutputJob.cCountOfPrintjobs = 1
' DoEvents
' Loop
' OutputJob.cPrinterStop = False
'
' 'Wait until the PDF file shows up then release the objects
' Do Until Dir(sOutputPath & sOutputName) <> ""
' DoEvents
' Loop
' OutputJob.cClose
' Set OutputJob = Nothing
End Sub
' Option 3
Private Sub ImgFFMpedConv(ByVal InFileName As String)
' Convert to any format (with/without compression) via FFMpeg http://ffmpeg.zeranoe.com/builds.
Shell ("ffmpeg.exe -i YourFile.bmp -q <qualityNumber*> ConverTo.Any") ' *write ffmpeg /? in cmd to know usage
End Sub
' Option 4
' A pure VB6 JPG class development
'http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=50065&lngWId=1