I have seen a lot of suggestions for this problem, and I have tried them all, but none seem to work. The VBA code is in a non-Microsoft product (SAP Business Objects, which might be the problem). I create an Excel object:
Set oExcel = CreateObject("Excel.Application")
Load the contents from column 1 of one of the WorkSheets in a particular workbook, then close Excel. Each time, it leaves a process in memory, taking up 5+ mb of memory.
I tried making the oExcel object visible, so that at least I could kill it without resorting to the Task Manager, but when I call Quit, the UI quits, and still leaves the process.
Every time I run the code, it creates a new process. So I tried to reuse any existing Excel processes by calling
Set m_oExcel = GetObject(, "Excel.Application")
and only creating it if that call returns nothing,
That did not proliferate the processes, but the single process grew by 5+ mb each time, so essentially the same problem.
In each case, I close the workbook I opened and set DisplayAlerts to False before quitting:
m_oBook.Close SaveChanges:=False
m_oExcel.DisplayAlerts = False
m_oExcel.Quit
This bit of code has been in use for at least five years, but this problem did not crop up until we moved to Windows 7.
Here is the full code in case it helps. Note all the Excel objects are module level variables ("m_" prefix) per one suggestion, and I have used the "one-dot" rule per another suggestion. I also tried using generic objects (i.e. late bound) but that did not resolve the problem either:
Private Function GetVariablesFromXLS(ByVal sFile As String) As Boolean
On Error GoTo SubError
If Dir(sFile) = "" Then
MsgBox "File '" & sFile & "' does not exist. " & _
"The Agent and Account lists have not been updated."
Else
Set m_oExcel = CreateObject("Excel.Application")
Set m_oBooks = m_oExcel.Workbooks
Set m_oBook = m_oBooks.Open(sFile)
ThisDocument.Variables("Agent(s)").Value = DelimitedList("Agents")
ThisDocument.Variables("Account(s)").Value = DelimitedList("Accounts")
End If
GetVariablesFromXLS = True
SubExit:
On Error GoTo ResumeNext
m_oBook.Close SaveChanges:=False
Set m_oBook = Nothing
Set m_oBooks = Nothing
m_oExcel.DisplayAlerts = False
m_oExcel.Quit
Set m_oExcel = Nothing
Exit Function
SubError:
MsgBox Err.Description
GetVariablesFromXLS = False
Resume SubExit
ResumeNext:
MsgBox Err.Description
GetVariablesFromXLS = False
Resume Next
End Function
Most times this happens because Excel is keeping a COM Add-in open. Try using the link below for help on removing the COM Add-in.
Add or remove add-ins
I find particular comfort in the note:
Note This removes the add-in from memory but keeps its name in the list of available add-ins. It does not delete the add-in from your computer.
Adding an answer based on David Zemens comment. Works for me.
m_oExcel.Quit '<- Still in Task Manager after this line
Set m_oExcel = Nothing '<- Gone after this line
This question has already been answered by Acantud in response to a subsequent post:
https://stackoverflow.com/questions/25147242
Fully qualify your references to objects within the Excel workbook you open to avoid creating orphaned processes in the task manager. In this case, the solution is to prefix DelimitedList with m_oBook, such as
ThisDocument.Variables("Agent(s)").Value = m_oBook.DelimitedList("Agents")
Though this isn't supposed to happen, you could send excel a "WindowClose" message in order to force close.
You'll be needing these API functions
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
And it should look something like this:
// First, get the handle
hWindow = FindWindow(vbNullString, "Excel")
//Get proccess ID
GetWindowThreadProcessId(hWindow, ProcessValueID)
//Kill the process
ProcessValue = OpenProcess(PROCESS_ALL_ACCESS, CLng(0), ProcessValueID)
TerminateProcess(ProcessValue, CLng(0))
CloseHandle ProcessValueID
Need to use only:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Excel.Application.Quit
End Sub
Related
I've searched high and low and the following code is the closest I've come to my objective.
This is what I'm working on:
I wrote some code (OK, honestly, mostly copied bits and pieces and pasted into what is probably jumbled code that works) to email documents to my students. If a doc is open, I get and error, which allows me to manually save and close the doc (thx to Debug), and continue on. I would like to automate this, but Word seems to make things a tad difficult by opening each doc in a separate instance. I can get one instance and its doc, but if it is not the one I need, I cannot save and close it. I found how to get the other instances, but I have not found how to check each instance to see if the doc which it opened is the one I want.
I used ZeroKelvin's UDF in (Check if Word instance is running), which I modified a little bit...
Dim WMG As Object, Proc As Object
Set WMG = GetObject("winmgmts:")
For Each Proc In WMG.InstancesOf("win32_process")
If UCase(Trim(Proc.Name)) = "WINWORD.EXE" Then
*'Beginning of my code...*
*'This is what I need and have no idea how to go about*
Dim WdApp as Word.Application, WdDoc as Object
*' is it better to have WdDoc as Document?*
set WdDoc = ' ### I do not know what goes here ...
If WdDoc.Name = Doc2Send Or WdDoc.Name = Doc2SendFullName Then
*' ### ... or how to properly save and close*
WdApp.Documents(Doc2Send).Close (wdPromptToSaveChanges)
Exit For
End If
*'... end of my code*
Exit For
End If
Next 'Proc
Set WMG = Nothing
Thank you for your time and effort.
Cheers
You may like to consider controlling the number of instances of the Word application that are created. The function below, called from Excel, will return an existing instance of Word or create a new one only if none existed.
Private Function GetWord(ByRef WdApp As Word.Application) As Boolean
' 256
' return True if a new instance of Word was created
Const AppName As String = "Word.Application"
On Error Resume Next
Set WdApp = GetObject(, AppName)
If Err Then
Set WdApp = CreateObject(AppName, "")
End If
WdApp.Visible = True
GetWord = CBool(Err)
Err.Clear
End Function
The function is designed for early binding, meaning you need to add a reference to the Microsoft Word Object Library. During development it's better to work that way. You can change to late binding after your code has been fully developed and tested.
Please take note of the line WdApp.Visible = True. I added it to demonstrate that the object can be modified. A modification done within the If Err bracket would apply only to a newly created instance. Where I placed it it will apply regardless of how WdApp was created.
The next procedure demonstrates how the function might be used in your project. (You can run it as it is.)
Sub Test_GetWord()
' 256
Dim WdApp As Word.Application
Dim NewWord As Boolean
Dim MyDoc As Word.Document
NewWord = GetWord(WdApp)
If NewWord Then
Set MyDoc = WdApp.Documents.Add
MsgBox "A new instance of Word was created and" & vbCr & _
"a document added named " & MyDoc.Name
Else
MsgBox "Word is running and has " & WdApp.Documents.Count & " document open."
End If
End Sub
As you see, the variable WdApp is declared here and passed to the function. The function assigns an object to it and returns information whether that object previously existed or not. I use this info to close the instance if it was created or leave it open if the user had it open before the macro was run.
The two message boxes are for demonstration only. You can use the logical spaces they occupy to do other things. And, yes, I would prefer to assign each document in an instance I'm looking at to an object variable. While using early binding you will get the added benefit of Intellisense.
EDIT
Your procedure enumerates processes. I wasn't able to find a way to determine convert the process into an instance of the application. In other words, you can enumerate the processes and find how many instances of Word are running but I can't convert any of these instances into a particular, functioning instance of the application so as to access the documents open in it. Therefore I decided to enumerate the windows instead and work from there back to the document. The function below specifically omits documents opened invisibly.
Option Explicit
Private Declare PtrSafe Function apiGetClassName Lib "user32" Alias _
"GetClassNameA" (ByVal Hwnd As Long, _
ByVal lpClassname As String, _
ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function apiGetDesktopWindow Lib "user32" Alias _
"GetDesktopWindow" () As Long
Private Declare PtrSafe Function apiGetWindow Lib "user32" Alias _
"GetWindow" (ByVal Hwnd As Long, _
ByVal wCmd As Long) As Long
Private Declare PtrSafe Function apiGetWindowLong Lib "user32" Alias _
"GetWindowLongA" (ByVal Hwnd As Long, ByVal _
nIndex As Long) As Long
Private Declare PtrSafe Function apiGetWindowText Lib "user32" Alias _
"GetWindowTextA" (ByVal Hwnd As Long, ByVal _
lpString As String, ByVal aint As Long) As Long
Private Const mcGWCHILD = 5
Private Const mcGWHWNDNEXT = 2
Private Const mcGWLSTYLE = (-16)
Private Const mcWSVISIBLE = &H10000000
Private Const mconMAXLEN = 255
Sub ListName()
' 256
' adapted from
' https://www.extendoffice.com/documents/excel/4789-excel-vba-list-all-open-applications.html
Dim xStr As String
Dim xStrLen As Long
Dim xHandle As Long
Dim xHandleStr As String
Dim xHandleLen As Long
Dim xHandleStyle As Long
Dim WdDoc As Word.Document
Dim Sp() As String
On Error Resume Next
xHandle = apiGetWindow(apiGetDesktopWindow(), mcGWCHILD)
Do While xHandle <> 0
xStr = String$(mconMAXLEN - 1, 0)
xStrLen = apiGetWindowText(xHandle, xStr, mconMAXLEN)
If xStrLen > 0 Then
xStr = Left$(xStr, xStrLen)
xHandleStyle = apiGetWindowLong(xHandle, mcGWLSTYLE)
If xHandleStyle And mcWSVISIBLE Then
Sp = Split(xStr, "-")
If Trim(Sp(UBound(Sp))) = "Word" Then
ReDim Preserve Sp(UBound(Sp) - 1)
xStr = Trim(Join(Sp, "-"))
Set WdDoc = Word.Application.Documents(xStr)
' this applies if the document was not saved:-
If WdDoc.Name <> xStr Then Set WdDoc = GetObject(xStr)
Debug.Print xStr,
Debug.Print WdDoc.Name
End If
End If
End If
xHandle = apiGetWindow(xHandle, mcGWHWNDNEXT)
Loop
End Sub
Note that it's important to have the API functions at the top of the module - no code above them. Your question doesn't extend to what you want to do with the files but you wanted them listed, and that is accomplished.
I'm making an application in VBA and after 15 or so minutes of inactivity, the program opens a seperate userform and starts counting down from 60. After that time has expired, I wish to make windows log off so that any data won't get compromised by students or nothing gets destroyed. However; after spending nearly an hour going through forums and my textbook, I can't find a functioning, simple piece of code. Any snippets or suggestions are welcome :)
Thank you very much :)
You could just lock the workstation
Declare Function LockWorkStation Lib "user32.dll" () As Long
Public Sub LockPC()
LockWorkStation
End Sub
Update You could also logoff but be aware all applications are closed and normally nothing will be saved.
Option Explicit
Private Declare Function ExitWindowsEx Lib "User32" ( _
ByVal uFlags As Long, _
dwReserved As Long) As Long
Private Const EWX_FORCE = 4
Private Const EWX_LOGOFF = 0
Private Const EWX_REBOOT = 2
Private Const EWX_SHUTDOWN = 1
Private Const EWX_POWEROFF = 8
Sub Logoff()
Dim Retval As Long
Retval = ExitWindowsEx(EWX_LOGOFF, 0&)
If Retval = 0 Then MsgBox "Could not log off", vbOKOnly + vbInformation, "Logoff"
End Sub
Attention For a 64-bit Excel you have to adapt the api declarations, have a look here. Often you only have to add PtrSafe and replace Long with LongLong
Update 2022/08/10 API calls for 64-bit Excel
Declare PtrSafe Function LockWorkStation Lib "user32.dll" () As Long
Declare PtrSafe Function ExitWindowsEx Lib "user32" _
(ByVal uFlags As Long, ByVal dwReserved As Long) As Long
You can also use the shutdown.exe to log off. Example below
Sub LogOffComputer()
'https://learn.microsoft.com/en-us/windows-server/administration/windows-commands/shutdown
Dim oShell
Set oShell = CreateObject("Shell.Application")
oShell.ShellExecute "cmd.exe", "shutdown.exe /l /f"
Set oShell = Nothing
End Sub
This works on my 64 bit Excel:
Sub shut()
Shell "Shutdown -s -t 20", vbHide
End Sub
Although I am looking for a method to close any running apps first, since I suppose it can make the system corrupt to close apps by shutdown windows with running apps.
I have a working VBA macro which enters SAP, starts a transaction and then extracts the data in spreadsheet.
But sometimes the calculation runs too long, or I just would like to stop it to intervene. There is a functionality on the toolbar at the top left corner, where the user can "stop transaction" manually.
Is there any SAP script code for the "stop transaction" button, so I can avoid the manual step?
SAP toolbar:
It is assumed that the VBA macro is running in the first session. If a second session is opened before starting the macro, it can be used to close the first session.
for example:
Set SapGuiAuto = GetObject("SAPGUI")
Set SAPapp = SapGuiAuto.GetScriptingEngine
Set SAPconnection = SAPapp.Children(0)
Set session = SAPconnection.Children(1)
session.findById("wnd[0]/tbar[0]/okcd").text = "/i1"
session.findById("wnd[0]").sendVKey 0
session.createSession
Application.Wait (Now + TimeValue("0:00:05"))
session.findById("wnd[0]/tbar[0]/okcd").text = "/i3"
session.findById("wnd[0]").sendVKey 0
session.createSession
Application.Wait (Now + TimeValue("0:00:05"))
Whether a "rollback" is carried out or not, would be to test.
Regards,
ScriptMan
I guess you better record a script with this scenario, then you can re-use it any time.
Otherwise, I am at the very moment struggling with the same case, but with the run time counter part to leave the tcode if running too long.
It is a hart nut to crack too, but a different topic.
Update: realizing that there is no way to get the 'Stop Transaction' step recorded, I applied the above method - thank you Script Man, it was not the first time you saved the day.
For anyone reading this thread - may be useful to know how to split the SAP runtime from VBA script runtime.
I introduced an object that is the 'Execute' command itself. This way, SAP takes the command and starts execution, while the macro will step over as it is not an actual command but applying a new object only. This trick can help users to write a time counter and drop the session if running too long.
For reference, see my code here - I quoted the part of my code that contains the relevant method.
'check whether you already have an extra session open to close the long running session
'open one if needed
On Error Resume Next
Set session1 = Connection.Children(1)
If Err.Number <> 0 Then
session.CreateSession
Application.Wait (Now + TimeValue("0:00:05"))
're-set the sessions, ensuring you use the first session for actual work and keep session1 in background
Set session = Connection.Children(0)
Set session1 = Connection.Children(1)
SesCount = Connection.Sessions.Count()
Err.Clear
On Error GoTo 0
End If
'get the ID of first session, so you can enter the correct terminating transaction code when needed
sessionID = Mid(session.ID, (InStrRev(session.ID, "[") + 1), 1)
Terminator = "/i" & sessionID + 1
session.FindById("wnd[0]").Maximize
'some code comes here
'here I use an object to apply the execute button - this way parallel with the SAP runtime, the VBA script can proceed.
perec = session.FindById("wnd[0]/tbar[1]/btn[8]").press
'here we set a loop to check whether system is busy over a certain time then we may interrupt:
Do
Application.Wait (Now + TimeValue("0:00:05"))
SecondsElapsed = SecondsElapsed + 5
fityirc = session.Busy()
if fityirc = False then
exit Do
end if
Loop Until SecondsElapsed >= 100
If fityirc = True Then
session1.FindById("wnd[0]/tbar[0]/okcd").Text = Terminator
session1.FindById("wnd[0]").sendVKey 0
End If
'...and so on. This solution is applied in a loop to extract datasets massively without human interaction.
Or, have a look at code I've just written and tested to use the Windows API to run the Stop Transaction menu item. I raised a question about it on the SAP forum, but figured it out myself in the meantime (SAP Forum)
Private Declare PtrSafe Function FindWindowA Lib "user32.dll" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetSystemMenu Lib "user32" (ByVal hWnd As LongPtr, ByVal bRevert As Long) As LongPtr
Private Declare PtrSafe Function GetMenuItemCount Lib "user32" (ByVal hMenu As LongPtr) As Long
Private Declare PtrSafe Function GetMenuItemInfoA Lib "user32" (ByVal hMenu As LongPtr, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare PtrSafe Function SendMessageA Lib "user32" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Public Const MIIM_STRING As Integer = &H40
Public Const MIIM_ID = &H2
Public Const WM_COMMAND = &H111
Public Const WM_SYSCOMMAND = &H112
Public Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As LongPtr
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type
Public Function RunMenuItemByString(ByVal sMenuItem As String, _
ByVal sWindowClass As String, _
ByVal sWindowText As String, _
ByVal iCommandType As Integer) As Boolean
Dim hWnd As LongPtr, hMenu As LongPtr, lpMenuItemID As LongPtr
Dim lngMenuItemCount As Long, lngMenuItem As Long, lngResultMenuItemInfo As Long
Dim typMI As MENUITEMINFO
Dim s As String
Dim blnRet As Boolean
hWnd = FindWindowA(sWindowClass, sWindowText)
hMenu = GetSystemMenu(hWnd, 0&)
lngMenuItemCount = GetMenuItemCount(hMenu)
For lngMenuItem = 0 To lngMenuItemCount - 1
typMI.cbSize = Len(typMI)
typMI.dwTypeData = String$(255, " ")
typMI.cch = Len(typMI.dwTypeData)
typMI.fMask = MIIM_STRING Or MIIM_ID
lngResultMenuItemInfo = GetMenuItemInfoA(hMenu, lngMenuItem, 1, typMI)
s = Trim$(typMI.dwTypeData)
lpMenuItemID = typMI.wID
If InStr(1, s, sMenuItem, vbTextCompare) > 0 Then
blnRet = SendMessageA(hWnd, iCommandType, lpMenuItemID, 0&) = 0
Exit For
End If
Next lngMenuItem
RunMenuItemByString = blnRet
End Function
Public Function TestRunMenuItemByString()
lpHwndSAPSession = oSAPSession.FindById("wnd[0]").Handle
sWindowText = GetWindowText(lpHwndSAPSession)
TestRunMenuItemByString = RunMenuItemByString("Stop Transaction", "SAP_FRONTEND_SESSION", sWindowText, WM_SYSCOMMAND)
End Function
The TestRunMenuItemByString function can be used only after a session is started, and will only work if there is actually a transaction executing. You will need to figure out how to reference your sap session object (oSAPSession) in order to use the Handle value from it.
The declarations should work in both 32 bit and 64 bit versions of VBA and the LongPtr has been used for the handle (h) and pointer (lp) variables to reflect this.
This was tested in Microsoft Access, but I see no reason why it shouldn't work in VBA in other Office applications. I can't vouch for it being adaptable for VBScript.
Below is a working code snippet that opens a Microsoft Word document, and goes to a specific index from the Table of Contents. filePath is a filepath, and strTopic is a value that links to the Table of Contents in the Word document.
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set docWord = objWord.Documents.Open(fileName:=strPath, ReadOnly:=True)
docWord.Bookmarks(strTopic).Range.Select
I need to bring the Word document to the foreground.
Is there a toFront() type "function" in VBA?
You can achieve what you want using APIS. I am using two APIs SetForegroundWindow and FindWindow
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) _
As Long
Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) _
As Long
Sub Sample()
Dim objWord As Object, docWord As Object
Dim strPath As String, FileName As String
Dim hwnd As Long
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
'~~> Change this to the relevant Filename and path
strPath = "C:\Users\Siddharth Rout\Desktop\Sample.docx"
'~~> Put the acutal file name here without the extension
FileName = "Sample"
Set docWord = objWord.Documents.Open(FileName:=strPath, ReadOnly:=True)
hwnd = FindWindow(vbNullString, FileName & " [Read-Only] - Microsoft Word")
If hwnd > 0 Then
SetForegroundWindow (hwnd)
End If
End Sub
NOTE: If you are sure that there is no other Word Application open other than what you opened then you can use this as well :)
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Sub Sample()
Dim objWord As Object, docWord As Object
Dim strPath As String
Dim hwnd As Long
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
'~~> Change this to the relevant Filename and path
strPath = "C:\Users\Siddharth Rout\Desktop\Sample.docx"
Set docWord = objWord.Documents.Open(FileName:=strPath, ReadOnly:=True)
hwnd = FindWindow("OpusApp", vbNullString)
If hwnd > 0 Then
SetForegroundWindow (hwnd)
End If
End Sub
How about,
docWord.Activate
This should bring the file that has been "Set" for the docWord object to foreground.
EDIT: Tested this on Access, quiet unreliable on Excel. Using an API is the best way to go if there are multiple instances of the Word application running.
Once you've opened a document (or added one) you can get a Hwnd to pass to the SetForegroundWindow API function from the ActiveWindow object (e.g. obWord.ActivieWindow.Hwnd). That way you don't need to search for the correct Word instance to bring to front.
This seems to work every time. Word running or not, multiple docs open or not.
OpenAlready:
On Error GoTo 0
With wrdApp
.Selection.Goto What:=1, Which:=2, Name:=PageNumber
.Visible = True
.Activate '<---seems to work well. regardless of number of Word docs open OR not open.
End With
Set wrdDoc = Nothing
Set wrdApp = Nothing
i'm quite new here, and in doing a ~30 min research on this specific case, I think I could bring something to the table here...
I found in this link: http://www.vbaexpress.com/forum/showthread.php?27589-bringing-Word-in-fornt-of-Excel this line of code:
Application.ActivateMicrosoftApp xlMicrosoftWord
It will force Word in front of everything, BUT if there is something opened it will create a new document, so what I found is that, if you want to open something and then bring it to front you use this sintax:
[...]
Application.ActivateMicrosoftApp xlMicrosoftWord
Word.Documents.Open(MyDocument)
[...]
Once in vba debugging the code will always be in front, but when using the code with the excel vba userform it works great! I can see the word changing the words on the fly!!!!
Can also use AppActivate "Microsoft Word"
visit Microsoft help :here
Using AppActivate needs the exact title of the window you want focused. E.g. for a word 2013 template opened as an "add", you would have to use AppActivate "Document1 - Word"
I just use;
FileAndPath = "C:\temp\Mydocument.docx"
ThisWorkbook.FollowHyperlink (FileAndPath)
It even works if the file is already open.
Since ".Activate" is comented various times but at least for me calling it from excel to bring to fornt a word doc.
I have to do a work around minimizing and maximazing the window.
This works well for me until now:
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
wdApp.ScreenUpdating = True
Set wdDoc = wdApp.Documents.Open(ThisWorkbook.Path & "\" & stWordDocument) 'update your path
wdDoc.Activate
ActiveDocument.ActiveWindow _
.WindowState = wdWindowStateMinimize
ActiveDocument.ActiveWindow _
.WindowState = wdWindowStateMaximize
found!
ActiveDocument.Activate 'might not be necessary
ActiveDocument.Windows.Application.WindowState = wdWindowStateMaximize
works flawlessly. I already had an "activedocument" I was working on.
http://www.access-programmers.co.uk/forums/showthread.php?t=173871
I have a vb6 multithreaded app working and i would like to use mutexes to protect data. The expected behavior is that when a thread tried to obtain a lock on an existing mutex, when the "WaitForSingleObject" function is called, that thread blocks until the mutex is signaled. What I am experiencing is the entire app freezes.
To duplicate my project, open VB6 and create a new Active X EXE. Create a module with default name. Place this code in it:
Option Explicit
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Sub Main()
' this hack is necessary to ensure that we only 'create' the application window once..
Dim hwnd As Long
hwnd = FindWindow(vbNullString, "Form1")
If hwnd = 0 Then
Dim f As Form1
Set f = New Form1
f.Show
Set f = Nothing
End If
End Sub
Next create a class, with default name and add this code to it:
Option Explicit
Private Const INFINITE = -1&
Private Const STANDARD_RIGHTS_REQUIRED As Long = &HF0000
Private Const SYNCHRONIZE As Long = &H100000
Private Const MUTANT_QUERY_STATE As Long = &H1
Private Const MUTANT_ALL_ACCESS As Long = (STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or MUTANT_QUERY_STATE)
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" (lpMutexAttributes As Any, ByVal bInitialOwner As Long, ByVal lpName As String) As Long
Private Declare Function OpenMutex Lib "kernel32" Alias "OpenMutexA" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal lpName As String) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function ReleaseMutex Lib "kernel32" (ByVal hMutex As Long) As Long
Private Const MUTEX_NAME As String = "mymutex"
Private m_hCurrentMutex As Long
Public Sub Class_Terminate()
Call ReleaseIt
End Sub
Public Sub LockIt(success As String)
Dim hMutex As Long
MsgBox "Lockit t:" & App.ThreadID
hMutex = OpenMutex(STANDARD_RIGHTS_REQUIRED, 0, MUTEX_NAME)
If hMutex <> 0 Then
Form1.Caption = "waiting on mutex"
MsgBox "waiting t:" & App.ThreadID
Dim res As Long
Do
'MsgWaitForMultipleObjects
res = WaitForSingleObject(hMutex, INFINITE)
DoEvents
Loop While res = -1
m_hCurrentMutex = hMutex
Else
Form1.Caption = "creating mutex"
m_hCurrentMutex = CreateMutex(ByVal 0&, 1, MUTEX_NAME)
End If
Form1.Caption = success
MsgBox success
End Sub
Public Sub ReleaseIt()
If m_hCurrentMutex <> 0 Then
Call ReleaseMutex(m_hCurrentMutex)
Call CloseHandle(m_hCurrentMutex)
m_hCurrentMutex = 0
End If
End Sub
Finally, in the main form, add 4 command buttons and this code:
Option Explicit
Dim c(1) As Class1
'Lock
Private Sub Command1_Click()
If c(0) Is Nothing Then Set c(0) = CreateObject("Project1.Class1")
Call c(0).LockIt("Object0")
End Sub
Private Sub Command2_Click()
If c(1) Is Nothing Then Set c(1) = CreateObject("Project1.Class1")
Call c(1).LockIt("Object1")
End Sub
'Free
Private Sub Command3_Click()
If c(0) Is Nothing Then Set c(0) = CreateObject("Project1.Class1")
Call c(0).ReleaseIt
End Sub
Private Sub Command4_Click()
If c(1) Is Nothing Then Set c(1) = CreateObject("Project1.Class1")
Call c(1).ReleaseIt
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set c(0) = Nothing
Set c(1) = Nothing
End
End Sub
The first two command buttons lock their respective mutexes. The 2nd two free it. Notice how before the mutex is locked, a unique thread id is displayed. This made me believe only that thread should block, and not freeze the entire application.
Any assistance would be greatly appreciated. Thank you.
EDIT: I forgot to mention a very important part: In the project properties section, I have it set to create 'thread per object' and this is verified with results of the msghox App.ThreadID calls.
While you can make a class create another thread (Using the ActiveX EXE hack) that you still have a single execution thread, i.e. all calls are serialised.
If you want an asynchronous call cross thread, you need to set a timer (SetTimer() API) in that function and wait for the callback before doing the long running code. Also note that while that thread is locked you can not make ANY calls into it unless they can break and call DoEvents.
In order to avoid the locking of the app you should have somewhere in your application at least on call to CreateThread.
The problem is that all the code you have is executed on a single thread, the main app thread. So when you click the button the main thread will block in WaitForSingleObject until the mutex is released. Because the main thread is blocked, the UI of the application freezes (the message loop is blocked), so you are not able to click the other button in order to release the mutex.
EDIT: Even if every object has its own thread, it seems the calls to class methods are synchronized. This means that the calling thread (in your case the UI thread) will wait until the LockIt method ends, even if the code in LockIt method executes in another thread. You can easily check this by putting an MessageBox at the end of Command1_Click and Command2_Click. These message boxes will appear only after all the message boxes from LockIt are displayed, not immediately after you call the LockIt method. (I think it's better to replace the MessageBox with some kind of log messages saved to a file). As a conclusion it seems that you get the synchronization of threads as a default behavior, so probably you don't need to use mutexes.