'Creates an uncompressed zip file of the contents (and subfolders) of a folder. 

Option Explicit
Const TEXT_EXTENSIONS = "1st aim ans asc c cpp css csv frm h htc htm html js latex log log lrc man msg ncx nfo opf readme rt rtf sig sub tab tdf tex text txt txt vbs wsf wsh xdl xhtm xhtml xml xpgt"
Dim strZipFileEntries, strZipDirectoryEntries
Main

Sub Main()
	Dim fs, strZip, strFileName, strZipEndDirectory
	'Initialize
	strZipFileEntries = ""
	strZipDirectoryEntries = ""
	Set fs = CreateObject("Scripting.FileSystemObject")
	'Check valid args
	If WScript.Arguments.Count = 0 Then
		MsgBox "Drop a folder on me!"
		Exit Sub
	End If
	ProcessFolder WScript.Arguments(0), ""
	'Make end directory
	strZipEndDirectory = ZipEndDirectory(strZipFileEntries, strZipDirectoryEntries)
	'Concatenate everything to make a complete zip file
	strZip = strZipFileEntries & strZipDirectoryEntries & strZipEndDirectory
	'Write the zip file
	String2File strZip, fs.BuildPath(fs.GetParentFolderName(WScript.Arguments(0)), fs.GetBaseName(WScript.Arguments(0)) & ".zip")
End Sub

Sub ProcessFolder(strFolderName, strStoredFolderName)
'The "strFolderName" is the complete path to a folder. 
'The "strStoredFolderName" is the path that will be prefixed to that file (or folder) in the zip file
'This subroutine handles recursion of folders and directs processing of individual files
	Dim fs, fil, fol
	Set fs = CreateObject("Scripting.FileSystemObject")
	If fs.FolderExists(strFolderName) Then
		'Process each file in the folder
		For Each fil In fs.GetFolder(strFolderName).Files
			ProcessFile fil.Path, strStoredFolderName
		Next
		'Recurse folders
		For Each fol In fs.GetFolder(strFolderName).SubFolders
			ProcessFile fol.Path, strStoredFolderName 'We also have to process a folder as if it were a file
			ProcessFolder fol.Path, strStoredFolderName & fs.GetFileName(fol.Name) & "/"
		Next
	End If
End Sub

Sub ProcessFile(strFileName, strStoredFolderName)
'The "strFileName" is the complete path to a file (or folder!). 
'The "strStoredFolderName" is the path that will be prefixed to that file (or folder) in the zip file
'This subroutine appends zip data to the global "strZipFileEntries" and "strZipDirectoryEntries" structures
	Dim fs, strZipFileEntry, strZipDirectoryEntry
	Set fs = CreateObject("Scripting.FileSystemObject")
	'Make file (or folder) zip entry. 
	If fs.FileExists(strFileName) Then
		'Make a file entry
		strZipFileEntry = ZipFileEntry(strFileName, strStoredFolderName & fs.GetFileName(strFileName))
	Elseif fs.FolderExists(strFileName) Then
		'Make a folder entry 
		strZipFileEntry = ZipFileEntry(strFileName, strStoredFolderName & fs.GetFileName(strFileName) & "/")
	Else
		'If it isn't a file or folder, something is very wrong -- don't process it!
		Exit Sub
	End If
	'Make directory entry
	strZipDirectoryEntry = ZipDirectoryEntry(strZipFileEntry, strZipFileEntries)
	'Append file entry
	strZipFileEntries = strZipFileEntries & strZipFileEntry
	'Append directory entry
	strZipDirectoryEntries = strZipDirectoryEntries & strZipDirectoryEntry
End Sub

Function ZipFileEntry(strFileName, strStoredName)
'Create a zip file entry. We need the "StoredName" defined 
'because it can contain paths instead of just a file name.
	Dim fs, dt, strZip, strCRC, strFileData, strFileBaseName, strPart, strExt, blnVFAT, blnPlainText
	Set fs = CreateObject("Scripting.FileSystemObject")
	'Figure out the file last-modified timestamp
	If fs.FileExists(strFileName) Then
		dt = fs.GetFile(strFileName).DateLastModified
	Elseif fs.FolderExists(strFileName) Then
		dt = fs.GetFolder(strFileName).DateLastModified
	Else
		dt = Now()
	End If
	'Figure out the file contents
	blnPlainText = False
	If Instr(fs.GetFileName(strFileName), ".") Then
		For Each strExt In Split(TEXT_EXTENSIONS)
			If Lcase(Right(fs.GetFileName(strFileName), Len(strExt) + 1)) = LCase("." & strExt) Then
				blnPlainText = True
			End If
		Next
	End If
	strFileData = ""
	If fs.FileExists(strFileName) Then 'Ignore folders!
		If blnPlainText Then 
			strFileData = File2String(strFileName)
		Else
			On Error Resume Next 'Security blocking adodb.stream?
			strFileData = ByteArray2Text(ReadByteArray(strFileName))
			On Error Goto 0
			If strFileData = "" Then 
				'Try reading it as text and hope for the best.
				strFileData = File2String(strFileName)
			End If
		End If 
	End If
	'Header
	strZip = "PK" & Chr(3) & Chr(4)
	'Creator Version (10=only files 20=supports folders)
	If InStr(strStoredName, "/") Then
		strZip = strZip & Chr(20)
	Else
		strZip = strZip & Chr(10)
	End If
	'Native File System (0=DOS, 14=VFAT, 20=UNKN)
	blnVFAT = False
	If UCase(strStoredName) <> strStoredName Then blnVFAT = True
	If InStr(strStoredName, " ") <> 0 Then blnVFAT = True
	For Each strPart In Split(strStoredName, "/")
		If Len(strPart) > 12 Then blnVFAT = True
		If ((Len(strPart) > 8) And (InStr(strPart, ".") = 0)) Then blnVFAT = True
		If InStr(strPart, ".") Then
			If Len(strPart) - InStr(strPart, ".") > 3 Then blnVFAT = True
		End If
	Next
	If blnVFAT Then
		'Declare VFAT file system for most things
		strZip = strZip & Chr(14)
	Else
		'Only declare DOS file system for uppercase 8.3 names and paths
		strZip = strZip & Chr(0)
	End If
	'Encryption (0=none) 
	strZip = strZip & TwoByteValue(0)
	'Compression (0=none) 
	strZip = strZip & TwoByteValue(0)
	'Time (MS-DOS format, 2-second resolution) 
	strZip = strZip & TwoByteValue(Cint(Second(dt)/2) + (32*(Minute(dt))) + (2048*(Hour(dt))))
	'Date (MS-DOS format, base year 1980)
	strZip = strZip & TwoByteValue((Day(dt)) + (32*(Month(dt))) + (512*(Year(dt) - 1980)))
	'CRC32 (in that crazy reverse order)
	strCRC = CRC32(strFileData)
	strZip = strZip & Chr("&H" & Mid(strCRC, 7, 2)) & Chr("&H" & Mid(strCRC, 5, 2)) & Chr("&H" & Mid(strCRC, 3, 2)) & Chr("&H" & Mid(strCRC, 1, 2))
	'Compressed size (Same as original size since we aren't compressing)
	strZip = strZip & FourByteValue(Len(strFileData)) 
	'Original size
	strZip = strZip & FourByteValue(Len(strFileData))
	'File name length
	strZip = strZip & TwoByteValue(Len(strStoredName))
	'Extra length
	strZip = strZip & TwoByteValue(0)
	'File name (Include directory name if using paths. Use trailing slash if directory.)
	strZip = strZip & strStoredName
	'File data (contents of file)
	strZip = strZip & strFileData
	ZipFileEntry = strZip
End Function

Function ZipDirectoryEntry(strZipFileEntry, strZipFileEntries)
'You MUST append the strZipFileEntry to strZipFileEntries AFTER this Function
'You MUST append the ZipDirectoryEntry to ZipDirectoryEntries AFTER this function
	Dim strZip, lngFileNameLength, strFileName, blnPlainText, strExt, fs
	Set fs = CreateObject("Scripting.FileSystemObject")
	lngFileNameLength = Asc(Mid(strZipFileEntry, 27, 1)) + (256 * Asc(Mid(strZipFileEntry, 28, 1) ))
	'Extract the file name
	strFileName = Mid(strZipFileEntry, 31, lngFileNameLength)
	'Figure out (again) if this is a binary or text file
	blnPlainText = False
	If Instr(fs.GetFileName(strFileName), ".") <> 0 Then
		For Each strExt In Split(TEXT_EXTENSIONS)
			If Lcase(Right(fs.GetFileName(strFileName), Len(strExt) + 1)) = LCase("." & strExt) Then
				blnPlainText = True
			End If
		Next
	End If
	'Header 
	strZip = "PK" & Chr(1) & Chr(2)
	'Creator Version (10=only files 20=supports folders)
	strZip = strZip & Mid(strZipFileEntry, 5, 2)
	'Extractor version
	strZip = strZip & Mid(strZipFileEntry, 5, 2)
	'General
	strZip = strZip & Mid(strZipFileEntry, 7, 2)
	'Compression
	strZip = strZip & Mid(strZipFileEntry, 9, 2)
	'Time
	strZip = strZip & Mid(strZipFileEntry, 11, 2)
	'Date
	strZip = strZip & Mid(strZipFileEntry, 13, 2)
	'CRC
	strZip = strZip & Mid(strZipFileEntry, 15, 4)
	'Compressed size
	strZip = strZip & Mid(strZipFileEntry, 19, 4)
	'Original size
	strZip = strZip & Mid(strZipFileEntry, 23, 4)
	'File name length
	strZip = strZip & Mid(strZipFileEntry, 27, 2)
	'Extra
	strZip = strZip & TwoByteValue(0)
	'Comment length
	strZip = strZip & TwoByteValue(0)
	'Disk number
	strZip = strZip & TwoByteValue(0)
	'Attributes (0=folder or binary, 1=text)
	If ((Not blnPlainText) Or (Right(strFileName, 1) = "/")) Then
		strZip = strZip & TwoByteValue(0)
	Else
		strZip = strZip & TwoByteValue(1)
	End If	
	'Attributes (0=none, 16=folder, 32=archive bit)
	If Right(strFileName, 1) = "/" Then
		strZip = strZip & FourByteValue(16)
	Else
		strZip = strZip & FourByteValue(0)
	End If
	'Offset 
	strZip = strZip & FourByteValue(Len(strZipFileEntries))
	'File Name
	strZip = strZip & strFileName
	'Return the result
	ZipDirectoryEntry = strZip
End Function

Function ZipEndDirectory(strZipFileEntries, strZipDirectoryEntries)
	Dim strZip, strTemp, lngEntries
	'Header 
	strZip = "PK" & Chr(5) & Chr(6)
	'Disk number
	strZip = strZip & TwoByteValue(0)
	'Starting disk
	strZip = strZip & TwoByteValue(0)
	'Number of records this disk 
	strTemp = strZipDirectoryEntries
	lngEntries = 0
	Do While InStr(strTemp, "PK" & Chr(1) & Chr(2))
		lngEntries = lngEntries + 1
		strTemp = Mid(strTemp, InStr(strTemp, "PK" & Chr(1) & Chr(2)) + 4)
	Loop
	strZip = strZip & TwoByteValue(lngEntries)
	'Total records all disks
	strZip = strZip & TwoByteValue(lngEntries)
	'Directory size
	strZip = strZip & FourByteValue(Len(strZipDirectoryEntries)) 
	'Directory offset start
	strZip = strZip & FourByteValue(Len(strZipFileEntries))
	'Comment length
	strZip = strZip & TwoByteValue(0)
	'Return a value
	ZipEndDirectory = strZip
End Function

Function String2File(strData, strFileName)
'Writes a string to a file. Returns True if success.
	Dim fs, ts, lngChar, strBlock, intChar, dtTimeStamp
	Const ForWriting = 2
	Set fs = CreateObject("Scripting.FileSystemObject")
	On Error Resume Next
	If fs.FileExists(strFileName) Then
		dtTimeStamp = fs.GetFile(strFileName).DateLastModified
	Else
		dtTimeStamp = CDate(0)
	End If
	Err.Clear
	Set ts = fs.OpenTextFile(strFileName, ForWriting, True)
	ts.Write strData
	If Err.Number <> 0 Then
		'Must have hit one of the "problem characters" between 128 and 159
		For lngChar = 1 To Len(strData) Step 100
			Err.Clear
			ts.Write Mid(strData, lngChar, 100)
			If Err.Number <> 0 Then
				'This block of 100 must have the problem. Write them one-at-a-time
				strBlock = Mid(strData, lngChar, 100)
				For intChar = 1 To Len(strBlock)
					ts.Write Chr(255 And AscW(Mid(strBlock, intChar)))
				Next
			End If
		Next
	End If
	ts.Close
	If fs.FileExists(strFileName) Then
		If dtTimeStamp = fs.GetFile(strFileName).DateLastModified Then
			String2File = False
		Else
			String2File = True
		End If
	Else
		String2File = False
	End If
End Function

Function File2String(strFile)
	Dim fs, ts 
	Const ForReading = 1
	Set fs = CreateObject("Scripting.FileSystemObject")
	If fs.FileExists(strFile) Then
		Set ts = fs.OpenTextFile(strFile, ForReading, True)
		If ts.AtEndOfStream Then
			File2String =""
		Else
			File2String = ts.ReadAll
		End If
		ts.Close
	Else
		File2String = ""
	End If
End Function

Function ReadByteArray(strFileName)
Const adTypeBinary = 1
Dim bin
	Set bin = CreateObject("ADODB.Stream")
	bin.Type = adTypeBinary
	bin.Open
	bin.LoadFromFile strFileName
	ReadByteArray = bin.Read
End Function

Function ByteArray2Text(varByteArray)
'Convert byte array into a string with ADODB.Recordset
Dim rs
Const adLongVarChar = 201
    Set rs = CreateObject("ADODB.Recordset")
    rs.Fields.Append "temp", adLongVarChar, LenB(varByteArray)
    rs.Open
    rs.AddNew
    rs("temp").AppendChunk varByteArray
    rs.Update
    ByteArray2Text = rs("temp")
    rs.Close
    Set rs = Nothing
End Function

Function FourByteValue(lngNumber)
'Returns little-endian byte order of a number
	Dim strValue
	strValue = ""
	strValue = strValue & Chr(lngNumber And 255)
	strValue = strValue & Chr((lngNumber \ 256) And 255)
	strValue = strValue & Chr((lngNumber \ (256 * 256)) And 255)
	strValue = strValue & Chr((lngNumber \ (256 * 256 * 256)) And 255)
	FourByteValue = strValue
End Function

Function TwoByteValue(lngNumber)
'Returns little-endian byte order of a number
	Dim strValue
	strValue = ""
	strValue = strValue & Chr(lngNumber And 255)
	strValue = strValue & Chr((lngNumber \ 256) And 255)
	TwoByteValue = strValue
End Function

Function CRC32(strData)
	'A major rewrite of CCalcCRC32 class originally from and copyrighted by Dave Rayment 1999 <d_rayme@hotmailnospam.com>
	Dim strCrc, lngCRC, intCount, lngLookup(256)
	strCrc = "0000000077073096EE0E612C990951BA076DC419706AF48FE963A5359E6495A30EDB883279DCB8A4E0D5E91E97D2D98809B64C2B7EB17CBDE7B82D0790BF1D91"
	strCrc = strCrc & "1DB710646AB020F2F3B9714884BE41DE1ADAD47D6DDDE4EBF4D4B55183D385C7136C9856646BA8C0FD62F97A8A65C9EC14015C4F63066CD9FA0F3D638D080DF5"
	strCrc = strCrc & "3B6E20C84C69105ED56041E4A26771723C03E4D14B04D447D20D85FDA50AB56B35B5A8FA42B2986CDBBBC9D6ACBCF94032D86CE345DF5C75DCD60DCFABD13D59"
	strCrc = strCrc & "26D930AC51DE003AC8D75180BFD0611621B4F4B556B3C423CFBA9599B8BDA50F2802B89E5F058808C60CD9B2B10BE9242F6F7C8758684C11C1611DABB6662D3D"
	strCrc = strCrc & "76DC419001DB710698D220BCEFD5102A71B1858906B6B51F9FBFE4A5E8B8D4337807C9A20F00F9349609A88EE10E98187F6A0DBB086D3D2D91646C97E6635C01"
	strCrc = strCrc & "6B6B51F41C6C6162856530D8F262004E6C0695ED1B01A57B8208F4C1F50FC45765B0D9C612B7E9508BBEB8EAFCB9887C62DD1DDF15DA2D498CD37CF3FBD44C65"
	strCrc = strCrc & "4DB261583AB551CEA3BC0074D4BB30E24ADFA5413DD895D7A4D1C46DD3D6F4FB4369E96A346ED9FCAD678846DA60B8D044042D7333031DE5AA0A4C5FDD0D7CC9"
	strCrc = strCrc & "5005713C270241AABE0B1010C90C20865768B525206F85B3B966D409CE61E49F5EDEF90E29D9C998B0D09822C7D7A8B459B33D172EB40D81B7BD5C3BC0BA6CAD"
	strCrc = strCrc & "EDB883209ABFB3B603B6E20C74B1D29AEAD547399DD277AF04DB261573DC1683E3630B1294643B840D6D6A3E7A6A5AA8E40ECF0B9309FF9D0A00AE277D079EB1"
	strCrc = strCrc & "F00F93448708A3D21E01F2686906C2FEF762575D806567CB196C36716E6B06E7FED41B7689D32BE010DA7A5A67DD4ACCF9B9DF6F8EBEEFF917B7BE4360B08ED5"
	strCrc = strCrc & "D6D6A3E8A1D1937E38D8C2C44FDFF252D1BB67F1A6BC57673FB506DD48B2364BD80D2BDAAF0A1B4C36034AF641047A60DF60EFC3A867DF55316E8EEF4669BE79"
	strCrc = strCrc & "CB61B38CBC66831A256FD2A05268E236CC0C7795BB0B4703220216B95505262FC5BA3BBEB2BD0B282BB45A925CB36A04C2D7FFA7B5D0CF312CD99E8B5BDEAE1D"
	strCrc = strCrc & "9B64C2B0EC63F226756AA39C026D930A9C0906A9EB0E363F720767850500571395BF4A82E2B87A147BB12BAE0CB61B3892D28E9BE5D5BE0D7CDCEFB70BDBDF21"
	strCrc = strCrc & "86D3D2D4F1D4E24268DDB3F81FDA836E81BE16CDF6B9265B6FB077E118B7477788085AE6FF0F6A7066063BCA11010B5C8F659EFFF862AE69616BFFD3166CCF45"
	strCrc = strCrc & "A00AE278D70DD2EE4E0483543903B3C2A7672661D06016F74969474D3E6E77DBAED16A4AD9D65ADC40DF0B6637D83BF0A9BCAE53DEBB9EC547B2CF7F30B5FFE9"
	strCrc = strCrc & "BDBDF21CCABAC28A53B3933024B4A3A6BAD03605CDD7069354DE572923D967BFB3667A2EC4614AB85D681B022A6F2B94B40BBE37C30C8EA15A05DF1B2D02EF8D"
	For intCount = 0 To 255
		lngLookup(intCount) = CLng("&H" & Mid(strCrc, (1 + (intCount * 8)), 8))
	Next
	lngCRC = &HFFFFFFFF
	For intCount = 1 To Len(strData)
		lngCRC = (Int(lngCRC / 256) And &HFFFFFF) Xor (lngLookup((lngCRC Xor Asc(Mid(strData, intCount, 1))) And &HFF))
	Next
	CRC32 = Right("00000000" & Hex(Not lngCRC), 8)
End Function