Consulting

Results 1 to 5 of 5

Thread: Separating out test code from main code

  1. #1
    VBAX Regular
    Joined
    Mar 2017
    Posts
    23
    Location

    Separating out test code from main code

    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

  2. #2
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    6,902
    Location
    Thank you for sharing
    I always expect the student to do their homework and find all the errrors I leeve in.

    Please take the time to read the Forum FAQ

  3. #3
    VBAX Regular
    Joined
    Mar 2017
    Posts
    23
    Location
    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.

  4. #4
    Moderator VBAX Wizard SamT's Avatar
    Joined
    Oct 2006
    Location
    Near Columbia
    Posts
    6,902
    Location
    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.
    I always expect the student to do their homework and find all the errrors I leeve in.

    Please take the time to read the Forum FAQ

  5. #5
    VBAX Regular
    Joined
    Mar 2017
    Posts
    23
    Location
    Quote Originally Posted by SamT View Post
    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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •