asked on

Attachment without script

Hi Experts,

I would like to request Experts help to add additional function in the attached script. How to prevent the email attached copy doesn’t extract any VBA codes in the sheet from the source. Hope this is possible.

Function SendMsg(strSubject As String, _
                   strBody As String, _
                   strTO As String, _
                   Optional strDoc As String, _
                   Optional strCC As String, _
                   Optional strBCC As String)
       
    Dim oLapp
    Dim oItem
    Dim myattachments
    Dim fs As String
    
    Set oLapp = CreateObject("Outlook.Application")
    Set oItem = oLapp.CreateItem(olMailItem)
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets("Tracker").Copy
    ThisWorkbook.Sheets("Tracker").Range("A:D").Copy
    ActiveSheet.Range("A:D").PasteSpecial xlPasteValues
    Call deleteButton2
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Sheets("Tracker").Cells(1, "i") & "_" & Sheets("Tracker").Cells(5, "I") & "Update @" & Format(Sheets("Tracker").Range("J1").Value, "hh'mm'ss") & ".xls", FileFormat:=-4143
      
    Application.DisplayAlerts = True
    fs = ActiveWorkbook.FullName
    ActiveWorkbook.Close
   oItem.Subject = strSubject

    addr1 = "test@gmail.com.my"
   

    oItem.To = addr1 + ";" + addr2

    oItem.CC = strCC
   
    oItem.BCC = strBCC
    'oItem.BodyFormat = olFormatHTML
    oItem.htmlbody = strBody
    oItem.Importance = olImportanceHigh
    oItem.attachments.Add fs
'
  
   oItem.display 'send
   Kill fs
   
    Set oLapp = Nothing
    Set oItem = Nothing
       
End Function

Open in new window

SiddharthRout

Do you want the attached copy not to have any VBA code?

Sid

Cartillo

ASKER

Hi Sid,

You're right.

SiddharthRout

UNTESTED

I just wrote this in VBA Editor and it is not tested. let me know if you get any error. Please set a reference to the "Microsoft Visual Basic For Applications Extensibility" from VBA Menu Tools>References.

Sid

Function SendMsg(strSubject As String, strBody As String, strTO As String, _
Optional strDoc As String, Optional strCC As String, Optional strBCC As String)
    Dim oLapp, oItem, myattachments, fs As String
    
    Set oLapp = CreateObject("Outlook.Application")
    Set oItem = oLapp.CreateItem(olMailItem)
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets("Tracker").Copy
    ThisWorkbook.Sheets("Tracker").Range("A:D").Copy
    ActiveSheet.Range("A:D").PasteSpecial xlPasteValues
    Call deleteButton2
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Sheets("Tracker").Cells(1, "i") _
    & "_" & Sheets("Tracker").Cells(5, "I") & "Update @" & _
    Format(Sheets("Tracker").Range("J1").Value, "hh'mm'ss") & ".xls", FileFormat:=-4143
      
    Application.DisplayAlerts = True
    fs = ActiveWorkbook.FullName
    
    '~~> Delete All VBA Code
    DeleteSheetEventCode fs
    
    ActiveWorkbook.Close
    oItem.Subject = strSubject

    addr1 = "test@gmail.com.my"
    oItem.To = addr1 + ";" + addr2
    oItem.CC = strCC
    oItem.BCC = strBCC
    'oItem.BodyFormat = olFormatHTML
    oItem.htmlbody = strBody
    oItem.Importance = olImportanceHigh
    oItem.attachments.Add fs
   oItem.display 'send
   Kill fs
    Set oLapp = Nothing
    Set oItem = Nothing
End Function

Sub DeleteSheetEventCode(xlsFile As String)
    Dim sSheet As Worksheet, strName As String
    Dim wb As Workbook
    
    Set wb = Workbooks.Open(xlsFile)
    
    For Each sSheet In wb.Sheets
        strName = sSheet.CodeName
        With wb.VBProject.VBComponents(strName).CodeModule
            .DeleteLines 1, .CountOfLines
        End With
    Next sSheet
    wb.Close savechanges:=True
End Sub

Open in new window

SiddharthRout

Oops missed something else, Deleting the workbook and the module code.

Give me few moments.

Sid

SiddharthRout

Try this

Function SendMsg(strSubject As String, strBody As String, strTO As String, _
Optional strDoc As String, Optional strCC As String, Optional strBCC As String)
    Dim oLapp, oItem, myattachments, fs As String
    
    Set oLapp = CreateObject("Outlook.Application")
    Set oItem = oLapp.CreateItem(olMailItem)
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets("Tracker").Copy
    ThisWorkbook.Sheets("Tracker").Range("A:D").Copy
    ActiveSheet.Range("A:D").PasteSpecial xlPasteValues
    Call deleteButton2
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Sheets("Tracker").Cells(1, "i") _
    & "_" & Sheets("Tracker").Cells(5, "I") & "Update @" & _
    Format(Sheets("Tracker").Range("J1").Value, "hh'mm'ss") & ".xls", FileFormat:=-4143
      
    Application.DisplayAlerts = True
    fs = ActiveWorkbook.FullName
    
    '~~> Delete All VBA Code
    DeleteAllCode fs
    
    ActiveWorkbook.Close
    oItem.Subject = strSubject

    addr1 = "test@gmail.com.my"
    oItem.To = addr1 + ";" + addr2
    oItem.CC = strCC
    oItem.BCC = strBCC
    'oItem.BodyFormat = olFormatHTML
    oItem.htmlbody = strBody
    oItem.Importance = olImportanceHigh
    oItem.attachments.Add fs
   oItem.display 'send
   Kill fs
    Set oLapp = Nothing
    Set oItem = Nothing
End Function

'~~> Courtesy http://www.cpearson.com/excel/vbe.aspx
Sub DeleteAllCode(xlsFile As String)
    Dim wb As Workbook
    Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponent
    Dim CodeMod As VBIDE.CodeModule
    
    Set wb = Workbooks.Open(xlsFile)
    
    Set VBProj = wb.VBProject
    
    For Each VBComp In VBProj.VBComponents
        If VBComp.Type = vbext_ct_Document Then
            Set CodeMod = VBComp.CodeModule
            With CodeMod
                .DeleteLines 1, .CountOfLines
            End With
        Else
            VBProj.VBComponents.Remove VBComp
        End If
    Next VBComp

    wb.Close savechanges:=True
End Sub

Open in new window

Sid

Cartillo

ASKER

Hi,

I have attached the workbook that I’ve used for this code. Showing an error message after running the code in Box Tracker sheet. This mainly because the copied file still caring the source VBA code. Please assist.

SendEmail.xls

SiddharthRout

Cartillo: It worked for me :)

You missed the part from ID: 35438700 which says

Please set a reference to the "Microsoft Visual Basic For Applications Extensibility" from VBA Menu Tools>References.

Sid

Cartillo

ASKER

Hi Sid,

Have tested, it still show error as "sub or function not defined" at "UpdateValues". The error message was highlighted at the copy of the workbook".

SiddharthRout

Ah I see why. Giveme a short while. Lemme have my dinner quickly :)

Sid

SiddharthRout

Try this file now.

Sid
SendEmail.xls

Cartillo

ASKER

Hi Sid,

Thanks for the WB. Any idea why the excel has stopped working and request for close program after the email sent out? i've tried few times and the Excel continuously crashing.

SiddharthRout

Have you made any changes to the code?

I just tried it and after the mail was sent, excel asked if I wanted to save changes to the file. I clicked no and excel exited peacefully :)

Sid

Cartillo

ASKER

Hi Sid,

Attached my original workbook that I've used. The excel crashed after pop up message "do you want to save the changes you made to SendEmail.xls?" The ID and Password for userform is "test".
SendEmail.xls

SiddharthRout

It didn't in my case.It works just fine. :)

Please see screencast.

Sid
SiddharthRout-447218.flv

Cartillo

ASKER

Hi Sid,

The crash takes place after I select "Yes", is that possible to prevent "do you want to save the changes you made to SendEmail.xls?" pop up alert?

SiddharthRout

Yes. Gimme me few moments.

Sid

ASKER CERTIFIED SOLUTION

SiddharthRout

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

Cartillo

ASKER

Hi Sid,

Thanks a lot for the solution given.