Embed this VBA Macro in your Outlook :
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim totalSize As Double 'to store total size of the attachments
Dim FileName As String 'path for the temp folder
Dim strBody As String
Dim strUname As String
Dim i As Integer
totalSize = 0
strBody = "The attached files are placed in the below location" & vbCrLf
i = 1
strUname = Environ("USERNAME")
If Item.Attachments.Count <> 0 Then 'Check if files are attached
For Each At In Item.Attachments
totalSize = totalSize + At.Size
Next At
'Check the total size of attached files are greater than 1MB
If totalSize >= 10 Then
For Each Atmt In Item.Attachments
strBody = strBody & "http://mysite/personal/" & strUname & "/Personal%20Documents/" & Atmt & vbCrLf
FileName = "C:\Users\" & strUname & "\AppData\Local\Temp\" & Trim(Atmt.FileName)
Atmt.SaveAsFile FileName 'Save the attachments to Temp folder of your system
UploadFile "C:\Users\" & strUname & "\AppData\Local\Temp\" & Atmt, "http://mysite/personal/" & strUname, "Personal Documents/" & Atmt.FileName, "Test title", "Test checkin comment"
Next Atmt
End If
For i = 1 To Item.Attachments.Count 'Delete Attached files in mail
Item.Attachments(1).Delete
Next i
Item.Body = Item.Body & strBody
'MsgBox ("Total Size:" & totalSize & "KB")
MsgBox "Done"
End If
End Sub
Function StringToByteArray(str)
Set stream = CreateObject("ADODB.Stream")
stream.Open
stream.Type = 2 ''adTypeText
stream.Charset = "ascii"
stream.WriteText str
stream.Position = 0
stream.Type = 1 ''adTypeBinary
StringToByteArray = stream.Read()
stream.Close
End Function
Sub UploadFile(sourcePath, siteUrl, docName, title, checkincomment)
strHeader = "method=put+document%3a12.0.4518.1016" + "&service_name=%2f" + "&document=[document_name=" + docName + ";meta_info=[vti_title%3bSW%7c" + title + "]]" + "&put_option=overwrite,createdir,migrationsemantics" + "&comment=" + "&keep%5fchecked%5fout=false" + vbLf
byteArray = StringToByteArray(strHeader)
Set stream = CreateObject("ADODB.Stream")
stream.Open
stream.Type = 1 ''adTypeBinary
stream.Write byteArray
Set stream2 = CreateObject("ADODB.Stream")
stream2.Open
stream2.Type = 1 ''adTypeBinary
stream2.LoadFromFile sourcePath
stream2.CopyTo stream, -1
stream.Position = 0
Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
xmlHttp.Open "POST", siteUrl + "/_vti_bin/_vti_aut/author.dll", False
xmlHttp.setRequestHeader "Content-Type", "application/x-vermeer-urlencoded"
xmlHttp.setRequestHeader "X-Vermeer-Content-Type", "application/x-vermeer-urlencoded"
xmlHttp.setRequestHeader "User-Agent", "FrontPage"
xmlHttp.Send stream
If xmlHttp.Status = 200 Then
If InStr(xmlHttp.responseText, "successfully") = 0 Then
MsgBox "ERROR:" & vbCrLf & xmlHttp.responseText
Else
''Checkin
strHeader = "method=checkin+document%3a12.0.4518.1016" + "&service_name=%2f" + "&document_name=" & docName + "&comment=" + checkincomment + "&keep%5fchecked%5fout=false" + vbLf
Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
xmlHttp.Open "POST", siteUrl + "/_vti_bin/_vti_aut/author.dll", False
xmlHttp.setRequestHeader "Content-Type", "application/x-vermeer-urlencoded"
xmlHttp.setRequestHeader "X-Vermeer-Content-Type", "application/x-vermeer-urlencoded"
xmlHttp.setRequestHeader "User-Agent", "FrontPage"
xmlHttp.Send strHeader
End If
End If
If xmlHttp.Status / 100 <> 2 Then
MsgBox "ERROR: status = " & xmlHttp.Status & vbCrLf & xmlHttp.responseText
End If
End Sub
Function UserNameWindows() As String
Dim UserName As String
UserName = Environ("USERNAME")
'return UserName
End Function
No comments:
Post a Comment