Separating out test code from main code

[neilt17]

I have been using the fantastic Rubberduck VBE add-in to do unit testing on my project code. As a result I was ending up with a lot of test modules cluttering up my add-in code. So, I have pulled out all of my test code into a separate macro enabled (pptm in my case) file. To speed up switching between working on the main code in one file and running tests in the other, I have set up some automation for creating an add-in from the first pptm file and adding this as a reference for use by the test code. It works fairly well - but any comments for improving it would be great!

This example is from PowerPoint - but would be similar for other Office formats.

Saving code to be tested as an add-in:

Application.ActivePresentation.SaveAs "\path\for\addin\under\test", ppSaveAsOpenXMLAddin

Code in the file doing the testing:
(Run LoadAddIn - with the name of the project you saved and the full path to its add-in file).

Option Explicit


' Loads or reloads the add-in to test
Public Sub LoadAddIn(ByVal stSrcProjectName, ByVal stSrcAddInPath)


  Dim stAddInCopyPath As String
  stAddInCopyPath = LAM_TmpFilePath()
  
  If LAM_RefExists(stSrcProjectName) Then
    LAM_DeleteRef stSrcProjectName
    Debug.Print "Existing add-in - " & stSrcProjectName & " - de-referenced."
  End If
  
  ' Clear out old temporary files. Note, any add-ins that have been referenced
  ' since ppt was last opened may not be deletable even if they are no longer
  ' referenced. These can be deleted by closing and opening ppt and running
  ' this procedure:
  Dim lngFileDeleteCount As Long
  lngFileDeleteCount = LAM_RemoveTempFiles()
  If lngFileDeleteCount > 0 Then
    Debug.Print "Number of temporary files deleted: " & lngFileDeleteCount
  End If
  
  Dim fso
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  If fso.FileExists(stSrcAddInPath) Then
    ' Copy the file to a new file for loading - if it is loaded with the
    ' original file name we will not be able to save new versions of the
    ' source file without closing this file.
    fso.CopyFile stSrcAddInPath, stAddInCopyPath
    Debug.Print "Source file:" & vbCrLf & stSrcAddInPath & vbCrLf & _
                "found. Last modified:" & vbCrLf & _
                fso.getfile(stSrcAddInPath).datelastmodified
  Else
    Debug.Print stSrcAddInPath & vbCrLf & "could not be found."
    Exit Sub
  End If
  
  If Not fso.FileExists(stAddInCopyPath) Then
    Debug.Print "The temporary copy of the add-in could notbe created at:" & _
                stAddInCopyPath & vbCrLf & "The add-in has not been loaded."
    Exit Sub
  End If
  
  Application.ActivePresentation.VBProject.References.AddFromFile stAddInCopyPath


  If LAM_RefExists(stSrcProjectName) Then
    Debug.Print "Add-in - " & stSrcProjectName & " - loaded."
  Else
    Debug.Print "Failed to load add-in - " & stSrcProjectName & "."
  End If


End Sub


Public Sub UnloadAddIn(ByVal stSrcProjectName)
  If LAM_RefExists(stSrcProjectName) Then
    LAM_DeleteRef stSrcProjectName
    Debug.Print "Existing add-in - " & stSrcProjectName & " - de-referenced."
  Else
    Debug.Print stSrcProjectName & " was not found in the list of references."
  End If
End Sub


' This removes as many unused temporary files as possible - given that
' PowerPoint may hold onto them - even if the reference has been removed.
Public Function LAM_RemoveTempFiles() As Long


  Dim stBaseFileName As String
  stBaseFileName = LAM_TmpAddInBaseName()


  Dim stTmpFolder As String
  stTmpFolder = Environ("TMP")
  
  Dim lngFileCount As Long
  lngFileCount = 0
  
  Dim stTmp As String
  stTmp = Dir(stTmpFolder & "\")
  
  Do While stTmp <> vbNullString
    If Mid(stTmp, 1, Len(stBaseFileName)) = stBaseFileName Then
      If LAM_DeleteFile(stTmpFolder & "\" & stTmp) Then
        lngFileCount = lngFileCount + 1
      End If
    End If
    stTmp = Dir
  Loop
  LAM_RemoveTempFiles = lngFileCount


End Function


Public Function LAM_DeleteFile(ByVal stFilePath As String) As Boolean


  LAM_DeleteFile = False
  Dim fso
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  On Error GoTo DeleteFailed
  
  fso.DeleteFile stFilePath
  LAM_DeleteFile = True
  
  Exit Function
  
DeleteFailed:
  


End Function


Public Function LAM_RefExists(ByVal RefName)
  Dim ref As Object
  LAM_RefExists = False
  For Each ref In Application.ActivePresentation.VBProject.References
    If ref.Name = RefName Then
      LAM_RefExists = True
      Exit Function
    End If
  Next
End Function


Public Sub LAM_ListReferences()
  Dim ref As Object
  For Each ref In Application.ActivePresentation.VBProject.References
    Debug.Print ref.Name
  Next
End Sub


Public Function LAM_DeleteRef(ByVal stRefName As String) As Boolean
  Dim ref As Object
  
  LAM_DeleteRef = False
  
  On Error GoTo RemoveProblem
  
  With Application.ActivePresentation.VBProject.References
    .Remove .Item(stRefName)
    LAM_DeleteRef = True
  End With
  
  Exit Function
  
RemoveProblem:
  ' LAM_DeleteRef = False


End Function


Private Function LAM_TmpAddInBaseName() As String
  LAM_TmpAddInBaseName = "vba-tmp-addin-"
End Function


Private Function LAM_TmpFilePath() As String
  LAM_TmpFilePath = Environ("TMP") & "\" & LAM_TmpAddInBaseName() & (Now() * 86400) & ".ppam"
End Function

[SamT]

Thank you for sharing

[neilt17]

Just a note of caution if you are using this. If you also have an add-in loaded with the same project name as the project name under test you may get an error about having a duplicate reference and the add-in under test won't load. You may continue to get this error even if you remove the duplicate projects/references, and even if you close and re-open the presentation file loading the add-in: it appears the reference is still retained even if it doesn't appear in the references list. The sequence of events looks like this:

* you get a duplicate name error when you run LoadAddin;
* you remove all possible sources of duplicate project names (closing files/removing add-ins/removing references);
* you still get the same error;
* you close the file (saving it) - and re-open it;
* you still get the same error;
* restart computer - error persists.

The only remedy seems to be to go to an earlier version of the file - saved before you tried to add the reference.

[SamT]

The only remedy seems to be to go to an earlier version of the file - saved before you tried to add the reference.

If you do enough coding to use a third party code tester, and need to save many "micro" versions, here's what I use in My Personal.xls

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'If I forget to save before closing. Provides a warning, in case I really don't want the latest changes.
    If Not Me.Saved Then Me.Save
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUi As Boolean, Cancel As Boolean)
'Everytime the File is saved
    Me.SaveCopyAs ("E:\COMPUTING\Programming\_VBA\MyPersonal\" & CDbl(Now) & "- Personal.xls")
End Sub

When I actually want to SaveAs a new version, I just do that normally from the Menu.

[neilt17]

If you do enough coding to use a third party code tester, and need to save many "micro" versions, here's what I use in My Personal.xls

Private Sub Workbook_BeforeClose(Cancel As Boolean)
'If I forget to save before closing. Provides a warning, in case I really don't want the latest changes.
    If Not Me.Saved Then Me.Save
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUi As Boolean, Cancel As Boolean)
'Everytime the File is saved
    Me.SaveCopyAs ("E:\COMPUTING\Programming\_VBA\MyPersonal\" & CDbl(Now) & "- Personal.xls")
End Sub

When I actually want to SaveAs a new version, I just do that normally from the Menu.

Thank you SamT - that's a great idea.

I found that I needed to modify this slightly for PowerPoint as when you call .SaveCopyAs from the equivalent PresentationBeforeSave event handler I get an error "Presentation (unknown member): Failed". A solution involving timers (posted here: https://www.pcreview.co.uk/threads/e...aveas.2839232/) did not work for me. So instead I call .SaveCopyAs from within a PresentationSave event handler - with a check for a recent save to prevent looping:

MyEventsModule:

Option Explicit

Public m_oMyEvents As CMyEvents

Private Sub Auto_Open()
  If m_oMyEvents Is Nothing Then
    Set m_oMyEvents = New CMyEvents
  End If
  Set m_oMyEvents.PPTEvent = Application
End Sub

CMyEvents class:

Option Explicit

Public WithEvents PPTEvent As Application
Private m_strSaveMinute As String

Private Sub PPTEvent_PresentationSave(ByVal Pres As Presentation)
  Dim strNowMinute As String
  strNowMinute = Format(Now, "yyyy-mm-dd-hh-nn")
  If strNowMinute <> m_strSaveMinute Then
    ' This required to prevent an infinite loop as the SaveCopyAs event also
    ' triggers the PresentationSave event.
    Application.ActivePresentation.SaveCopyAs Environ("HOMEPATH") & _
      "\Documents\FileBackups\PowerPoint\" & "mybackup" & "-" & _
      Format(Now, "yyyy-mm-dd-hh-nn-ss") & ".pptm", _
      ppSaveAsOpenXMLPresentationMacroEnabled
  End If
  m_strSaveMinute = Format(Now, "yyyy-mm-dd-hh-nn")
End Sub