Add custom property to all assembly components using macro

I'm a beginner macro/VB user and I've managed to piece together a macro that will parse the filename of a .sldprt and deposit some of it's characters into a custom property of "Description".  How can I make this work at the touch of a button to loop through an entire assembly including components located in subassemblies?  I tried looking the VB help under traversing assemblies at component levels but was quickly lost - way over my head regarding what does what.  I see the counters in there and some other recognizable things there which make it seem like this can be done - but the view is cloudy.  The macro code I have for a single component is below.  I've attached a dummy assembly and drawing I've been using to try and get this to work to no avail.  Any help is appreciated.

---------------------------------------

Option Explicit

Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim cpm As CustomPropertyManager

Sub main()

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set cpm = swModel.Extension.CustomPropertyManager("")

Dim path As String, filename As String, Description As String

path = swModel.GetPathName
filename = Mid\$(path, InStrRev(path, "\") + 1) ' With extension
filename = Left\$(filename, InStrRev(filename, ".") - 1) ' Remove extension

If InStr(Left(filename, 1), "t") = True Then
    Description = UCase(Right(filename, Len(filename) - 7))
Else
    Description = UCase(Right(filename, Len(filename) - 6))
End If

Description = Replace(Description, "_", " ")

cpm.Delete "Description"
cpm.Add2 "Description", swCustomInfoText, Description

End Sub

------------------------------------------

SolidworksApi macros