I wrote a large VBA program which, in a nutshell, calculates the energy need of buildings. It would be way to much code to post here but firstly it reads a configuration file for each building, then loads some heat load profiles from the disk and then dynamically calculates for 35040 quarter hours which heat producers generates what amount of heat.
On Windows 7 with Windows Defender it just runs smooth and fine, no matter what Excel Version (2007, 2010, 2013, 365 tested).
Now, if I'm running the same code on my computer with Windows 10 and Windows Defender (Excel 365), it is slower by an incredible amount (factor 1000 or so it feels). And strangely, everything is way slower, it is not a certain procedure or event. Loading the files and profiles from the disk takes forever, but calculating the energy needs in the loop (where nothing is transferred from/to the drive) is way slower aswell. The GUI isn't refreshing at all and the whole application just seems frozen.
At the same time MsMpEng.exe is on full load, suggesting Windows Defender has a problem. And surprise, having turned off Windows Defender, everything runs fine.
Now, because there are so many classes/modules/etc. it is hard to say, what may be the problem and I can't upload the code. But at least I have a suspicion. Every class has a Parent Property, implemented as depicted here.
The parent property is called very often and all over the code so the extreme slow down would make sense if there was a problem with the CopyMemory-API/Function.
Update 1:
I removed the CopyMemory-Function and replaced all the Parents with Circular References. This is no long term solution, but it solved part of the problem. When I wait long enough the calculation starts at some point and is as fast as it's supposed to be. So the problem could be related to API-Functions in general because I use quite a lot for the GUI, namely
Public Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Public Declare PtrSafe Function GetDeviceCaps Lib "Gdi32" (ByVal hDC As LongPtr, ByVal _
nIndex As Long) As Long
Public Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal _
hDC As LongPtr) As Long
Public Declare PtrSafe Function GetSystemMetrics32 Lib "user32" _
Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long
Public Declare PtrSafe Function SetWindowPos Lib "user32" _
(ByVal hWnd As LongPtr, ByVal hWndInsertAfter As LongPtr, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Public Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Public Declare PtrSafe Sub ReleaseCapture Lib "user32" ()
Public Declare PtrSafe Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" _
(ByVal hInst As LongPtr, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As LongPtr
Public Declare PtrSafe Function GetActiveWindow32 Lib "user32" Alias "GetActiveWindow" () As Integer
#If Win64 Then
Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" _
(ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" _
(ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#End If
Update 2 (which makes the topic in a way solved):
The reason for the loading-part of the program took so long is because I used the JSON-Converter. And as it turns out there was a similar problem. Since I updated the module and removed every other API-Call everything runs fine and smooth. So it is definitly caused by the API-Calls though I don't know why there aren't that many other people complaining about the huge performance issues. And now I can't tweak the GUI in the way I wan't to and I don't really know how to implement the parent property properly.
Related
Hello can you somone tell me how make this macros to run on 32 bit and on 64 bit Office?
on 32 bit macros is run but on 64 bit it not and it is in red color. Thank you.
Public Declare Function CreatePopupMenu Lib "user32" () As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long`
Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Public Declare Function SetMenu Lib "user32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long
Public Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long```
I was using code that was working fine when I was running the 32-bit version of Excel. After I was switched to the 64-Bit version, the macro broke. I updated the dll calls to use LongPtr everywhere instead of Long.
Is there any way to determine which arguments and return types need to be changed for VBA7, and which don't, for a specific Declare Function?
Here is an example of some of the "Declare Functions" that I have updated (there were actually several more too).
#If VBA7 Then
Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nWidth As LongPtr, ByVal nHeight As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongPtr) As LongPtr
Private Const LOGPIXELSY As Long = 90
#Else
Private Declare CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData 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 Const LOGPIXELSY As Long = 90
#End If
This code was adapted from an answer to this question:
vb macro string width
Relevant snippet is copied here below:
Private Function GetLabelSize(text As String, font As StdFont) As SIZE
Dim tempDC As Long
Dim tempBMP As Long
Dim f As Long
Dim lf As LOGFONT
Dim textSize As SIZE
tempDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0)
tempBMP = CreateCompatibleBitmap(tempDC, 1, 1)
I get a runtime error that just says "Compile Error: Type Mismatch." The function call to CreateDC is highlighted, and the debugger breaks on the function GetLabelSize. I have no idea which variable is now causing the error. I'm also assuming that once I fix this first error, I'll have other errors too.
Do I need to pass the value of that last argument (ByVal 0) as an explicitly typed variable? If so how?
I updated the dll calls to use LongPtr everywhere instead of Long.
You should have not done that.
By adding PtrSafe to a function declaration, you promise to the compiler that you have put LongPtr in all places where it needs to be, and nowhere else.
LongPtr is a pointer-sized integer. It must be used for things that have the same size as a pointer.
To learn which Windows API types should be described as LongPtr, you must look at the original function signature, consult https://learn.microsoft.com/en-us/windows/win32/winprog/windows-data-types, track the used data types through all the typedefs down to the basic types, and use LongPtr for those that are pointers to things.
For the functions that you have shown, that would be
#If VBA7 Then
Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongPtr) As Long
#Else
Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData 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 DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
#End If
When you declare variables to hold your LongPtr results, you need to use #If VBA7 too:
#If VBA7 Then
Dim tempDC As LongPtr
Dim tempBMP As LongPtr
#Else
Dim tempDC As Long
Dim tempBMP As Long
#End If
If you don't have to support Office 2007 and older, you can ditch the #If VBA7s and only use the LongPtr branch.
Im trying to run a macro code but since I'm using a 64 bit Excel 2016 this code is not working. Please help me how to fix this.
Private Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" _
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function IIDFromString Lib "ole32" _
(ByVal lpsz As Long, ByRef lpiid As GUID) As Long
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" _
(ByVal hWnd As Long, ByVal dwId As Long, ByRef riid As GUID, _
ByRef ppvObject As Object) As Long
These should work on 64 bit Excel
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
(ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, _
ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function IIDFromString Lib "ole32" _
(ByVal lpsz As LongPtr, ByRef lpiid As GUID) As Long
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" _
(ByVal Hwnd As LongPtr, ByVal dwId As Long, ByRef riid As GUID, _
ByRef ppvObject As Object) As Long
If you need it to run on both you can use the following #If VBA7
#If VBA7 Then
'64 bit declares here
#Else
'32 bit declares here
#End If
A nice resource for PtrSafe Win32 API declares can be found here: Win32API_PtrSafe.txt
We need to do following two code changes:
Replace Long data type with LongPtr, at all places in the
script
You need to change the private function declarations as
below:
OLD:
Private Declare Function GetTimeZoneInformation Lib "kernel32" ( _
lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
NEW:
Private Declare PtrSafe Function GetTimeZoneInformation Lib "kernel32" ( _
lpTimeZoneInformation As TIME_ZONE_INFORMATION) As LongPtr
Is there any way to get display zoom value of Windows? The 200% in the picture is exactly what I would like to get.
This question is only half the means to achieve another purpose, which is formulated in that question: Excel Shape position disturbed by Windows Display Zoom settings
You can retrieve this information with a WIN32-API call
Option Explicit
Private Const LOGPIXELSX As Long = 88
#If VBA7 Then
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function EnumDisplayMonitors Lib "user32" (ByVal hdc As LongPtr, ByRef lprcClip As Any, ByVal lpfnEnum As LongPtr, ByVal dwData As Long) As Long
#Else
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function EnumDisplayMonitors Lib "user32" (ByVal hdc As Long, ByRef lprcClip As Any, ByVal lpfnEnum As Long, ByVal dwData As Long) As Long
#End If
Public Function GetDpi() As Long
#If VBA7 Then
Dim hdcScreen As LongPtr
Dim hWnd As LongPtr
#Else
Dim hdcScreen As Long
Dim hWnd As Long
#End If
hWnd = GetActiveWindow()
hdcScreen = GetDC(hWnd)
Dim iDPI As Long
iDPI = -1
If (hdcScreen) Then
iDPI = GetDeviceCaps(hdcScreen, LOGPIXELSX)
ReleaseDC hWnd, hdcScreen
End If
GetDpi = iDPI
End Function
This will result in 192 for eg 200%:
96 – Smaller 100%
120 – Medium 125%
144 – Larger 150%
192 – Extra Large 200%
240 – Custom 250%
288 – Custom 300%
384 – Custom 400%
480 – Custom 500%
I have function declarations which have been updated to accommodate both 64-bit and 32-bit Windows (VBA6 & VBA7). I would like to keep both declarations, since some of our clients still use Excel 2007.
The problem is that the VBA6 declarations (following the Else statement) seem to sometimes (though not always) throw a compiler error in Excel 2016 (tested on Office 365, 64 bit) upon opening the application, even though it will never be read.
(Compile error: The code in this project must be updated for use on 64-bit systems. Please review and update Declare statements and mark them with the PtrSafe attribute.)
Is there any way that this can be avoided?
#If VBA7 Then
Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal
dwProcessId As Long) As Long
#Else
Private Declare Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
#End If
Your declaration of the PtrSafe Function WaitForSingleObject is wrong. Here is the corret version.
Declare PtrSafe Function WaitForSingleObject Lib "kernel32" _
Alias "WaitForSingleObject" ( _
ByVal hHandle As LongPtr, _
ByVal dwMilliseconds As Long _
) As Long