Vault Transmittal - need only the dwfs but the transmittal doesn't give the required information

There's a pack and go tool in Vault that is great for sharing files outside of  vault, that gives options for a complete pack and go of assemblies, and all required parts or just the dwfs and sending these directly to an email. It even includes a tool for automatically creating a transmittal report and attaching that in the zip. The transmittal report is fully customisable to include the information and properties you require.
The only problem is when you create a pack and go and choose to just include dwfs (a common scenario when sending out information), the information in the report just includes the information about the dwfs, not the issue number and status of the main files.
Of course you can create your own custom add in to vault to do this (and even share files over a number of different methods such as directly to Autodesk 360), but that could be time consuming to get the extra 1% functionality required from the pack and go tool.
We have created a workaround to this problem which involves manipulating a generated pack and go zip once it is attached to an email, to strip out everything apart from the pdfs, and dwfs of drawings.
Using the pack and go tool, generate a zip of the models, drawings and dwfs and attach to an email. Building filtering in to the report template to only include information on the required files, and remove the information on spurious additional files. Then run the macro below in outlook to strip out all files except for required dwfs and pdfs.
It's a bit crude and basic, but functional and quickly helps achieve an outcome that overcomes the limitations in the existing functionality.

Public Sub clearzipattachedfile()

If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
      processzip (Application.ActiveInspector.CurrentItem)
End If
End Sub

 

Private Sub processzip(obj As Outlook.MailItem)
Dim Att As Outlook.Attachment
Dim Path As String
Path = Environ("temp") & "\"
For Each Att In obj.Attachments
        If Right(Att.FileName, 3) = "zip" Then
            Dim tempfile As String
            tempfile = Path & Att.FileName
            'save zip to temp folder
            Att.SaveAsFile (tempfile)
            'remove zip file from email
            Att.Delete
            'delete files from zip file
            Call deletefilesfromzip(tempfile)
            'add updated zip back to mail
            obj.Attachments.Add (tempfile)
           'delete zip file from temp folder
            VBA.FileSystem.Kill (tempfile)
       End If
Next
End Sub

Private Sub deletefilesfromzip(zipfile As String)

'macro to delete all files in a folder
On Error Resume Next
'extract files to zipfile
Dim filenamefolder As String
filenamefolder = Left(zipfile, Len(zipfile) - 4)
MkDir filenamefolder
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace((filenamefolder)).CopyHere oApp.NameSpace((zipfile)).Items
Set FileSys = CreateObject("Scripting.FileSystemObject")
FileSys.DeleteFile zipfile
Call newzip(zipfile)
Call deletefiles(filenamefolder, zipfile)
FileSys.deletefolder filenamefolder
Set FileSys = Nothing
End Sub

Private Sub deletefiles(foldername, zipname)

Dim FileSys 'As FileSystemObject
Dim objFile 'As vba.File
Dim myFolder
Set FileSys = CreateObject("Scripting.FileSystemObject")
Set myFolder = FileSys.GetFolder(foldername)
For Each subf In myFolder.subfolders
   Call deletefiles(subf.Path, zipname)
Next subf

'loop through each file and check for name match

For Each objFile In myFolder.Files
        If Right(objFile.Name, 7) <> "dwg.dwf" And Right(objFile.Name, 7) <> "idw.dwf" And Right(objFile.Name, 3) <> "pdf" Then
            objFile.Delete
        Else
            'add back to zip
            Set oApp = CreateObject("Shell.Application")
            Dim i As Integer
            i = 0
            On Error Resume Next
            i = oApp.NameSpace((zipname)).Items.Count
            oApp.NameSpace((zipname)).CopyHere objFile.Path
            Do Until oApp.NameSpace((zipname)).Items.Count = i + 1
                Application.Wait (Now + TimeValue("0:00:01"))
            Loop
        Set oApp = Nothing
        End If
Next objFile
Set FileSys = Nothing
Set myFolder = Nothing
End Sub

Private Sub newzip(sPath)

'Create empty Zip File

    If Len(dir(sPath)) > 0 Then Kill sPath

    Open sPath For Output As #1

    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)

    Close #1

End Sub