I have been struggling to identify the cause of an error in a PPT Add-in that is distributed across about 40 end users.
Problem: loss of the ribbon state/loss of the ribbonUI object.
For some users, eventually the Rib object becomes Nothing.
Users assure me they are not getting any run-time errors nor script errors (from COM object that we also invoke through this add-in). An unhandled error, if user hits End would expectedly cause the state loss.
None of the users have been able to reliably reproduce the scenario which causes the observed failure. This is what makes it very difficult to troubleshoot. I am hoping against hope that there is something obvious that I'm missing, or that I didn't anticipate.
How I currently handle loss or RibbonUI
In attempt to combat this, I store the object pointer to the ribbon in THREE places, this seems like overkill to me but it is still apparently not sufficient:
A class object called cbRibbon has a property .RibbonUI which is assigned; Set cbRibbon.RibbonUI = Rib during the ribbon's onLoad callback procedure. So we have a byRef copy of the object itself. If the ribbon is nothing, theoretically I can Set rib = cbRibbon.RibbonUI and this works unless cbRibbon object is also out of scope.
The cbRibbon object has property .Pointer which is assigned: cbRibbon.Pointer = ObjPtr(Rib).
A CustomDocumentProperty called "RibbonPointer" is also used to store a reference to the object pointer. (Note: This persists even beyond state loss)
So you can see I've given some thought to this in attempt to replicate the way of storing this pointer the way one might store it in a hidden worksheet/range in Excel.
Additional information
I can see from robust client-side logging that this the error appears to happen usually but not always during the procedure below, which is used to refresh/invalidate the ribbon and its controls.
This procedure is called any time I need to dynamically refresh the ribbon or part of its controls:
Call RefreshRibbon(id)
The error appears to (sometimes, I can't stress this enough: the error cannot be replicated on-demand) happen during a full refresh, which is called like:
Call RefreshRibbon("")
This is the procedure that does the invalidation:
Sub RefreshRibbon(id As String)
If Rib Is Nothing Then
If RibbonError(id) Then GoTo ErrorExit
End If
Select Case id
Case vbNullString, "", "RibbonUI"
Call Logger.LogEvent("RefreshRibbon: Rib.Invalidate", Array("RibbonUI", _
"Ribbon:" & CStr(Not Rib Is Nothing), _
"Pointer:" & ObjPtr(Rib)))
Rib.Invalidate
Case Else
Call Logger.LogEvent("RefreshRibbon: Rib.InvalidateControl", Array(id, _
"Ribbon:" & CStr(Not Rib Is Nothing), _
"Pointer:" & ObjPtr(Rib)))
Rib.InvalidateControl id
End Select
Exit Sub
ErrorExit:
End Sub
As you can see, the very first thing I do in this procedure is test the Rib object for Nothing-ness. If this evaluates to True, then the RibbonUI object has somehow been lost.
The error function then attempts to re-instantiate the ribbon: first from cbRibbon.RibbonUI, then from the cbRibbon.Pointer and if both of those fails, then from the CustomDocumentProperties("RibbonPointer") value. If neither of these succeeds, then we display a fatal error and the user is prompted to close the PowerPoint application. If any one of these succeeds, then the ribbon is reloaded programmatically and everything continues to work.
Here is the code for that procedure. Note that it calls several other procedures which I have not included code for. These are helper functions or logger functions. The .GetPointer method actually invokes the WinAPI CopyMemory function to reload the object from its pointer value.
Function RibbonError(id As String) As Boolean
'Checks for state loss of the ribbon
Dim ret As Boolean
If id = vbNullString Then id = "RibbonUI"
Call Logger.LogEvent("RibbonError", Array("Checking for Error with Ribbon" & vbCrLf & _
"id: " & id, _
"Pointer: " & ObjPtr(Rib), _
"cbPointer: " & cbRibbon.Pointer))
If Not Rib Is Nothing Then
GoTo EarlyExit
End If
On Error Resume Next
'Attempt to restore from class object:
Set Rib = cbRibbon.ribbonUI
'Attempt to restore from Pointer reference if that fails:
If Rib Is Nothing Then
'Call Logger.LogEvent("Attempt to Restore from cbRibbon", Array(cbRibbon.Pointer))
If Not CLng(cbRibbon.Pointer) = 0 Then
Set Rib = cbRibbon.GetRibbon(cbRibbon.Pointer)
End If
End If
'Attempt to restore from CDP
If Rib Is Nothing Then
'Call Logger.LogEvent("Attempt to Restore from CDP", Array(MyDoc.CustomDocumentProperties("RibbonPointer")))
If HasCustomProperty("RibbonPointer") Then
cbRibbon.Pointer = CLng(MyDoc.CustomDocumentProperties("RibbonPointer"))
Set Rib = cbRibbon.GetRibbon(cbRibbon.Pointer)
End If
End If
On Error GoTo 0
If Rib Is Nothing Then
Debug.Print "Pointer value was: " & cbRibbon.Pointer
'Since we can't restore from an invalid pointer, erase this in the CDP
' a value of "0" will set Rib = Nothing, anything else will crash the appliation
Call SetCustomProperty("RibbonPointer", "0")
Else
'Reload the restored ribbon:
Call RibbonOnLoad(Rib)
Call SetCustomProperty("RibbonPointer", ObjPtr(Rib))
cbRibbon.Pointer = ObjPtr(Rib)
End If
'Make sure the ribbon exists or was able to be restored
ret = (Rib Is Nothing)
If ret Then
'Inform the user
MsgBox "A fatal error has been encountered. Please save & restart the presentation", vbCritical, Application.Name
'Log the event to file
Call Logger.LogEvent("RibbonError", Array("FATAL ERROR"))
Call ReleaseTrap
End If
EarlyExit:
RibbonError = ret
End Function
All of this works perfectly well in theory and in fact I can straight-up kill run-time (by invoking the End statement or otherwise) and these procedures reset the ribbon as expected.
So, what am I missing?
OK I forgot about this... while I still have not pinpointed the error I have some ideas that users are simply not reporting unhandled runtime errors and instead they're hitting "End" when prompted by PowerPoint.
I'm reasonably certain that is the cause and I have confirmation that in many cases, that sort of error precedes the "crash", so I'm updating to resolve that soon.
Otherwise, here is the method I ultimately have been using for several months, with success.
Create a procedure that writes the Pointer value of the ribbon on the user's machine. I didn't want to do this, but ultimately had to:
Sub LogRibbon(pointer As Long)
'Writes the ribbon pointer to a text file
Dim filename As String
Dim FF As Integer
filename = "C:\users\" & Environ("username") & "\AppData\Roaming\Microsoft\AddIns\pointer.txt"
FF = FreeFile
Open filename For Output As FF
Print #FF, pointer
Close FF
End Sub
In the ribbon's _OnLoad event handler, I call the LogRibbon procedure:
Public Rib As IRibbonUI
Public cbRibbon As New cRibbonProperties
Sub RibbonOnLoad(ribbon As IRibbonUI)
'Callback for customUI.onLoad
Set Rib = ribbon
Call LogRibbon(ObjPtr(Rib))
'Store the properties so we can easily access them later
cbRibbon.ribbonUI = Rib
End Sub
I created a class object to store some information about the ribbon to avoid repeated and slow calls to an external API, but for this purpose you can create a class that stores just the pointer value. That is referenced above in the cbRibbon.ribbonUI = Rib. This GetRibbon method of this class uses the CopyMemory function from WinAPI to restore the object from it's pointer.
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (destination As Any, source As Any, _
ByVal length As Long)
'example ported from Excel:
'http://www.excelguru.ca/blog/2006/11/29/modifying-the-ribbon-part-6/
Private pControls As Object
Private pRibbonUI As IRibbonUI
Private pPointer As Long
Sub Class_Initialize()
'Elsewhere I add some controls to this dictionary so taht I can invoke their event procedures programmatically:
Set pControls = CreateObject("Scripting.Dictionary")
Set pRibbonUI = Rib
Call SaveRibbonPointer(Rib)
pConnected = False
End Sub
'#############################################################
'hold a reference to the ribbon itself
Public Property Let ribbonUI(iRib As IRibbonUI)
'Set RibbonUI to property for later use
Set pRibbonUI = iRib
End Property
Public Property Get ribbonUI() As IRibbonUI
'Retrieve RibbonUI from property for use
Set ribbonUI = pRibbonUI
End Property
'http://www.mrexcel.com/forum/excel-questions/518629-how-preserve-regain-id-my-custom-ribbon-ui.html
Public Sub SaveRibbonPointer(ribbon As IRibbonUI)
Dim lngRibPtr As Long
' Store the custom ribbon UI Id in a static variable.
' This is done once during load of UI.
lngRibPtr = ObjPtr(ribbon)
cbRibbon.pointer = lngRibPtr
End Sub
Function GetRibbon(lngRibPtr As Long) As Object
'Uses CopyMemory function to re-load a ribbon that
' has been inadvertently lost due to run-time error/etc.
Dim filename As String
Dim ret As Long
Dim objRibbon As Object
filename = "C:\users\" & Environ("username") & "\AppData\Roaming\Microsoft\AddIns\pointer.txt"
On Error Resume Next
With CreateObject("Scripting.FileSystemObject").GetFile(filename)
ret = .OpenAsTextStream.ReadLine
End With
On Error GoTo 0
If lngRibPtr = 0 Then
lngRibPtr = ret
End If
CopyMemory objRibbon, lngRibPtr, 4
Set GetRibbon = objRibbon
' clean up invalid object
CopyMemory objRibbon, 0&, 4
Set objRibbon = Nothing
End Function
'##############################################################
' Store the pointer reference to the RibbonUI
Public Property Let pointer(p As Long)
pPointer = p
End Property
Public Property Get pointer() As Long
pointer = pPointer
End Property
'#############################################################
'Dictionary of control properties for Dropdowns/ComboBox
Public Property Let properties(p As Object)
Set pProperties = p
End Property
Public Property Get properties() As Object
Set properties = pProperties
End Property
Then, I have a function which checks for loss of ribbon, and restores from the pointer value. This one actually invokes the OnLoad procedure, which we can do since we have an object variable (or class object property) representing the Ribbon object).
Function RibbonError(id As String) As Boolean
'Checks for state loss of the ribbon
Dim ret As Boolean
Dim ptr As Long
Dim src As String
On Error Resume Next
If Not Rib Is Nothing Then
GoTo EarlyExit
End If
If Rib is Nothing then
ptr = GetPointerFile
cbRibbon.pointer = ptr
Set Rib = cbRibbon.GetRibbon(ptr)
End If
On Error GoTo 0
'make sure the ribbon has been restored or exists:
ret = (Rib is Nothing)
If Not ret then
'Reload the restored ribbon by invoking the OnLoad procedure
' we can only do this because we have a handle on the Ribbon object now
Call RibbonOnLoad(Rib)
cbRibbon.pointer = ObjPtr(Rib) 'store the new pointer
Else
MsgBox "A fatal error has been encountered.", vbCritical
End If
EarlyExit:
RibbonError = ret
End Function
Call on the RibbonError function any time you are going to refresh the ribbon through either Invalidate or InvalidateControl methods.
The code above may not 100% compile -- I had to modify it and trim some stuff out, so let me know if you have any problems trying to implement it!
Found the real solution: Credit
Public Declare Sub CopyMemory Lib "kernel32" Alias _
"RtlMoveMemory" (destination As Any, source As Any, _
ByVal length As Long)
Public Sub ribbon L o a ded(ribbon As IRibbonUI)
' Store pointer to IRibbonUI
Dim lngRibPtr As Long
' Store the custom ribbon UI Id in a static variable.
' This is done once during load of UI. I.e. during workbook open.
Set guiRibbon = ribbon
lngRibPtr = ObjPtr(ribbon)
' Write pointer to worksheet for safe keeping
Tabelle2.Range("A1").Value = lngRibPtr
End Sub
Function GetRibbon(lngRibPtr as Long) As Object
Dim objRibbon As Object
CopyMemory objRibbon, lngRibPtr, 4
Set GetRibbon = objRibbon
' clean up invalid object
CopyMemory objRibbon, 0&, 4
Set objRibbon = Nothing
End Function
Then
Public Sub DoButton(ByVal control As IRibbonControl)
' The onAction callback for btn1 and btn2
' Toggle state
Toggle12 = Not Toggle12
' Invalidate the ribbon UI so that the enabled-states get reloaded
If Not (guiRibbon Is Nothing) Then
' Invalidate will force the UI to reload and thereby ask for their enabled-states
guiRibbon.Invalidate 'Control ("tabCustom") InvalidateControl does not work reliably
Else
Set guiRibbon = GetRibbon(CLng(Tabelle2.Range("A1").Value))
guiRibbon.Invalidate
' The static guiRibbon-variable was meanwhile lost
' MsgBox "Due to a design flaw in the architecture of the MS ribbon UI you have to close " & _
' "and reopen this workbook." & vbNewLine & vbNewLine & _
' "Very sorry about that.", vbExclamation + vbOKOnly
MsgBox "Hopefully this is sorted now?"
' Note: In the help we can find
' guiRibbon.Refresh
' but unfortunately this is not implemented.
' It is exactly what we should have instead of that brute force reload mechanism.
End If
End Sub
Related
I would like to repeat Creating Object until it gets created (opened).
In my case the problem looks like this. Application is opened via COM and access is controlled via licensing service. While all licenses are in use, you eventually will get an error as shown in attached image. But when free license will appear, you will be able to launch the application.
Dim ApplicationName As Object
Set ApplicationName = CreateObject("AppNameToLaunchViaCOM")
Is there any way to do it? And maybe inform the user how many times it failed to open etc.
Server Execution Failed window
You could try the following approach
Option Explicit
Public Declare PtrSafe Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As LongPtr)
Function getObj() As Object
On Error GoTo EH
Dim ApplicationName As Object
Set ApplicationName = CreateObject("AppNameToLaunchViaCOM")
Set getObj = ApplicationName
Exit Function
EH:
End Function
Sub TryOut()
Const MAX = 10
Dim i As Long
Dim myObj As Object
Do
Set myObj = getObj
If Not myObj Is Nothing Then
Exit Do
End If
' Code to wait
Sleep 1000
' exit loop in case more than max tries
i = i + 1
Loop Until i > MAX
If myObj Is Nothing Then
Debug.Print "No license"
' furher code
Else
Debug.Print "Tries", i
' furher code
End If
End Sub
So I have some macros run inside an Excel document and wanted to know if there is a way to frequently output text to a Console window (Basicly using it like the immediate window).
I know there are multiple ways of writing text to files, I just want to display some info on the running process without using the immediate window or other windows inside Excel itself.
Using this helps me to display a single line, but I dont want to open a new window for every line:
Call Shell("cmd.exe /K echo testInfo", vbNormalFocus)
I do NOT want to run a command (except echo maybe?) to execute a task, its just supposed to display text.
Thank you in advance for any advice.
EDIT:
As an addition to #JohnRC 's post I found a solution without external applications:
Call Shell("PowerShell.exe -noexit -command get-content " + strPath + " -wait")
Logging information to a textfile at the location after running the command above does the trick.
OK, as I got a couple of downvotes on my earlier answer, I thought I should attempt to provide an actual answer to the request, namely to provide a way of sending log messages to a command prompt window. Here goes...
This solution is implemented as a VBA class that will send messages as comment lines to a separately-running command prompt window that has the text "ExcelLog" in the title. This command prompt must be started separately. The easiest way to do this is to create a shortcut named "ExcelLog" to just run CMD, then when this shortcut is opened the command prompt window will have "ExcelLog" in the title.
Inside the spreadsheet add the code for the class cConsole (below), and then in your VBA code create a global instance of the class and use the method .W "message" to send a text message to the console as a comment line (in this case using the prefix :: to the line to identify it as a comment).
The cConsole class looks for any command prompt window with the requisite title, then sends the comment message to that window. If the window cannot be found, it simply skips the action so the Excel VBA code continues to execute without reporting an error. Also if you open the command prompt window after Excel VBA has started running, cConsole will automatically connect to the window and start/resume sending messages. This means you can close and reopen the command prompt ExcelLog window any time without interrupting the execution of the VBA code.
This seems to work on my setup OK. I think it is a bit more trouble than simply tailing a text file, but - hey, you pays your money and takes your choice.
Here is the code of the cConsole class.
Option Explicit
'// cConsole class
'// This class wraps an interface to a separately-started command prompt
'// window to which messages are sent as comments, so that the command prompt
'// window can be used as a real-time scrolling log from Excel.
'// Each instance of this class creates its own connection to the
'// command prompt window which must have a title containing the text
'// "ExcelLog". If such a window is not open then messages are not
'// logged. The command prompt window can be opened after messages
'// have started, and it will be connected when the next message is
'// sent.
'// The simplest way to set up the necessary command prompt window is to
'// create a shortcut on the desktop the name "ExcelLog" which runs CMD
'// Usage - - - - - - - - - - - -
'//
'// Dim oConsole As New cConsole
'// :
'// oConsole.W "Message to be written to the console"
'//
'// Windows functions to get window handles etc
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 GetClassName Lib "user32" Alias "GetClassNameA" _
(ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
(ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As Long) As Long
'// Handle of the excel log window
Private hLogWindow As Long
Private Sub Class_Initialize()
'// On instantiation, attempts to find the ExcelLog window
findExcelLogWindow
End Sub
Public Sub W(sMsg As String)
'// Public function used to send the given message
'// as a comment line to the linked window
SendToConsole ":: " & sMsg
End Sub
Private Sub SendToConsole(Command As String)
'// Connects to and sends a command line to the command prompt
'// window that is being used as the log
Dim res As Boolean
'// Check that a connection has been made and
'// attempt to connect if not
If hLogWindow = 0 Then
findExcelLogWindow
If hLogWindow = 0 Then Exit Sub
End If
On Error Resume Next
Do
'// Attempt to bring the logging window to the foreground
res = SetForegroundWindow(hLogWindow)
'// Check if successful, and send the command if so
If res Then
SendKeys Command & vbCrLf
Exit Do
Else
'// Not successful, so try reconnecting to the logging window
findExcelLogWindow
'// If we cannot connect, just exit without sending anything
If hLogWindow = 0 Then Exit Sub
End If
Loop
'// Check if there has been any error
If Err.Number <> 0 Then
hLogWindow = 0
MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
End If
On Error GoTo 0
End Sub
Private Function findExcelLogWindow() As Long
'// This function looks for a command prompt window that has the text
'// ExcelLog in the title
Dim nLen As Long
Dim sData As String
Dim Class As String
Dim Title As String
'// Get handle to the first window
hLogWindow = 0
'// Check each window in turn
Do
hLogWindow = FindWindowEx(0&, hLogWindow, vbNullString, vbNullString)
'// Check that a window was found
If hLogWindow = 0 Then Exit Do
'// Get the class name of the window
sData = String$(100, Chr$(0))
nLen = GetClassName(hLogWindow, sData, 100)
Class = Left$(sData, nLen)
'// Get the title of the window
sData = String$(100, Chr$(0))
nLen = GetWindowText(hLogWindow, sData, 100)
Title = Left$(sData, nLen)
'// Check if the required window has been found
If Class = "ConsoleWindowClass" And InStr(Title, "ExcelLog") > 0 Then
'// Initialise the window to remove any prompt text
SendToConsole "PROMPT $S"
'// Write some initial messages
Me.W "*******************"
Me.W "[" & ThisWorkbook.Name & "] connected to console at " & Now
Me.W ""
'// Return the handle to the log window
findExcelLogWindow = hLogWindow
Exit Function
End If
Loop
'// The log window was not found, so return zero
findExcelLogWindow = 0
End Function
I tested this out by handling MouseMove events on an image control in a worksheet:
Option Explicit
Private oCons As New cConsole
Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
oCons.W "MouseMove " & X & ", " & Y
End Sub
And here is the result
Instead of using a shell to act as a console to log messages, I have used a text file to hold the log, and monitored the output to the file with a tail utility (I have used WinTail from http://www.baremetalsoft.com/wintail/ but I am sure there are others). This is the code, which I put in a separate vba module named Log. Then call Log.W "Message" to log a message.
Option Explicit
'// You need a reference to "Microsoft Scripting Runtime" library in VBA
Private oLog As Scripting.TextStream
Private bErr As Boolean
Private Sub INIT()
'// Initialise the output log file
'// Check if log file is already open, or there has been an error
If bErr Then Exit Sub
If Not oLog Is Nothing Then Exit Sub
'// Open the log file for appending
Dim ofso As New Scripting.FileSystemObject
On Error Resume Next
Set oLog = ofso.OpenTextFile("excel.log", ForAppending, True)
'// Check that open was successful
If Err.Number <> 0 Then
MsgBox "Log file error: " & Err.Number & ": " & Err.Description
bErr = True
Exit Sub
End If
On Error GoTo 0
'// Write a starting block to the log
oLog.WriteLine "*"
W "********************************** START"
W "* Start of log " & Format(Date, "YYYY-MM-dd")
W ""
End Sub
Public Sub W(sMsg)
'// Writes a single line message to the log
'// Initialize if required
INIT
'// Check for log file error
If bErr Then Exit Sub
'// Create the log line and write to log file
Dim st As String
st = Format(Now, "hh:mm:ss ")
oLog.WriteLine st & sMsg
End Sub
Public Function ReportErr(Optional Loc As Variant = "") As Boolean
'// Reports information from the Err object, if an error has occured
'// Check if error has occurred, exit if not
If Err.Number = 0 Then ReportErr = False: Exit Function
'// Set return value
ReportErr = True
'// Initialize if required
INIT
'// Check for log file error
If bErr Then Exit Function
'// Write the error block to the log
W "*********** ERROR ******* " & IIf(Len(Loc) > 0, "[" & Loc & "]", "")
W "* Error #" & Err.Number
If Len(Err.Description) > 0 Then
W "* : " & Err.Description
W "*************************"
End If
End Function
Tailing the log file with WinTail means that output to the log appears immediately it is written, so you can monitor the log as the program is running.
I am trying to prompt the user when he tries to close a workbook like this
Private Sub Workbook_BeforeClose(Cancel as Boolean)
MsgBox "Changes has been detected. Do you want to export the data ?"
End Sub
I know that this code need to be placed in ThisWorkbook module.
Is there a way to do that from my custom module ? I need to add this functionality to multiple workbooks used by my client as a part of up-gradation, which is usually done by replacing old modules with new modules.
You can use the Application.VBE object and Workbook.VBProject to modify a file's VBA. Note however that it requires that the Excel performing the upgrade has to have the setting "Trust access to the VBA project" toggled on (it can be found in the Trust center under the tab Macro settings). When not needed anymore, it's an option best left off though for security reasons.
There is a way how you can Import the ThisWorkbook Module. I wrote some Code for that a long Time ago.
So how does it work.
First you have to Export the ThisWorkbook Module. Right click on the Module and Export.
Save the ThisWorkbook.cls on the Server where you have your other Module's or send it with the Modules (Like how you do the Upgrade of the other Modules)
Open the ThisWorkbook.cls File with a Editor (Like Notepad++)
And Delete The First Rows. They Look like This.
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Execute the UpdateThisDocument Subrutine.
The Only Question how have to answer yourself is how you will Execute The Code ^^ (I wrote en Extern Updater that Executed the Code)
Sub UpdateThisDocument()
Dim ModuleName As String
ModuleName = "DieseArbeitsmappe"
Dim aDoc As Workbook
Set aDoc = ThisWorkbook
Dim strPath As String
'Put here the Path to the Folder where the cls File of This Workbook is.
strPath = "C:\Users\z002mkvy\Desktop\"
With aDoc
If ModuleExists(ModuleName) = True Then
Call clsLoeschen
End If
'
With ThisWorkbook.VBProject
.VBComponents(ModuleName).CodeModule.AddFromFile _
strPath & "\DieseArbeitsmappe.cls"
Fehler:
End With
End With
End Sub
Private Function ModuleExists(ModuleName As String) _
As Boolean
On Error Resume Next
ModuleExists = Len(ThisWorkbook.VBProject _
.VBComponents(ModuleName).Name) <> 0
End Function
Private Sub clsLoeschen()
Dim modcls
Dim awcl As Integer
On Error Resume Next
Set modcls = ThisWorkbook.VBProject.VBComponents.Item("DieseArbeitsmappe")
awcl = modcls.CodeModule.CountOfLines
modcls.CodeModule.DeleteLines 1, awcl
Set modcls = Nothing
End Sub
I hope This can Help you
I have a set of macros defined in my workbook, and I'd like to offer the user the option to log events related to those macros in a log file.
I initiate the log by creating the following in ThisWorkbook:
Public writeLog as Boolean
Public logWrite as Object
Public log as Object
Private Sub Worksheet_Open()
Dim prompt as Integer
prompt = MsgBox("Would you like to log events for this session?", vbYesNo, "Log Events?")
If prompt Then
writeLog = True
Set logWrite = CreateObject("Scripting.FileSystemObject")
Set log = logWrite.CreateTextFile("C:/TEST.txt", False)
Else
writeLog = False
End If
End Sub
I then created a procedure that I can use to write an argument to this object, which I've stored in its own module:
Public Sub PrintLog(obj as Object, argument as String)
If writeLog = True Then
obj.WriteLine argument
End If
End Sub
Unfortunately, this doesn't work, and I'm not sure why: even if I don't include obj as an argument to the function (since log and logWrite were created as global variables), I'm not able to Call WriteLog("String here.") or Call WriteLog(log, "String here.") without an error (Compile Error: Argument Not Optional.)
Is it possible to get such a Sub() to work, so that I can call it from anywhere in the workbook (after a button is pressed in a userform, for example) without having to define a new Scripting.FileSystemObject in every module?
I think that you can solve your problem by making some minor changes to your code. I tried the following setup:
logger module:
Option Explicit
Private log As Object
Public Sub initLog()
Dim prompt As VbMsgBoxResult
Dim fso As Object
prompt = MsgBox("Would you like to log events for this session?", vbYesNo, "Log Events?")
If prompt = vbYes Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set log = fso.CreateTextFile("C:/TEST.txt", False)
End If
End Sub
Public Sub PrintLog(argument As String)
If Not log Is Nothing Then
log.WriteLine argument
End If
End Sub
Public Sub yadda()
'test
PrintLog "yadda"
End Sub
ThisWorkbook:
Private Sub Workbook_Open()
initLog
End Sub
This is my no-frills drop in replacement for Debug.Print(), that logs to "Log.txt" at your Workbook path.
To install : Just search and replace "Debug.Print" with "Log", and optionally call LogClear() at the start of your program.
Public Function Log(ByRef a_stringLogThis As String)
' send to TTY
Debug.Print (a_stringLogThis)
' append (not write) to disk
Open ThisWorkbook.path & "\Log.txt" For Append As #1
Print #1, a_stringLogThis
Close #1
End Function
OPTIONAL : And here's a helper you COULD call at the beginning of your to clear out the previous logs.
Public Function LogClear()
Debug.Print ("Erasing the previous logs.")
Open ThisWorkbook.path & "\Log.txt" For Output As #1
Print #1, ""
Close #1
End Function
OPTIONAL : Finally, if can't live without date and time in your logging, use this Log statement instead:
Public Function Log(ByRef a_stringLogThis As String)
' prepare date
l_stringDateTimeNow = Now
l_stringToday = Format(l_stringDateTimeNow, "YYYY-MM-DD hh:mm:ss")
' concatenate date and what the user wants logged
l_stringLogStatement = l_stringToday & " " & a_stringLogThis
' send to TTY
Debug.Print (l_stringLogStatement)
' append (not write) to disk
Open ThisWorkbook.path & "\Log.txt" For Append As #1
Print #1, l_stringLogStatement
Close #1
End Function
I believe you're having issues as writeLog already exists as a boolean. Error should be popping up "Ambiguous name detected"
Try the following,
Public bLog as Boolean
Public logWrite as Object
Public log as Object
Private Sub Worksheet_Open()
Dim prompt as Integer
prompt = MsgBox("Would you like to log events for this session?", vbYesNo, "Log Events?")
If prompt Then
bLog = True
Set logWrite = CreateObject("Scripting.FileSystemObject")
Set log = logWrite.CreateTextFile("C:/TEST.txt", False)
Else
bLog = False
End If
End Sub
Public Sub WriteLog(Optional obj as Object, Optional argument as String)
If bLog = True Then
obj.WriteLine argument
End If
End Sub
Edit: made parameters optional in WriteLog (or PrintLog) for further testing
' Write to a log file using Separator and Array of variant Parameters
' Auto generate the file
' USE EndLog to close
'use:
' PrintLog vbtab, "one", 2, 3
' PrintLog vbtab, "Apple","Windows","Linux","Android","Commodore","Amiga","Spectrum"
' EndLog
' Generate a csv file:
' PrintLog ";", rst!ID, rst!Name
Private FileLog As Object
Private fso As Object
Const DEBUG_LOG_FILE = "C:\log.txt"
Public Sub PrintLog(ByVal Separator As String, ParamArray Arguments() As Variant)
Dim ele As Variant
Dim line As String
If FileLog Is Nothing Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set FileLog = fso.CreateTextFile(DEBUG_LOG_FILE, True, True)
End If
line = CStr(Now()) ' Print Timestamp
For Each ele In Arguments
If line > "" Then line = line & Separator
line = line & CStr(ele)
Next
If line > "" Then FileLog.WriteLine line
End Sub
Public Sub EndLog()
On Error Resume Next
FileLog.Close
Set FileLog = Nothing
Set fso = Nothing
On Error GoTo 0
End Sub
I really don't know why this is happening:
This hier is a little presentation wrapper:
' Class PPTGenPresentation
Private m_Presentation As Presentation
Public Sub Class_Initialize()
Set m_Presentation = Nothing
End Sub
Public Sub Class_Terminate()
If Not m_Presentation Is Nothing Then
m_Presentation.Close
End If
End Sub
Public Sub Initialize(ByVal presentationPath As String)
On Error GoTo Error
Set m_Presentation = Presentations.Open(presentationPath, , , msoFalse)
Exit Sub
Error:
MsgBox ("Could not open " & presentationPath)
End Sub
Public Property Get Instance() As Presentation
' After this line Class_Terminate() gets called somehow ..
Instance = m_Presentation
End Property
After I opened the ppt I want to access the actual presentation by accessing the property:
For Each filePath In filePaths
Set safePresentation = New PPTGenPresentation
safePresentation.Initialize (filePath)
Dim tmp As Presentation
Set tmp = savePresentation.Instance
For Each oSlide In tmp.Slides
Set oShape = oSlide.Shapes(1)
If oShape.HasTextFrame Then
If oShape.TextFrame.HasText Then
MsgBox oShape.TextFrame
End If
End If
Next
Next
But after accessing the property Instance, somehow Class_terminate gets called.
I have no idea why ths is happening. Could somebody explain to me what the problem is?
I have added comments to your code.
Basically, when you use set=new to overwrite an object (as happens in each subsequent iteration through your For Each loop) the previous object has either one of two situations from a theoretical standpoint:
The reference is lost but the object exists and now creates a memory leak
The object is automatically cleaned up and destroyed when the reference is gone
VBA automatically causes the second to be true. When you use "New" again, the first presentation no longer will have any way to refer to it, and so it is cleaned up and destroyed. This calls Class_Terminate
Just a note, in other languages without this sort of code you have now would start causing memory leaks (such as C++).
For Each filePath In filePaths
'Each subsequent iteration the following basically happens:
'when you set the presentation to a new one, you are effectively
'ending the previous version. So for example, the following *basically* happens:
' if not safePresentation is nothing then set safePresentation=nothing
Set safePresentation = New PPTGenPresentation
safePresentation.Initialize (filePath)
Dim tmp As Presentation
Set tmp = savePresentation.Instance
For Each oSlide In tmp.Slides
Set oShape = oSlide.Shapes(1)
Next
Next
To solve this, move Set safePresentation = New PPTGenPresentation above your For Each loop.
It gets called as you have a syntax error in your code and I suspect that you have On Error Resume Next in the calling code.
Public Property Get Instance() As Presentation
' After this line Class_Terminate() gets called somehow ..
Instance = m_Presentation
End Property
Generates an error, which is suppressed by the resume next, try:
Public Property Get Instance() As Presentation
' After this line Class_Terminate() gets called somehow ..
Set Instance = m_Presentation
End Property
You'd be much better off not suppressing errors, and certainly not when testing