[AccessD] How to create cab files

Hi Jim and John

Thanks! I was browsing to locate some code to create a cab file - then
I stumbled over IExpress - it must be one of those strange MS secrets.

Nevertheless, I managed too to cook a function to create a cab file
using COM and no shelling in Windows 2000+. This, too, is a well
preserved secret ... you have to use a strange typelib package,
catsrvut.dll, which contains seven typelibs from which one is capable
of compressing files to a cab file. Who would have believed that?

Basically, with this type library it's three lines of code - it
couldn't be simpler!
However, a bit more is needed for making it as robust as needed for
real life.

Below is the function for creating a cab file with a single file; I'll
leave it as an exercise to expand it with an array or collection of
files to be stuffed in the cabinet (hint: look up the links in the
comments) as this can be solved in many ways and is highly dependant
on what you wish to use the function for.

It uses late binding which I think is fine as the library is loaded
very fast and, to be honest, I couldn't find out how to create early
binding for this strange typelib - I have the feeling that it may not
even be possible and as late binding works fine, I left it.

Also note the parenthesis around the file name variables; they are
absolutely needed for some reason.

Have fun!

/gustav

<code>

Public Function CreateCab1( _
  ByVal strCabFileName As String, _
  ByVal strFileNameToCab As String, _
  ByVal strFileNameInCab As String) _
  As Boolean
  
' Create Cab(inet) file containing one compressed file
' by using the typelib in catsrvut.dll.
' OS must be Windows 2000+.
' 2004-05-30. Cactus Data ApS, CPH.
'
' Based on code from Torgeir Bakken and Alex Angelopoulos:
' http://groups.google.com/groups?q=catsrvut.dll&start=10&hl=da&lr=&ie=UTF-8&selm=%23mxGK5hiCHA.1328%40tkmsftngp09&rnum=11
' http://groups.google.com/groups?q=catsrvut.dll&hl=da&lr=&ie=UTF-8&selm=Oqs%24H3ioCHA.1636%40TK2MSFTNGP09&rnum=2
' http://x220.win2ktest.com/forum/topic.asp?TOPIC_ID=3318

  ' Settings for properties of created Cab file.
  Const cbooMakeSignable  As Boolean = False
  Const cbooExtraSpace    As Boolean = False
  Const cbooUse10Format   As Boolean = False
  ' Error code for wrong number of arguments.
  Const clngErrArguments  As Long = 450
  
  Dim objCab              As Object
  
  Dim booSuccess          As Boolean
  
  On Error Resume Next
  
  If Len(strCabFileName) = 0 Or Len(strFileNameToCab) = 0 Then
    ' Nothing to do.
    Exit Function
  End If
  
  ' Create Cabinet object from COMEXPLib.ComExport typelib.
  Set objCab = CreateObject("MakeCab.MakeCab.1")
  
  If Err.Number = 0 Then
    ' Object could be created.
    If Len(strFileNameInCab) = 0 Then
      ' No specific name for the file in the cabinet has been given.
      ' Use the name of the source file.
      ' Note: Path will be preserved.
      strFileNameInCab = strFileNameToCab
    End If
    
    With objCab
      ' Parameters for method CreateCab.
      ' Except for the first, all parameters _must_ be of type Boolean.
      ' For Windows 2000:
      '   CreateCab ByVal CabFileName, ByVal MakeSignable, ByVal ExtraSpace
      ' For Windows XP/2003:
      '   CreateCab ByVal CabFileName, ByVal MakeSignable, ByVal ExtraSpace, ByVal Use10Format
      '
      ' Try call for Windows 2000.
      .CreateCab (strCabFileName), cbooMakeSignable, cbooExtraSpace
      If Err.Number = clngErrArguments Then
        ' Call for Windows 2000 failed.
        ' Reset error and try call for Windows XP.
        Err.Clear
        .CreateCab (strCabFileName), cbooMakeSignable, cbooExtraSpace, cbooUse10Format
      End If
      If Err.Number = 0 Then
        ' Cab file has been initialized.
        ' Add the file to the cabinet and close.
        .AddFile (strFileNameToCab), (strFileNameInCab)
        .CloseCab
        If Err.Number = 0 Then
          ' The file was added successfully to the cabinet.
          booSuccess = True
        End If
      End If
    End With
  End If
  
  Set objCab = Nothing
    
  ' Return True if success.
  CreateCab1 = booSuccess
  
End Function

</code>