• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 300
  • Last Modified:

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

0
Cartillo
Asked:
Cartillo
  • 11
  • 7
1 Solution
 
SiddharthRoutCommented:
Do you want the attached copy not to have any VBA code?

Sid
0
 
CartilloAuthor Commented:
Hi Sid,

You're right.
0
 
SiddharthRoutCommented:
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

0
VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

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

Give me few moments.

Sid
0
 
SiddharthRoutCommented:
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
0
 
CartilloAuthor Commented:
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
0
 
SiddharthRoutCommented:
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
0
 
CartilloAuthor Commented:
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".  
0
 
SiddharthRoutCommented:
Ah I see why. Giveme a short while. Lemme have my dinner quickly :)

Sid
0
 
SiddharthRoutCommented:
Try this file now.

Sid
SendEmail.xls
0
 
CartilloAuthor Commented:
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.
0
 
SiddharthRoutCommented:
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
0
 
CartilloAuthor Commented:
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
0
 
SiddharthRoutCommented:
It didn't in my case.It works just fine. :)

Please see screencast.

Sid
SiddharthRout-447218.flv
0
 
CartilloAuthor Commented:
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?
0
 
SiddharthRoutCommented:
Yes. Gimme me few moments.

Sid
0
 
SiddharthRoutCommented:
Try this

Sid
SendEmail.xls
0
 
CartilloAuthor Commented:
Hi Sid,

Thanks a lot for the solution given.
0

Featured Post

NFR key for Veeam Agent for Linux

Veeam is happy to provide a free NFR license for one year.  It allows for the non‑production use and valid for five workstations and two servers. Veeam Agent for Linux is a simple backup tool for your Linux installations, both on‑premises and in the public cloud.

  • 11
  • 7
Tackle projects and never again get stuck behind a technical roadblock.
Join Now