7/01/2011

How to move your heavy attached files in a mail to your peronal website

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