Hello all
I have a form that was created using Excel 2010 and have recently had an upgrade to Excel 2016 . I am running 64 bit system. I have managed to resolve some errors using "PtrSafe" code which worked once but now the user form wont load. Not sure what to put in for the .Show vba function error is Run-Time error 9 script out of range
All code included in in this post
Hopefully there is a simple update
I have a form that was created using Excel 2010 and have recently had an upgrade to Excel 2016 . I am running 64 bit system. I have managed to resolve some errors using "PtrSafe" code which worked once but now the user form wont load. Not sure what to put in for the .Show vba function error is Run-Time error 9 script out of range
All code included in in this post
Hopefully there is a simple update
VBA Code:
Private Sub CommandButton1_Click()
Ejournal.Show
End Sub
Option Explicit
'Routines below similar to Stephen Bullen's PastePicture.xls, http://www.oaltd.co.uk/excel/
'https://www.excelforum.com/excel-programming-vba-macros/708529-copy-userform-to-clipboard-and-save-as-jpeg.html
' Object dimensions
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare PtrSafe Function _
GetActiveWindow& Lib "user32" ()
Private Declare PtrSafe Sub GetWindowRect Lib _
"user32" (ByVal hwnd&, lpRect As RECT)
Private Declare PtrSafe Function _
GetDesktopWindow& Lib "user32" ()
' Clipboard manipulation
Private Declare PtrSafe Function _
OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare PtrSafe Function _
CloseClipboard& Lib "user32" ()
Private Declare PtrSafe Function SetClipboardData& _
Lib "user32" (ByVal wFormat&, ByVal hMem&)
Private Declare PtrSafe Function _
EmptyClipboard& Lib "user32" ()
' Bitmap creation
Private Declare PtrSafe Function GetDC& _
Lib "user32" (ByVal hwnd&)
Private Declare PtrSafe Function _
CreateCompatibleDC& Lib "gdi32" (ByVal hDC&)
Private Declare PtrSafe Function CreateCompatibleBitmap& _
Lib "gdi32" (ByVal hDC&, ByVal nWidth& _
, ByVal nHeight&)
Private Declare PtrSafe Function SelectObject& _
Lib "gdi32" (ByVal hDC&, ByVal hObject&)
Private Declare PtrSafe Function BitBlt& Lib "gdi32" _
(ByVal hDestDC&, ByVal X&, ByVal Y& _
, ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC& _
, ByVal XSrc&, ByVal YSrc&, ByVal dwRop&)
Private Declare PtrSafe Function ReleaseDC& _
Lib "user32" (ByVal hwnd&, ByVal hDC&)
Private Declare PtrSafe Function DeleteDC& _
Lib "gdi32" (ByVal hDC&)
' Picture creation
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare PtrSafe Function OleCreatePictureIndirect _
Lib "olepro32.dll" (PicDesc As PicBmp _
, RefIID As Guid, ByVal fPictureOwnsHandle As Long _
, IPic As IPicture) As Long
' Object (UserForm, FullScreen, etc.):
Sub ScreenObjectCopy()
Dim hPtr&, r As RECT
Call GetWindowRect(GetActiveWindow, r)
hPtr = CreateBitmap(r.Right - r.Left _
, r.Bottom - r.Top, r.Left, r.Top)
If hPtr = 0 Then Exit Sub
' Save image on disk
'SavePicture CreatePicture(hPtr), "C:\Documents and Settings\Administrator\My Documents.bmp"
SavePicture CreatePicture(hPtr), "C:\temp\My Documents.bmp"
ActiveSheet.Paste
End Sub
Sub ScreenPartCopy()
Dim hPtr&
' Pixels coordinates (Width, Height, Left, Top)
hPtr = CreateBitmap(186, 60, 102, 432)
If hPtr = 0 Then Exit Sub
' Save image on disk
SavePicture CreatePicture(hPtr), "C:\Documents and Settings\Administrator\My Documents.bmp"
ActiveSheet.Paste
End Sub
Private Function CreateBitmap&(ByVal W& _
, ByVal H&, Optional L& = 0, Optional T& = 0)
Dim hwnd&, hBitmap&, hDC&, hDCMem&
hwnd = GetDesktopWindow()
' Get Desktop device context and allocate memory
hDC = GetDC(hwnd)
hDCMem = CreateCompatibleDC(hDC)
hBitmap = CreateCompatibleBitmap(hDC, W, H)
If hBitmap Then
Call SelectObject(hDCMem, hBitmap)
' Copy Desktop bitmap to memory location
' based on object coordinates.
Call BitBlt(hDCMem, 0, 0, W, H, hDC, L, T, &HCC0020)
' Set up Clipboard and copy bitmap
Call OpenClipboard(hwnd)
Call EmptyClipboard
CreateBitmap = SetClipboardData(2, hBitmap)
Call CloseClipboard
End If
' Clean up handles
Call DeleteDC(hDCMem)
Call ReleaseDC(hwnd, hDC)
End Function
Private Function CreatePicture(ByVal hBmp&) As IPicture
Dim Ret&, Pic As PicBmp, IPic As IPicture, IID As Guid
With IID
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With Pic
.Size = Len(Pic)
.Type = 1
.hBmp = hBmp
End With
Ret = OleCreatePictureIndirect(Pic, IID, 1, IPic)
Set CreatePicture = IPic
End Function
'Added by Kenneth Hobson, 9/22/2017
' Object (UserForm, FullScreen, etc.):
Sub SOC(pasteRange As Range, Optional bmpPath As String = "")
Dim hPtr&, r As RECT, ac As Range
Set ac = ActiveCell
Call GetWindowRect(GetActiveWindow, r)
hPtr = CreateBitmap(r.Right - r.Left _
, r.Bottom - r.Top, r.Left, r.Top)
If hPtr = 0 Then Exit Sub
' Save image on disk
If bmpPath <> "" Then SavePicture CreatePicture(hPtr), bmpPath
With pasteRange
.Parent.Activate
.Select
.Parent.Paste
End With
ac.Parent.Activate
ac.Select
End Sub
Sub ScreenObjectCopyToClipboard()
Dim hPtr&, r As RECT
Call GetWindowRect(GetActiveWindow, r)
hPtr = CreateBitmap(r.Right - r.Left _
, r.Bottom - r.Top, r.Left, r.Top)
If hPtr = 0 Then Exit Sub
End Sub
Sub SaveScreenToPDF(pdf As String, Optional Orientation As Integer = xlPortrait)
Dim hPtr&, r As RECT
Call GetWindowRect(GetActiveWindow, r)
hPtr = CreateBitmap(r.Right - r.Left, r.Bottom - r.Top, r.Left, r.Top)
If hPtr = 0 Then Exit Sub
With Workbooks.Add(xlWBATWorksheet).Worksheets(1)
'.PasteSpecial Format:="Bitmap", Link:=False, DisplayAsIcon:=False
.Paste
.PageSetup.Orientation = Orientation
'.PageSetup.FitToPagesWide = 1
'.PageSetup.FitToPagesTall = 1
.PageSetup.Zoom = False
.ExportAsFixedFormat Type:=xlTypePDF, filename:=pdf, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Workbooks(.Parent.name).Close False
End With
End Sub
