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 SubThese 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 FunctionFollowing 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