neilt17
03-15-2018, 09:33 AM
I have been using the fantastic Rubberduck VBE add-in (http://rubberduckvba.com/) 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
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