Можно ли на VB создать самораспаковываюшийся архив?

Option Explicit
'
'Архиватор-деархиватор ZIP
'by the fever brain 2016
'
Const r = 90
Dim WithEvents cb1 As CommandButton, WithEvents cb2 As CommandButton
Dim zn$, pn$, dd$
 
Private Sub cb1_Click()
    'Создание архива для указанного пути
    zn = InputBox("Имя архива", , Full("Archive.zip")): If LCase(Right$(zn, 4)) <> ".zip" Then Exit Sub
    pn = InputBox("Путь к файлу(папке)", , Full("test.txt")): If pn = "" Then Exit Sub
    CreateZIP(zn).CopyHere (Full(pn))
End Sub
 
Private Sub cb2_Click()
    'Извлечение из архива содержимого в одноименную папку
    zn = InputBox("Имя архива", , Full("Archive.zip")): If LCase(Right$(zn, 4)) <> ".zip" Then Exit Sub
    dd = InputBox("Папка извлечения", , Full(Replace$(zn, ".zip", "", , , 1))): If dd = "" Then Exit Sub
    On Error Resume Next: MkDir dd: On Error GoTo 0
    ShApp.NameSpace(Full(dd)).CopyHere ShApp.NameSpace(Full(zn)).Items
End Sub
 
Private Sub Form_Load()
    Dim w&
    w = r
    ChDir App.Path
    With Fso.CreateTextFile("test.txt")
        'Создаём тэстовый файл и напишем туда чтонибудь
        .Write "Привет народ ! Да здравствует WinRar !"
    End With
 
    'Добавляем кнопочек
    Set cb1 = Controls.Add("vb.CommandButton", "cb1"): With cb1
        .Move w, r, 2500: w = w + .Width + r
        .Caption = "Добавить в архив zip"
        .Visible = 1
    End With
 
    Set cb2 = Controls.Add("vb.CommandButton", "cb2"): With cb2
        .Move w, r
        .Caption = "извлеч в ..."
        .Visible = 1
    End With
End Sub
 
Private Function Full$(ByVal Path$) 'полный путь
    Full = Fso.GetAbsolutePathName(Path)
End Function
 
Private Function Fso()
    Static obj As Object
    If obj Is Nothing Then Set obj = CreateObject("scripting.filesystemobject")
    Set Fso = obj
End Function
 
Private Function ShApp()
    Static obj As Object
    If obj Is Nothing Then Set obj = CreateObject("Shell.Application")
    Set ShApp = obj
End Function
 
Private Function CreateZIP(ByVal ZipName$) As Object
    With Fso
        If LCase(Right$(ZipName, 3)) <> "zip" Then Exit Function
        If .FileExists(ZipName) Then Kill ZipName
        .CreateTextFile(ZipName, 1).Write "PK" & Chr(5) & Chr(6) & String(18, 0)
        Set CreateZIP = ShApp.NameSpace(Full(ZipName))
    End With
End Function
 
 
Private Sub Form_Unload(Cancel As Integer)
    If MsgBox("Убрать созданные файлы и папки этой программой ?", 68) = vbNo Then Exit Sub
    With Fso
        On Error Resume Next
        Fso.DeleteFile "test.txt", 1
        Fso.DeleteFolder "Archive", 1
        Fso.DeleteFile "Archive.zip", 0
    End With
End Sub