VBA help to email a document

[megha]

The following VBA code working perfectly fine in excel. I need help to convert this code for Microsoft word. I'm looking to do the exact same thing to a form built in word. Can someone please help?


Private Sub CommandButton1_Click()
MsgBox "Please make sure your Outlook is open"
'Working in Excel 2000-2016
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the ActiveSheet to a new workbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With
' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "" & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.to = "***x@gmail.com (***x@gmail.com)"
.CC = ""
.BCC = ""
.Subject = "Waste Collection Request Form"
.Body = ""
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your form has been emailed. Please check your sent item for a copy"
ThisWorkbook.Close savechanges:=False
End Sub

[megha]

can anyone please help me with this?

[macropod]

A little patience might not go astray; it was 4:39am here when you posted. Guess what I was doing then???

As for 'Can someone please help' you might start by saying what you're trying to achieve. After all, a Word document's structure is entirely different to an Excel workbook's structure.

[megha]

I have a form in word. I'm looking for a macro that can do followings:

1) whenever the user complete the form he/she can email it as an attachment by clicking a macro button
2) the original form always remain blank so next user can fill it and email it as an attachment by clicking the button

The code in my first post does all this but that code in built for excel and working fine in excel. i'm looking do same thing in word.

Thank you!

[macropod]

A little time searching previous discussions on your topic wouldn't go astray. See, for example: http://www.vbaexpress.com/forum/showthread.php?46662-Save-document-as-PDF&highlight=Word+document+email

[megha]

Ok this is what i came up with but i'm getting error message "RUN TIME ERROR 424 - OBJECT REQUIRED" and when i hit debug it highlight this item in my code:


TempFileName = "" & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")


Can someone please help me to fix this? Here is my entire code:


Private Sub CommandButton21_Click()
Dim OL As Object
Dim EmailItem As Object
Dim Doc As Document
Dim TempFilePath As String

Dim TempFileName As String

Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument
TempFilePath = Environ$("temp") & "\"

TempFileName = "" & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Doc.SaveAs2 TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum

With EmailItem
.Subject = "P66 Bayway Refinery Waste Collection Request Form"
.Body = "Please see attached form"
.To = ***@gmail.com

'.cc = ""
'.Importance = olImportanceNormal 'Or olImprotanceHigh Or olImprotanceLow
.Attachments.Add Doc.FullName
.Send
End With

Application.ScreenUpdating = True

Set Doc = Nothing
Set OL = Nothing
Set EmailItem = Nothing
MsgBox "Your form has been emailed. Please check your sent item for a copy"
ThisDocument.Close SaveChanges:=False

End Sub

[megha]

I was able to resolved error 424. I am now using the following code but the kill statement is not working. It say "file not found" everything else works fine.


Private Sub CommandButton21_Click()
Dim OL As Object
Dim EmailItem As Object
Dim Doc As Document
Dim TempFilePath As String
Dim TempFileName As String

Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument
TempFilePath = Environ$("temp") & "\"

TempFileName = "" & " " & Format(Now, "dd-mmm-yy h-mm-ss")
Doc.SaveAs2 TempFilePath & TempFileName

With EmailItem
.Subject = ""
.Body = "Please see attached form"
.To = ***@gmail.com

'.cc = ""
'.Importance = olImportanceNormal 'Or olImprotanceHigh Or olImprotanceLow
.Attachments.Add Doc.FullName
.Send
End With

Application.ScreenUpdating = True

Kill TempFilePath & TempFileName

Set Doc = Nothing
Set OL = Nothing
Set EmailItem = Nothing
MsgBox "Your form has been emailed. Please check your sent item for a copy"
ThisDocument.Close SaveChanges:=False

End Sub