'******************************************************************************
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF
' ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED
' TO THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A
' PARTICULAR PURPOSE.
'
' Copyright (C) 2001.  Microsoft Corporation.  All rights reserved.
'
' Modified by Michel I. Gallant  11/21/2002 to handle email S-MIME
' enveloped blocks which may require bstr to UNICODE string conversion. 
' Also handles binary p7 data (requires ADODB) .
'******************************************************************************
'
' DenvelopAll.vbs
'
' This VBScript decrypts a previously enveloped message, and then saves the 
' decrypted content to a specified file.
'
' This script runs from the command prompt and takes two arguments,
' 
' 1) filename of a enveloped message to be decrypted
' 2) filename to save the decrypted content
'
' To decrypt an enveloped message, a time valid recipient's certificate with
' access to the private key is required in the current user My store.
'
Option Explicit

Const ForReading = 1, ForWriting = 2

' Check syntax.
If Wscript.Arguments.Count <> 2 Then
    MsgBox "Usage: Denvelop.vbs EnvelopedFileName DecryptedFileName"
    Wscript.Quit(1)
End If

' Decrypt the enveloped message.
DenvelopFile Wscript.Arguments(0), Wscript.Arguments(1)

MsgBox "The enveloped message of " & Wscript.Arguments(0) & " has been " & _
       "successfully decrypted, and the decrypted content was saved to " & _
       Wscript.Arguments(1) & "."

Wscript.Quit(0)

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' DenvelopFile
'
' Decrypt an enveloped message of InFile and save decrypted content to OutFile.
'
Sub DenvelopFile (InFile, OutFile)
    Dim EnvelopedData, oUtils
    Dim Message, bMessage
    Dim decString
    Dim Encryption_Algorithm, Key_Length

 Encryption_Algorithm = Array("RC2", "RC4", "DES", "3DES", "AES")
 Key_Length = Array("maximum", "40 bits", "56 bits","128 bits", "192 bits", "256 bits")


    Set oUtils = CreateObject("CAPICOM.Utilities")
    Set EnvelopedData = CreateObject("CAPICOM.EnvelopedData")
    LoadFile InFile, Message
 On Error Resume Next
    EnvelopedData.Decrypt(Message)
  If  Err.Number <> 0  Then ' data may be binary DER
    'WScript.Echo "Could not decrypt as text"
	Err.Clear
 	LoadBinFile InFile, bMessage
	Message = oUtils.ByteArrayToBinaryString(bMessage)'convert from byte array to binary-packed string
	EnvelopedData.Decrypt(Message)
	If Err.Number <> 0  Then ' can't decrypt
	  WScript.Echo "Could not decrypt file " & InFile
	  WScript.Quit(1)
	  Exit Sub
	End If
  End If

 decString = EnvelopedData.Content

 WScript.Echo "Alg Name " & Encryption_Algorithm(EnvelopedData.Algorithm.Name)& _
		"  " & Key_Length(EnvelopedData.Algorithm.KeyLength)


  SaveFile OutFile, decString
   If  Err.Number <> 0  Then	' If error, could be an email S-MIME enveloped data block
     SaveBinFile OutFile, oUtils.BinaryStringToByteArray(decString) ' use this OR the next line
     'SaveFile OutFile, BinStrtoStr(decString)
     WScript.Echo "Saved to " & OutFile & " using binary conversion"
   Else
     WScript.Echo "Saved to " & OutFile & " directly as text file"
   End If
 On Error Goto 0

End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' LoadFile
'
' Read content of FileName and assign to Buffer as string.
'
Sub LoadFile (FileName, Buffer)   
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.FileExists(FileName) Then
        MsgBox "Error: " & FileName & " file not found."
        Exit Sub
    End If
   
    Dim ts
    Set ts = fso.OpenTextFile(FileName, ForReading)  
    Buffer = ts.ReadAll
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' LoadBinFile
'
' Read content of FileName and return as byte array.
'
Sub LoadBinFile (FileName, bBuffer)   
  Const adReadAll = -1
  Dim oStream, bFileData
  Set oStream = WScript.CreateObject("ADODB.Stream")
  oStream.Open
  oStream.Type = 1  ' adTypeBinary
  oStream.LoadFromFile FileName
  bBuffer = oStream.Read(adReadAll)
  oStream.Close
  Set oStream = nothing
End Sub

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' SaveFile
'
' Save string Buffer to FileName.
'
Sub SaveFile (FileName, Buffer)
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim ts
    Set ts = fso.OpenTextFile(FileName, ForWriting, True)
    ts.Write Buffer
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' SaveBinFile
'
' Save binary array to FileName.
'
Sub SaveBinFile (FileName, Binarray)
  Dim oStream
  Const adSaveCreateOverWrite = 2
  Const adTypeBinary = 1
  Const adModeReadWrite = 3 
  Set oStream = WScript.CreateObject("ADODB.Stream")
  oStream.type = adTypeBinary
  oStream.mode = adModeReadWrite
  oStream.Open
  oStream.write Binarray
  oStream.SaveToFile FileName, adSaveCreateOverWrite
  oStream.Close
  Set oStream = nothing
End Sub


'************************************************************
' BinStrtoStr takes a binary-packed string argument
' and builds and returns a regular UNICODE vbs string.
'
' 				M. Gallant  08/14/2002
'************************************************************
Function BinStrtoStr(BinStr)
    Dim i
    Dim ch
    BinStrtoStr = ""
    For i = 1 to LenB(BinStr)
       ch = MidB(BinStr, i, 1)
       BinStrtoStr = BinStrtoStr & Chr(AscB(ch))
    Next
End Function



' -- Convert Unicode string to ASCII string ----
Function MyStrConv(Ustr)
    Dim i
    Dim ch
    MyStrConv = ""
    For i = 1 to Len(Ustr)
       ch = Mid(Ustr, i, 1)
       MyStrConv = MyStrConv & ChrB(AscB(ch))
    Next
End Function