' ************************************************************************************
' DeployBin v1.0 par omen999 - (omen999.developpez.com) octobre 2010
' déploiement de fichiers binaires embarqués 
' exemple de déploiement de composant COM sans inscription avec la DLL DynamicWrapperX 
' ************************************************************************************
Option Explicit
Const _
MB_ICONWARNING = &H30, _
MB_YESNO = &H4
Dim _
oWrap, _
iRep
Function Initialize
' vérifie si dynamicwrapperx est installé
' extraction éventuelle de wscript.exe, dynwrapx.dll et instanciation des objets et variables
' temps de creation sur HD < 4 secs
' l'écriture se fait en priorité avec l'objet ado stream (avec éventuellement l'objet xmldom) et seulement à défaut
' par l'objet filesystem qui n'est pas conçu pour écrire des fichiers binaires
Const _
GWL_HINSTANCE = -6, _
adTypeBinary = 1, _
adTypeText = 2
Dim _
oStream, _
oShell, _
oFso, _
oXml, _
oElm   
  'test existence objet dynamicwrapperx
  On Error Resume Next
  Set oWrap = CreateObject("DynamicWrapperX")
  If oWrap Is Nothing Then 
    'la lib dynwrapx n'a pas été référencée dans la bdr
    'on teste d'abord l'existence d'ado
    Set oStream = CreateObject("ADODB.Stream")
    If oStream Is Nothing Then
      'pas bon, on teste ensuite le filesystem object
      Set oFso=CreateObject("Scripting.FileSystemObject")
      If oFso Is Nothing Then
        'cas désespéré, on laisse tomber 
        MsgBox "Le composant DynamicWrapperX indispensable au bon fonctionnement du script est absent." & Chr(13) & _
               "Veuillez procéder à son enregistrement avant de continuer.",vbCritical,"Erreur DeployBin 1.0"
        Exit Function
      Else
        'l'objet fso existe, on extrait après décodage la dll et wscript pour les enregistrer comme fichiers
        'sauf s'ils existent déjà...
        If Not oFso.FileExists("dynwrapx.dll") Then 
          Set oStream = oFso.CreateTextFile("dynwrapx.dll")
          B64ToBin imgDynWrapX,oStream,False
          oStream.Close
        End If
        If Not oFso.FileExists("wscript.exe") Then 
          Set oStream = oFso.CreateTextFile("wscript.exe",True)
          B64ToBin imgWScript,oStream,False
        End If
      End If
    Else
      'l'objet adostream existe, test de l'objet XMLDOM
      'puis extraction éventuelle après décodage de la dll et wscript pour les enregistrer comme fichiers
      'pour éviter de faire un SetEOS on commence par le + petit
      oStream.Open
      Set oXml = CreateObject("Microsoft.XMLDOM")
      If oXml Is Nothing Then        
        oStream.Type = adTypeText
        oStream.CharSet = "Windows-1252" 
      Else ' nickel la conversion base64 sera 20 fois + rapide
        oStream.Type = adTypeBinary
        Set oElm = oXml.createElement("tmp")
        oElm.DataType = "bin.base64"
      End If
      oStream.LoadFromFile "dynwrapx.dll"
      If oStream.Size = 0 Then ' le fichier n'existe pas
        If oXml Is Nothing Then 
          B64ToBin imgDynWrapX,oStream,True
        Else 
          oElm.Text = imgDynWrapX
          oStream.Write oElm.NodeTypedValue
        End If		
        oStream.SaveToFile "dynwrapx.dll",2
      End If
      'au tour de wscript.exe 
      oStream.Position = 0
      oStream.LoadFromFile "wscript.exe"
      If oStream.Size < 100000 Then  ' wscript fait au moins 155ko...
        If oXml Is Nothing Then
          B64ToBin imgWScript,oStream,True
        Else
          oElm.Text = imgWScript
          oStream.Write oElm.NodeTypedValue
        End If
        oStream.SaveToFile "wscript.exe",2
      End If	
	End If
    oStream.Close
    Set oStream = Nothing
    Set oShell = CreateObject("WScript.Shell")
    oShell.Run "WScript.exe " & Chr(34) & WScript.ScriptFullName & Chr(34)
    Initialize = False
    Exit Function
  End If
  Initialize = True
End Function

Sub B64ToBin(ByRef sB64, ByRef oStrm, ByVal bAdo)
' pas de contrôle de conformation de la chaine d'entrée
' sB64 : chaine d'entrée en base64
' oStrm : objet textstream ado ou filesystem pour écrire le fichier binaire
' bAdo : flag objet - true ado, false filesystem
Const cB64Charset = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim iPointer   'index du groupe traité
Dim iGSize     'taille du groupe décodé en binaire (gestion du caractère terminal '=')
Dim iOffset    'index dans le groupe
Dim cChar      'caractère courant
Dim cBin       'valeur binaire du caractère
Dim iGBuffer   'buffer numérique du groupe
Dim hGBuffer   'buffer hexa du groupe
Dim cGBuffer   'buffer binaire du groupe			
  'on commence par traiter la chaine d'entrée par groupes de 4 octets
  'chaque groupe de 4 caractères encode pour 3 octets binaires
  iGSize = 3
  For iPointer = 1 To Len(sB64) Step 4   
    iGBuffer = 0 'raz buffer
    For iOffset = 0 To 3 'boucle de traitement du groupe courant
      'lecture du caractère courant
      cChar = Mid(sB64,iPointer + iOffset,1)
      If cChar = "=" Then
      	'le complément n'entre pas dans le décodage
      	iGSize = iGSize - 1
      	cBin = 0
      Else
      	'le rang dans le charset donne la valeur binaire
      	cBin = InStr(1,cB64Charset,cChar,vbBinaryCompare) - 1
      End If
      'nouvelle valeur binaire ajoutée après décalage gauche de deux caractères
      iGBuffer = 64 * iGBuffer + cBin
    Next
    'l'entier long est maintenant converti en une valeur chaine hexa de 6 caractères max
    hGBuffer = Hex(iGBuffer)
    'formatage par ajout de zéros à droite pour obtenir les 6 caractères (2 x 3)
    hGBuffer = String(6 - Len(hGBuffer), "0") & hGBuffer
    'chaque groupe de 2 caractères est converti en une valeur binaire
    cGBuffer = Chr(CByte("&h" & Mid(hGBuffer, 1, 2))) + _
    Chr(CByte("&h" & Mid(hGBuffer, 3, 2))) + _
    Chr(CByte("&h" & Mid(hGBuffer, 5, 2)))
    If bAdo Then
      oStrm.WriteText Left(cGBuffer,iGSize)
    Else
      oStrm.Write Left(cGBuffer,iGSize)
    End If
  Next
End Sub

' on se contente de tester la fonction Initialize qui se charge de relancer le script au besoin avec le bon contexte
If Initialize Then
' le code de chaque script doit être inséré ici en remplacement des deux lignes suivantes
  oWrap.Register "user32.dll", "MessageBoxW", "i=hwwu","r=l"
  iRep = oWrap.MessageBoxW(0, "Hello world !", "RegFreeSxS par omen999", MB_YESNO + MB_ICONWARNING)
End If

Const imgWScript = <code disponible dans le script à télécharger dans la section ci-dessous>
Const imgDynWrapX = <code disponible dans le script à télécharger dans la section ci-dessous>