Print embedded active x object via vba

[lilsnoop]

This workbook was posted in a previous post several days ago, which I find to be pretty interesting; so thanks to the original poster. My question is however that the print functionality for the embedded map (active x) doesn't work and I would like it to. The code presently just prints the address information only and not the map. I'm attaching the workbook but would surely be appreciative if anyone knows any vba coding that would allow for the capture and print of the map section (if possible). Thanks for your time.

[lilsnoop]

It appears from the lack of responses..that printing the embedded map is not possible. Any chance vba coding could be used to somehow capture the map image like via a print screen function but just of the map image and then save the image to a folder as a jpeg? Thanks for any/all input!

[lilsnoop]

I've been searching the web trying to figure out how I can get this to print out or do a "print screen" type effect to eventually be able to print out the map portion, etc. I'm attaching a modified example of some vba code that is suppose to do a "print screen" then copy image to new workbook, but I'm getting the following error message "Clipboard corrupted, possibly by another task". The code is placed in a module, which can be activated by a button in my example-some comments edited to meet required posting limits:

Option Explicit
'Module code for capturing a screen image (Print Screen) and pasting to a new workbook
'Created on November 14th, 2009, compiled by Zack Barresse
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Const SRCCOPY = &HCC0020 ' (DWORD) destination = source

Private Type DEVMODE
    dmDeviceName As String * CCHDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCHFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Long
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type

'API
Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Declare Function EmptyClipboard Lib "user32.dll" () As Long
Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function CloseClipboard Lib "user32.dll" () As Long
Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
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
Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long

Declare Function CountClipboardFormats Lib "user32" () As Long
Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Declare Function CreateIC Lib "GDI32" Alias "CreateICA" _
                          (ByVal lpDriverName As String, ByVal lpDeviceName As String, _
                           ByVal lpOutput As String, lpInitData As Long) As Long
Declare Function GetDeviceCaps Lib "GDI32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long

Sub GetPrintScreen()
'##### SET SCREEN CAPTURE SIZES HERE
    Call CaptureScreen(0, 0, 800, 600)
End Sub

Public Sub ScreenToGIF_NewWorkbook()
    Dim wbDest As Workbook, wsDest As Worksheet
    Dim FromType As String, PicHigh As Single
    Dim PicWide As Single, PicWideInch As Single
    Dim PicHighInch As Single, DPI As Long
    Dim PixelsWide As Integer, PixelsHigh As Integer

    Call TOGGLEEVENTS(False)
    Call GetPrintScreen
    
    If CountClipboardFormats = 0 Then
        MsgBox "Clipboard is currently empty.", vbExclamation, "Nothing to Paste"
        GoTo EndOfSub
    End If

    If IsClipboardFormatAvailable(14) <> 0 Then
        FromType = "pic"
    ElseIf IsClipboardFormatAvailable(2) <> 0 Then
        FromType = "bmp"
    Else
        MsgBox "Clipboard does not contain a picture or bitmap to paste.", _
               vbExclamation, "No Picture"
        Exit Sub
    End If

    Application.StatusBar = "Pasting from clipboard ..."

    Set wbDest = Workbooks.Add(xlWBATWorksheet)
    Set wsDest = wbDest.Sheets(1)
    wbDest.Activate
    wsDest.Activate
    wsDest.Range("B3").Activate

    On Error Resume Next 
    wsDest.Pictures.Paste.Select
    On Error GoTo 0

    'If the pasted item is an "OLEObject" then must convert to a bitmap
    'to get the correct size, including the added border and matting.
    'Do this via a CopyPicture-Bitmap and then a second Pictures.Paste.
    If TypeName(Selection) = "OLEObject" Then
        With Selection
            .CopyPicture Appearance:=xlScreen, Format:=xlBitmap
            .Delete
            ActiveSheet.Pictures.Paste.Select
            'Modify the FromType (used below in the suggested file name)
            'to signal that the original clipboard image is not being used.
            FromType = "ole object"
        End With
    End If

    'Make sure that what was pasted and selected is as expected.
    'Note this is the Excel TypeName, not the clipboard format.
    If TypeName(Selection) = "Picture" Then
        With Selection
                PicWide = .Width
                PicHigh = .Height
                .Delete
        End With
    Else
        'Can get to here if a chart is selected and "Copy"ed instead of "Copy Picture"ed.
        'Otherwise, ???.
        If TypeName(Selection) = "ChartObject" Then
            MsgBox "Use Shift > Edit > Copy Picture on charts, not just Copy.", _
                   vbExclamation, "Got a Chart Copy, not a Chart Picture"
        Else
            MsgBox "Excel pasted a '" & TypeName(Selection) & "' instead of a Picture.", _
                   vbExclamation, "Not a Picture"
        End If
        'Clean up and quit.
        ActiveWorkbook.Close SaveChanges:=False
        GoTo EndOfSub
    End If

    With Sheets(1)
        .ChartObjects.Add(.Range("B3").Left, .Range("B3").Top, PicWide, PicHigh).Activate
    End With

    'Paste the [resized] bitmap into the ChartArea, which creates ActiveChart.Shapes(1).
    On Error Resume Next
    ActiveChart.Pictures.Paste.Select
    On Error GoTo 0
    If TypeName(Selection) = "Picture" Then
        With ActiveChart
            'Adjust the position of the pasted picture, aka ActiveChart.Shapes(1).
            'Adjustment is slightly greater than the .ChartArea.Left/Top offset, why ???
            ''''         .Shapes(1).IncrementLeft -1
            ''''         .Shapes(1).IncrementTop -4
            'Remove chart border.  This must be done *after* all positioning and sizing.
            '         .ChartArea.Border.LineStyle = 0
        End With

        'Show pixel size info above the picture-in-chart-soon-to-be-GIF/JPEG/PNG.
        PicWideInch = PicWide / 72    'points to inches ("logical", not necessarily physical)
        PicHighInch = PicHigh / 72
        DPI = PixelsPerInch()         'typically 96 or 120 dpi for displays
        PixelsWide = PicWideInch * DPI
        PixelsHigh = PicHighInch * DPI
    Else
        'Something other than a Picture was pasted into the chart.
        'This is very unlikely.
        MsgBox "Clipboard corrupted, possibly by another task."
    End If
    
EndOfSub:
    Call TOGGLEEVENTS(True)
End Sub

Public Sub TOGGLEEVENTS(blnState As Boolean)
'Originally written by Zack Barresse
    With Application
        .DisplayAlerts = blnState
        .EnableEvents = blnState
        .ScreenUpdating = blnState
        If blnState Then .CutCopyMode = False
        If blnState Then .StatusBar = False
    End With
End Sub

Public Function PixelsPerInch() As Long
   'Get the screen resolution in pixels per inch.
   'Under Excel 2000 and above could use Application.DefaultWebOptions.PixelsPerInch.
   Dim hdc As Long
   hdc = CreateIC("DISPLAY", vbNullString, vbNullString, 0)
   PixelsPerInch = GetDeviceCaps(hdc, 88)  'LOGPIXELSX = 88 = Logical pixels/inch in X
   DeleteDC (hdc)
End Function

'Screen Capture Procedure, coordinates are expressed in pixels
Public Sub CaptureScreen(Left As Long, Top As Long, Width As Long, Height As Long)
    Dim srcDC As Long, trgDC As Long, BMPHandle As Long, dm As DEVMODE
    srcDC = CreateDC("DISPLAY", "", "", dm)
    trgDC = CreateCompatibleDC(srcDC)
    BMPHandle = CreateCompatibleBitmap(srcDC, Width, Height)
    SelectObject trgDC, BMPHandle
    BitBlt trgDC, 0, 0, Width, Height, srcDC, Left, Top, SRCCOPY
    OpenClipboard 0&
    EmptyClipboard
    SetClipboardData 2, BMPHandle
    CloseClipboard
    DeleteDC trgDC
    ReleaseDC BMPHandle, srcDC
End Sub

Any help getting this code to work properly would be greatly appreciated!

[lilsnoop]

From looking into this further. It appears the "print screen" functionality is working from the vba code posted above as well as it opening up another workbook to paste an image into. Currently it has an empty frame for the image to go into. If one were to however right click on their mouse and click "paste" the image would go into that framed area. So it appears that the code isn't completing the final "paste" function properly...and instead giving a message prompt as dictated in the code.

[lilsnoop]

Hope everyone has a blessed Holiday season! I've managed to make some changes to the vba coding posted earlier and it now works as hoped! Here is the revised coding:

Option Explicit
 
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Const SRCCOPY = &HCC0020 ' (DWORD) destination = source
 
Private Type DEVMODE
    dmDeviceName As String * CCHDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCHFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Long
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type
 
 'API
Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Declare Function EmptyClipboard Lib "user32.dll" () As Long
Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function CloseClipboard Lib "user32.dll" () As Long
Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
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
Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
 
Declare Function CountClipboardFormats Lib "user32" () As Long
Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Declare Function CreateIC Lib "GDI32" Alias "CreateICA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, lpInitData As Long) As Long
Declare Function GetDeviceCaps Lib "GDI32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
 
Sub GetPrintScreen()
     '##### SET SCREEN CAPTURE SIZES HERE
    Call CaptureScreen(0, 0, 800, 705)
End Sub
 
Public Sub ScreenToGIF_NewWorkbook()
    Dim wbDest As Workbook, wsDest As Worksheet
    Dim FromType As String, PicHigh As Single
    Dim PicWide As Single, PicWideInch As Single
    Dim PicHighInch As Single, DPI As Long
    Dim PixelsWide As Integer, PixelsHigh As Integer
    Application.DisplayFullScreen = True
    ActiveWindow.DisplayHeadings = False
    Application.DisplayFormulaBar = False
    Call TOGGLEEVENTS(False)
    Call GetPrintScreen
    Application.DisplayFullScreen = False
    ActiveWindow.DisplayHeadings = True
    Application.DisplayFormulaBar = True
    If CountClipboardFormats = 0 Then
        MsgBox "Clipboard is currently empty.", vbExclamation, "Nothing to Paste"
        GoTo EndOfSub
    End If
     
    If IsClipboardFormatAvailable(14) <> 0 Then
        FromType = "pic"
    ElseIf IsClipboardFormatAvailable(2) <> 0 Then
        FromType = "bmp"
    Else
        MsgBox "Clipboard does not contain a picture or bitmap to paste.", _
        vbExclamation, "No Picture"
        Exit Sub
    End If
     
    Application.StatusBar = "Pasting from clipboard ..."
     
    Set wbDest = Workbooks.Add(xlWBATWorksheet)
    Set wsDest = wbDest.Sheets(1)
    wbDest.Activate
    wsDest.Activate
    wsDest.PageSetup.Orientation = xlLandscape
    wsDest.PageSetup.LeftMargin = Application.InchesToPoints(0.25)
    wsDest.PageSetup.RightMargin = Application.InchesToPoints(0.25)
    wsDest.PageSetup.TopMargin = Application.InchesToPoints(0.25)
    wsDest.PageSetup.BottomMargin = Application.InchesToPoints(0.25)
    wsDest.PageSetup.HeaderMargin = Application.InchesToPoints(0.3)
    wsDest.PageSetup.FooterMargin = Application.InchesToPoints(0.3)
    wsDest.Range("A2").Activate

    On Error Resume Next 'just in case
    wsDest.Pictures.Paste.Select
    
    On Error GoTo 0
     
    If TypeName(Selection) = "OLEObject" Then
        With Selection
            .CopyPicture Appearance:=xlScreen, Format:=xlBitmap
            .delete
            ActiveSheet.Pictures.Paste.Select
             'Modify the FromType (used below in the suggested file name)
             'to signal that the original clipboard image is not being used.
            FromType = "ole object"
        End With
    End If

    If TypeName(Selection) = "Picture" Then
        With Selection
            PicWide = .Width
            PicHigh = .Height
            .delete
            
        End With
    Else

        If TypeName(Selection) = "ChartObject" Then
            MsgBox "Use Shift > Edit > Copy Picture on charts, not just Copy.", _
            vbExclamation, "Got a Chart Copy, not a Chart Picture"
        Else
            MsgBox "Excel pasted a '" & TypeName(Selection) & "' instead of a Picture.", _
            vbExclamation, "Not a Picture"
        End If
         'Clean up and quit.
        ActiveWorkbook.Close SaveChanges:=False
        GoTo EndOfSub
    End If
    On Error Resume Next
    ActiveChart.Pictures.Paste.Select
    On Error GoTo 0
    If TypeName(Selection) = "Picture" Then
        With ActiveChart
             'Adjust the position of the pasted picture, aka ActiveChart.Shapes(1).
             'Adjustment is slightly greater than the .ChartArea.Left/Top offset, why ???
             ''''         .Shapes(1).IncrementLeft -1
             ''''         .Shapes(1).IncrementTop -4
             'Remove chart border.  This must be done *after* all positioning and sizing.
             '         .ChartArea.Border.LineStyle = 0
             
        End With
         
         'Show pixel size info above the picture-in-chart-soon-to-be-GIF/JPEG/PNG.
        PicWideInch = PicWide / 72 'points to inches ("logical", not necessarily physical)
        PicHighInch = PicHigh / 72
        DPI = PixelsPerInch() 'typically 96 or 120 dpi for displays
        PixelsWide = PicWideInch * DPI
        PixelsHigh = PicHighInch * DPI

    Else
         'Something other than a Picture was pasted into the chart.
         'This is very unlikely.
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveWindow.SelectedSheets.PrintPreview
    End If
     
EndOfSub:
    Call TOGGLEEVENTS(True)
End Sub
 
Public Sub TOGGLEEVENTS(blnState As Boolean)
     'Originally written by Zack Barresse
    With Application
        .DisplayAlerts = blnState
        .EnableEvents = blnState
        .ScreenUpdating = blnState
        If blnState Then .CutCopyMode = False
        If blnState Then .StatusBar = False
    End With
End Sub
 
Public Function PixelsPerInch() As Long
     'Get the screen resolution in pixels per inch.
     'Under Excel 2000 and above could use Application.DefaultWebOptions.PixelsPerInch.
    Dim hdc As Long
    hdc = CreateIC("DISPLAY", vbNullString, vbNullString, 0)
    PixelsPerInch = GetDeviceCaps(hdc, 88) 'LOGPIXELSX = 88 = Logical pixels/inch in X
    DeleteDC (hdc)
End Function
 
 'Screen Capture Procedure, coordinates are expressed in pixels
Public Sub CaptureScreen(Left As Long, Top As Long, Width As Long, Height As Long)
    Dim srcDC As Long, trgDC As Long, BMPHandle As Long, dm As DEVMODE
    srcDC = CreateDC("DISPLAY", "", "", dm)
    trgDC = CreateCompatibleDC(srcDC)
    BMPHandle = CreateCompatibleBitmap(srcDC, Width, Height)
    SelectObject trgDC, BMPHandle
    BitBlt trgDC, 0, 0, Width, Height, srcDC, Left, Top, SRCCOPY
    OpenClipboard 0&
    EmptyClipboard
    SetClipboardData 2, BMPHandle
    CloseClipboard
    DeleteDC trgDC
    ReleaseDC BMPHandle, srcDC
End Sub

[skate1991]

I cant get this to work for me, anyone have a working workbook.

Thanks

[lilsnoop]

See if this example attachment will do the job for you.

[skate1991]

Thanks I havent tested it yet, The site is blocked at work getting it unblocked now, will let you know how it goes, Thanks for all your work