[XP] SendTo uitbreiden met Kopieren shortcut naar emailontv.

[Verwijderd]

Ik wil graag het SendTo-menu (Kopieren Naar) uitbreiden met de optie 'snelkoppeling kopieren naar e-mailontvanger'.

Ik weet dat je in de map C:\Documents and Settings\User Name\SendTo het bestand Bureaublad.desklink staat voor de functie 'kopieren naar bureaublad'
en bestand E-mailontvanger.mapimail voor de funktie 'kopieren naar e-mailontvanger'

Hiervan wil ik dus een combinatie maken: wanneer ik bv een excel-bestand op het netwerk heb staan en ik wil een snelkoppeling hiervan mailen naar een aantal mensen, dan zou het mooi zijn wanneer dit in 1x met een SendTo-optie kan

[Krypt]

Alstu: http://cwashington.netreach.net/depo/view.asp?Index=989

[Verwijderd]

Mooi script, bedankt!

Jammere is alleen dat het scriptje het pad + bestandsnaam in de mail body zet en hier niet automatisch een shortcut van maakt:

\\server\share\bestand.xls

Helaas heb ik geen verstand van scripts, maar denk dat het 'm zit in de vetgedrukte regel.
Iemand die weet hoe ik deze kan wijzigen zodat het script een link hiervan maakt? De mailbody is html.
Ikzelf heb wel wat lopen prutsen, maar dit levert niet meer op dan een rits foutmeldingen

'~~[author]~~
'Jochen Kanta
'~~[/author]~~

'~~[emailAddress]~~
'[e-mail]
'~~[/emailAddress]~~

'~~[scriptType]~~
'vbscript
'~~[/scriptType]~~

'~~[subType]~~
'Messaging
'~~[/subType]~~

'~~[keywords]~~
'Outlook Script, Contextmenu, Send To as Link
'~~[/keywords]~~

'~~[comment]~~
'A Simple Script that creates a Shortcut in Send To Folder. Everytime you choose the contexmenu in the Windows Explorer the Script will start Outlook an generates a new Message with a Link to the File you selected. The Link would be shown as UNC. It is very usefull because you don't send the File as Attachment only the Link. Be sure that the recipient have access to this UNC Path
'~~[/comment]~~

'~~[script]~~

Option Explicit
Dim ws, fso, arFldrs,olapp, ns, olmail, olAttach, olMailItem, strAttach, objNetwork, objDrive, i, strdriveUNC, strunc, Src,_
cnt, strDrive, strPath, Title, Usage

Set ws = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set objNetwork = WScript.CreateObject("WScript.Network")
Set objDrive = objNetwork.EnumNetworkDrives
Set olapp = CreateObject("Outlook.Application")
Set ns = olapp.GetNameSpace("MAPI")
Set olmail = olapp.CreateItem(olMailItem)

Title = "Send File as Shortcut in Mail"
Usage = "USAGE:" & vbcrlf & " Right click on file(s) or folder(s)" & vbcrlf & _
" Click " & chr(34) & "Send To" & chr(34) & vbcrlf &_
" Click " & chr(34) & "Verstuur snelkoppeling als mail"

If WScript.Arguments.Count = 0 Then
Dim Sel, Scut
Scut = ws.SpecialFolders("SendTo") & "\E-mailontvanger als snelkoppeling.lnk"
If fso.FileExists(Scut) Then
Sel = MsgBox("THIS UTILITY CAN NOT BE RUN DIRECTLY." & vbcrlf & vbcrlf & _
Usage & vbcrlf & vbcrlf & _
"DO YOU WANT TO UNINSTALL " & Title & "?", 4 + 64 + 256, Title)
If Sel = 6 Then
fso.GetFile(Scut).Delete
MsgBox Title & " UNINSTALLED." & vbcrlf & vbcrlf & "To REINSTALL, " & _
"run this script again.", 64, Title
End If
Else
Sel = MsgBox("Do you want to Install " & Title & "?", 4 + 32, Title)
If Sel = 6 Then
With ws.CreateShortcut(Scut)
.TargetPath = WScript.ScriptFullName
.IconLocation = "explorer.exe, 5"
.Save
End With
MsgBox Title & " INSTALLED." & vbcrlf & vbcrlf & Usage & vbcrlf & _
vbcrlf & "To UNINSTALL, run this script again.", 64, Title
End If
End If
Cleanup
End If


call BuildPath


call BuildMail

Cleanup


Sub BuildMail


On Error GoTo 0
For cnt = 0 To (WScript.Arguments.Count -1)
Src = WScript.Arguments.Item(cnt)
If strPath = "" Then
strAttach = fso.GetAbsolutePathName(Src)
Else
strAttach = fso.GetAbsolutePathName(Src)
strAttach = Mid (strAttach,3)
strAttach = ""&strPath & strAttach&""
End If
'olmail.HtmlBody = strAttach ' Plain HTML Body
olmail.Subject = strAttach
olmail.Body = vbcrlf & strAttach & vbcrlf' Plain Txt Body
olmail.Display
olmail.Save

Next

End Sub

Sub Cleanup
Set ws = Nothing
Set fso = Nothing
WScript.Quit
End Sub


Sub BuildPath

On Error GoTo 0
For cnt = 0 To (WScript.Arguments.Count -1)
Src = WScript.Arguments.Item(cnt)
For i = 0 to objDrive.Count - 1 Step 2
strdriveUNC = objDrive.Item(i)
strunc = objDrive.Item(i+1)
strdrive = fso.GetDriveName(Src)
If strDrive = strDriveUNC Then
strPath = strunc
End If
Call BuildMail
Next
Next

End Sub
'~~[/script]~~

[Krypt]

Je wilt er dus een hyperlink naar hebben?

De volgende regels veranderen in het volgende.

code:

    olmail.HtmlBody = "<a href=" & CHR(34) & strAttach & CHR(34) & ">" & strAttach & "</a>"' Plain HTML Body
    olmail.Subject = strAttach
    'olmail.Body = vbcrlf & strAttach & vbcrlf' Plain Txt Body

Dus gewoon HTML mail van maken en HTML code voor gebruiken.

[Verwijderd]

Werkt, super!

[Krypt]

Heb het script nog even aangepast. Multi files deed ie niet goed en het outlook schermpje lag te knipperen als een gek. Nergens voor nodig. Nog lang niet helemaal netjes geprogrammeerd maar het werkt al een stukje beter vind ik.

Edit: Regel 73 uitremmen als je niet wilt dat ie 'm automatisch opslaat als draft.

code:

Option Explicit
Dim ws, fso, arFldrs,olapp, ns, olmail, olAttach, olMailItem, strAttach, objNetwork, objDrive, i, strdriveUNC, strunc, Src,_
cnt, strDrive, strPath, Title, Usage, HtmlBody

Set ws = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set objNetwork = WScript.CreateObject("WScript.Network")
Set objDrive = objNetwork.EnumNetworkDrives
Set olapp = CreateObject("Outlook.Application")
Set ns = olapp.GetNameSpace("MAPI")
Set olmail = olapp.CreateItem(olMailItem)

Title = "Send File as Shortcut in Mail"
Usage = "USAGE:" & vbcrlf & " Right click on file(s) or folder(s)" & vbcrlf & _
" Click " & chr(34) & "Send To" & chr(34) & vbcrlf &_
" Click " & chr(34) & "Sent Mail To (create shortcut)"

If WScript.Arguments.Count = 0 Then
Dim Sel, Scut
Scut = ws.SpecialFolders("SendTo") & "\Sent Mail To (create shortcut).lnk"
If fso.FileExists(Scut) Then
Sel = MsgBox("THIS UTILITY CAN NOT BE RUN DIRECTLY." & vbcrlf & vbcrlf & _
Usage & vbcrlf & vbcrlf & _
"DO YOU WANT TO UNINSTALL " & Title & "?", 4 + 64 + 256, Title)
If Sel = 6 Then
fso.GetFile(Scut).Delete
MsgBox Title & " UNINSTALLED." & vbcrlf & vbcrlf & "To REINSTALL, " & _
"run this script again.", 64, Title
End If
Else
Sel = MsgBox("Do you want to Install " & Title & "?", 4 + 32, Title)
If Sel = 6 Then
With ws.CreateShortcut(Scut)
.TargetPath = WScript.ScriptFullName
.IconLocation = "explorer.exe, 5"
.Save
End With
MsgBox Title & " INSTALLED." & vbcrlf & vbcrlf & Usage & vbcrlf & _
vbcrlf & "To UNINSTALL, run this script again.", 64, Title
End If
End If
Cleanup
End If

Call BuildMail

Cleanup


Sub BuildMail
 '
 On Error GoTo 0
 '
 For cnt = 0 To (WScript.Arguments.Count -1)
   Src = WScript.Arguments.Item(cnt)
   strPath=BuildPath(Src)
   If strPath = "" Then
     strAttach = fso.GetAbsolutePathName(Src)
   Else
     strAttach = fso.GetAbsolutePathName(Src)
     strAttach = Mid (strAttach,3)
     strAttach = ""&strPath & strAttach&""
   End If
   '
   HtmlBody = HtmlBody & "<br><a href=" & CHR(34) & strAttach & CHR(34) & ">" & strAttach & "</a>"
   '
 Next
 '
 olmail.HtmlBody = HtmlBody ' Plain HTML Body
 olmail.Subject = strAttach
 'olmail.Body = vbcrlf & strAttach & vbcrlf' Plain Txt Body
 olmail.Display
 olmail.Save
 '
End Sub

Sub Cleanup
 '
 Set ws = Nothing
 Set fso = Nothing
 WScript.Quit
 '
End Sub

Function BuildPath(Src)
 '
 On Error GoTo 0
 For i = 0 to objDrive.Count - 1 Step 2
   strdriveUNC = objDrive.Item(i)
   strunc = objDrive.Item(i+1)
   strdrive = fso.GetDriveName(Src)
   If strDrive = strDriveUNC Then
     strPath = strunc
   End If
 Next
 BuildPath=strPath
 '
End Function

[Verwijderd]

Nog mooier! Bedankt.