'==========================================================================
' NAME: URLMail.vbs
'
' AUTHOR: Alan Kaplan, alan at akaplan dot com
' COMMENT: Creates a 'safe' email to send a URL
' DATE  : 5/3/2004
' 5-7-04 revised to fix handling names with spaces
' 8-5-04 Added delete prompt, bNoprompt variable, and prefix, released as v2
' Thanks to Sean Duffy for his suggestions.
' 12/29/10 Added support for Windows 7 URLs
'==========================================================================
Option Explicit
dim fso, oUrlFile, strURL
dim message, retval, strSubjectPrefix, strBody
Dim strFullName, strName
Dim n_args, help, bNoPrompt
Const ForReading = 1
set fso = CreateObject("Scripting.FileSystemObject")
dim wshShell
Set wshShell = WScript.CreateObject("WScript.Shell")

'Edit here ! 
	'Setting to True means no prompts for name or shortcut delete
	bnoprompt = False
	'Start subject line with this.  Notice the space.
	strSubjectPrefix = "Emailing URL: "
	strBody = "I thought you might be interested in this: "
'End edits

Set n_args = WScript.Arguments.named
If n_args.Exists("help") Then Syntax
If n_args.Exists("?") Then Syntax

If WScript.Arguments.Count = 0 Then Syntax

If fso.FileExists(WScript.Arguments(0)) Then
	strFullName = WScript.Arguments(0)
Else
	MsgBox ("not found")
	Syntax
End If 

ReadFile
Sendmail
DelURL

' ======== Subs and Functions ========
Sub ReadFile()
	'9-9-04 changed to support FTP and Mozilla
	Dim iStart, strURLline
	set oURLFile = fso.OpenTextFile(strFullName,ForReading)
	strName = fso.GetBaseName(strFullName)
	'strURLline = oUrlFile.ReadLine
	Do Until Left(strURLline,3) ="URL" Or oUrlFile.AtEndOfStream
		strURLline = oUrlFile.ReadLine	
	Loop
	istart = instr(strURLLine,"=") +1
	strURL =  Mid(strURLline,istart)
	oUrlFile.Close
End Sub 

sub Sendmail()	'Creating mail with Mailto is primitive, 
	'but it escapes warnings from various programs
	Dim strMailSub, strMailBody, strWhoTo
	strMailSub = strSubjectPrefix & StrName
	strMailSub = reformat(StrMailSub) 
	strMailBody = reformat(strBody & strURL & ".")

	Dim command, ampersand
	ampersand = chr(38)

	If bNoPrompt = False Then
		strWhoTo = InputBox("Enter the name of the recipient, (Blank is okay)","Recipient")
		
		If strWhoTo = "" Then 
			retval = MsgBox("No recipient could be a cancel.  Do you want to cancel?",vbquestion + vbyesno + vbdefaultbutton2,"Cancel?")
			If retval = vbyes Then WScript.Quit
		End If 	
		
		strWhoTo = reformat(strWhoTo)
	End If 

	command = "mailto:" & strWhoTo & "?subject="& strMailSub & ampersand &_
	 "body="& strMailBody 
	 	WshShell.Run command
		if Err <> 0 Then
			WshShell.Popup "A problem occured in creating email.  Recheck you syntax.",0,"Email Error",vbInformation
		End if
	On Error goto 0
end Sub

Function reformat (oldtext)
	reformat = REPLACE(oldtext,chr(32),"%20")
End Function

Sub DelURL
	On Error Resume next
	If bNoPrompt = False Then 
		retval = MsgBox ("Delete " & strname & " shortcut?", vbyesno + vbQuestion + vbSystemModal ,"Delete Shortcut?")
	End If 
	
	If ((retval = vbyes) Or (bNoPrompt = True)) Then 
		fso.DeleteFile strFullName,True 
	End If 
End Sub

Sub Syntax()
	message = "This script lets you email an internet shortcut (URL) without creating " & _
	"an attachment which may be filtered by Outlook security settings.  The title is set as the subject, " &_
	"and the URL is put into the body." & vbcrlf & vbcrlf  &_
	"Place this script in a folder and create a shorcut to it on your desktop. " &_
	"To use the script, drag an address from IE to the desktop to create the internet shortcut. " &_
	"Next, drag the internet shortcut to the script. "  &_
	"The default behavior is to prompt you for recipient name, and whether you want to " &_
	"delete the shortcut. " & vbcrlf & vbcrlf  &_
	"You can edit the script to set variable 'bnoprompt' to True if you want the script to " &_
	"create the email and delete the shortcut without prompting you. The 'strSubjectPrefix' variable " &_
	"can be changed to set the subject prefix." 
	MsgBox message,vbinformation + vbokonly,"URLMail 2.0" & " ---- " & "Alan Kaplan"
	WScript.Quit
End Sub