user form created in Excel 2010 wont load in Excel 2016

mmldogs

New Member
Joined
Jul 31, 2019
Messages
5
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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
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
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)

Rancidveg

New Member
Joined
Apr 14, 2015
Messages
10
I have found the error ... yes my fault . If you dont have a data sheet well it wont work . Just another reason to not work when tired . You do DUMB stuff
 

Watch MrExcel Video

Forum statistics

Threads
1,129,271
Messages
5,635,215
Members
416,847
Latest member
inaramos

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top