asked on

Not Copy Macros

Is there a way to copy a sheet, that has macors in it, without copying those macros to the new workbook?

No. You have to remove the macros after you copy the worksheet.

Here is code to do the work.

The routine below, PurgeCodeInWorkbook, removes all source code from a workbook. The routine will not work on the workbook in which it is located and running. The following sample code illustrates how to save a copy of a workbook and use the routine to purge all VBA code from it.

[Begin Code Segment]

Const FileName = "C:\Full\Path\To\Workbook Copy.xls"
ThisWorkbook.SaveCopyAs FileName
Workbooks.Open FileName, False
PurgeCodeInWorkbook ActiveWorkook
ActiveWorkbook.Save
ActiveWorkbook.Close False

[End Code Segment]

The routine for purging the VBA source code follows below.

[Begin Code Segment]

Public Sub PurgeCodeInWorkbook( _
ByVal TargetWorkbook As Workbook _
)

' Purge all VBA code in the specified workbook. The specified workbook must not
' be in the workbook in which this code is running.

Dim VBComponent As Variant
Dim VBCodeModule As CodeModule

If TargetWorkbook Is ThisWorkbook Then Stop ' Can't delete code in the same workbook

For Each VBComponent In TargetWorkbook.VBProject.VBComponents
Set VBCodeModule = VBComponent.CodeModule
If VBCodeModule.CountOfLines > 0 Then
If VBComponent.Type = 1 Then
TargetWorkbook.VBProject.VBComponents.Remove VBComponent
Else
VBCodeModule.DeleteLines 1, VBCodeModule.CountOfLines
End If
End If
Next VBComponent

End Sub

[End Code Segment]

Kevin

Tom Black

ASKER

I recieved this from you just recently and accepted it as a solution. Once I tried to adapt this to the workbooks I am using I could not get it to work at all.

I am copy a single sheet from a workbook into a new workbook. I did not understand the Targetworkbook and Thisworkbook. How do you drfine those terms and I also recived an object error when I tried the "Dim VBCodeModule As CodeModule" -- Complie Error: User-Defined type not defined

Tom Black

ASKER

I am using Excel 2007

zorvek (Kevin Jones)

Once you have copied the worksheet to the target workbook, you should have an object variable containing a reference to the target workbook. Let's assume it's called TargetWorkbook. The code to purge the code will be:

PurgeCodeInWorkbook TargetWorkbook

This is assuming you have the routing "PurgeCodeInWorkbook" in place which I listed above.

Kevin

zorvek (Kevin Jones)

I just saw the error. Use this code instead:

Public Sub PurgeCodeInWorkbook( _
ByVal TargetWorkbook As Workbook _
)

' Purge all VBA code in the specified workbook. The specified workbook must not
' be in the workbook in which this code is running.

Dim VBComponent As Variant
Dim VBCodeModule As Object

If TargetWorkbook Is ThisWorkbook Then Stop ' Can't delete code in the same workbook

For Each VBComponent In TargetWorkbook.VBProject.VBComponents
Set VBCodeModule = VBComponent.CodeModule
If VBCodeModule.CountOfLines > 0 Then
If VBComponent.Type = 1 Then
TargetWorkbook.VBProject.VBComponents.Remove VBComponent
Else
VBCodeModule.DeleteLines 1, VBCodeModule.CountOfLines
End If
End If
Next VBComponent

End Sub

Kevin

Tom Black

ASKER

Please seee attached Code -- I know it is probably sloppy to you but I am self taught so bare withit please. I still don't understand the TargetWorkbook and ThisWorkbook

Public Order As Worksheet, DGBook As Worksheet, Working As Worksheet
    Public DGOrderCurr As Worksheet, DGOrderPrev As Worksheet, BookOrig As Worksheet
    Public OrderR1 As Long, WorkingR1 As Long, DGOrderCurrR1 As Long, DGOrderPrevR1 As Long, DGBookR1 As Long, BookOrigR1 As Long
    Public OrderR2 As Long, WorkingR2 As Long, DGOrderCurrR2 As Long, DGOrderPrevR2 As Long, DGBookR2 As Long
    Public OrderR3 As Long, WorkingR3 As Long, DGOrderCurrR3 As Long, DGOrderPrevR3 As Long, DGBookR3 As Long
    Public OrderC1 As Long, WorkingC1 As Long, DGOrderCurrC1 As Long, DGOrderPrevC1 As Long, DGBookC1 As Long, BookOrigC1 As Long
    Public OrderC2 As Long, WorkingC2 As Long, DGOrderCurrC2 As Long, DGOrderPrevC2 As Long, DGBookC2 As Long
    Public OrderC3 As Long, WorkingC3 As Long, DGOrderCurrC3 As Long, DGOrderPrevC3 As Long, DGBookC3 As Long
    Public DGOrderPrevR4 As Long, DGOrderPrevC4 As Long, DGOrderPrevR5 As Long, DGOrderPrevC5 As Long
    Public CuttoffDate As Date, BeginDate As Date, ReportDate As Date, PrntA As Range, Days As Integer
    Public EmailSheet As Worksheet, EmailSheetR1 As Long, ws As Worksheet
    Public rs As Range, OutApp As Object, OutMail As Object
    Public VBComponent As Variant


Sub Set_Tabs1()
    
    Set Order = Sheets("New Stores to Order")
    Set DGBook = Sheets("DG CCTV Bookings")
    Set Working = Sheets("Store Working Tab")
    Set DGOrderPrev = Sheets("DG (Vector-New Stores) Prev")
    Set DGOrderCurr = Sheets("DG (Vector-New Stores)")
    Set BookOrig = Sheets("Bookings (Orig)")
    
End Sub
Sub Set_Tabs2()

    Set Order = Sheets("New Stores to Order")
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

End Sub

Sub Check_Orig()

Call Set_Tabs1

    DGOrderPrevR1 = DGOrderCurr.Cells(Rows.Count, 1).End(xlUp).Row
    If DGOrderPrevR1 = 1 Then: Stop
    DGOrderCurrR1 = DGOrderCurr.Cells(Rows.Count, 1).End(xlUp).Row
    If DGOrderCurrR1 = 1 Then: Stop
    BookOrigR1 = BookOrig.Cells(Rows.Count, 1).End(xlUp).Row
    If BookOrigR1 = 1 Then: Stop

End Sub
Sub Compare_Tabs()

Call Set_Tabs1

    DGOrderCurrR5 = DGOrderCurr.Cells(Rows.Count, 1).End(xlUp).Row
    DGOrderCurrC5 = DGOrderPrev.Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
    
    DGOrderCurr.UsedRange.Offset(1, 0).Interior.Pattern = xlNone
    DGOrderPrev.Unprotect
    
' Clear #N/A and Interior Formats
        With DGOrderPrev.UsedRange.Offset(1, 0)
            .Replace What:="#N/A", Replacement:=""
            .Font.ColorIndex = 1
            .Font.Bold = False
        End With
        With DGOrderCurr.UsedRange.Offset(1, 0)
            .Interior.Pattern = xlNone
            .Replace What:="#N/A", Replacement:=""
            .Font.ColorIndex = 1
            .Font.Bold = False
        End With

    For Each rs In DGOrderCurr.UsedRange.Rows
        If rs.Cells(1, 1) <> "" Then
            mr = Application.Match(rs.Cells(1, 1), DGOrderPrev.Range("A:A"), 0)
            If IsError(mr) Then
            rs.Interior.ColorIndex = 35
        Else
        For i = 1 To DGOrderCurrC5
            If rs.Cells(1, i) <> DGOrderPrev.Cells(mr, i) Then
                With rs.Cells(1, i)
                    .Interior.ColorIndex = 3
                    .Font.Name = "Times New Roman"
                    .Font.Bold = True
                    .Font.ColorIndex = 1
                End With
            End If
        Next i
            End If
        End If
    Next rs
    
    DGOrderPrev.Select
    Cells.Select
    Selection.Clear

End Sub
Sub DG_Order_Report()

' No visible changes until complete
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With

Call Set_Tabs1
   
Call Check_Orig

' Delete Named Ranges
    On Error Resume Next
            For Each NameX In ActiveWorkbook.Names
                NameX.Delete
            Next
    On Error GoTo 0
    
' Clear Tabs
    BookOrig.Select
    Sheets(Array("New Stores to Order", "DG CCTV Bookings", "Store Working Tab")).Select
    Cells.Select
    Selection.Clear
    Order.Select
        
Call Compare_Tabs
    
' Copy Originals

        With DGOrderCurr
            DGOrderCurrR1 = .Cells(Rows.Count, 1).End(xlUp).Row
            DGOrderCurrC1 = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
                With .Range(.Cells(1, 1), .Cells(1, DGOrderCurrC1))
                    .Interior.ColorIndex = 15
                    .WrapText = True
                End With
            .Range(.Cells(1, 1), .Cells(DGOrderCurrR1, DGOrderCurrC1)).Copy Working.Cells(1, 1)
        End With
        With BookOrig
            BookOrigR1 = .Cells(Rows.Count, 1).End(xlUp).Row
            BookOrigC1 = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
            .Range(.Cells(1, 1), .Cells(BookOrigR1, BookOrigC1)).Cut DGBook.Cells(1, 1)
        End With
        
    BeginDate = DateSerial(Year(Date), Month(Date), Day(Date) - 14)
    Days = 90
    CuttoffDate = DateSerial(Year(Date), Month(Date), Day(Date) + Days)

    
Call DG_CCTV_Bookings_Tab
    
Call Store_Working_Tab

Call Order_Tab

        For Each ws In Worksheets
            Select Case ws.Name
             
              Case "DG1", "DG2", "Book" ' add names of sheets NOT to open
                Case Else
                    ws.Select
                    ws.Cells(1, 1).Select
                    ActiveWindow.ScrollRow = 1
                    ActiveWindow.ScrollColumn = 1
            End Select
        Next

        With DGOrderCurr
            DGOrderCurrR3 = .Cells(Rows.Count, 1).End(xlUp).Row
            DGOrderCurrC3 = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
            .Range(.Cells(1, 1), .Cells(DGOrderCurrR3, DGOrderCurrC3)).Cut (DGOrderPrev.Cells(1, 1))
        End With
    DGOrderPrev.Protect
    
    Order.Select
    ActiveWorkbook.Save
    
    Order.Copy
    
Call Send_Email

' All visible changes After complete
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    
End Sub


Sub DG_CCTV_Bookings_Tab()

' Clean Up Store CCTV Bookings Tab

Call Set_Tabs1

        With DGBook
            .Cells(1, 1).Clear
            .Range(.Cells(2, 4), .Cells(3, 4)).Clear
            .Cells(1, 4).Value = "Bookings Report"
            .Cells(4, 4).Cut (.Cells(2, 4))
            DGBookR1 = .Cells(Rows.Count, 1).End(xlUp).Row
            DGBookC1 = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
            .Range(.Cells(6, 1), .Cells(DGBookR1, DGBookC1)).Name = "DGBook_Data"
            .Range(.Cells(7, 1), .Cells(DGBookR1, DGBookC1)).Name = "DGBook_Data_Filter"
                With Range("DGBook_Data")
                    .Sort Key1:=.Cells(6, DGBookC1), Order1:=xlAscending, Header:=xlYes
                    .AutoFilter
                    .AutoFilter Field:=DGBookC1, Criteria1:="<>*r Gen*"
                End With
          On Error Resume Next
            .Range("DGBook_Data_Filter").SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .ShowAllData
        
                With Range("DGBook_Data")
                    .Sort Key1:=.Cells(6, DGBookC1), Order1:=xlAscending, Header:=xlYes
                    .AutoFilter Field:=4, Criteria1:="<1000"
                End With
            .Range("DGBook_Data_Filter").SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .ShowAllData
            
                With Range("DGBook_Data")
                    .Sort Key1:=.Cells(6, DGBookC1), Order1:=xlAscending, Header:=xlYes
                    .AutoFilter Field:=6, Criteria1:="=Fire", Operator:=xlOr, _
                                          Criteria2:="=Relo*"
                End With
            .Range("DGBook_Data_Filter").SpecialCells(xlCellTypeVisible).EntireRow.Delete
            .ShowAllData
          On Error GoTo 0
            
            DGBookR2 = .Cells(Rows.Count, 1).End(xlUp).Row
            
            .Range("Q:Q").Insert
            .Range("Q6").Value = "Store #"
                With .Range(.Cells(7, 17), .Cells(DGBookR2, 17))
                    .FormulaR1C1 = "=mid(RC[-1],6,5)*1"
                    .Value = .Value
                    .NumberFormat = "00000"
                End With
            .Range("Q:Q").Cut
            .Range("I:I").Insert
          ' Name Columns
            .Range(.Cells(6, 9), .Cells(DGBookR2, 9)).Name = "Book_Store"
            .Range(.Cells(6, 10), .Cells(DGBookR2, 10)).Name = "Book_Date"
            .Range(.Cells(6, 15), .Cells(DGBookR2, 15)).Name = "Book_Fixture"
            .Range(.Cells(6, 9), .Cells(DGBookR2, 15)).Name = "Book_Lookup"
            .Range("A:B,G:H,M:N,P:U").Delete
            
            ReportDate = Int(Now())
            
            DGBookC2 = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
            .Range("D:D").Cut
            .Range("F:F").Insert
        
         ' Format Booking Table
            .Range(.Cells(6, 1), .Cells(6, DGBookC2)).Font.Bold = True
                With .Range("DGBook_Data")
                    .EntireColumn.AutoFit
                    .Borders.Weight = xlMedium
                    .Borders(xlInsideVertical).Weight = xlThin
                    .Borders(xlInsideHorizontal).Weight = xlThin
                End With
                With .Range(.Cells(6, 1), .Cells(6, DGBookC2))
                    .VerticalAlignment = xlCenter
                    .HorizontalAlignment = xlCenter
                    .Interior.ColorIndex = 34
                    .Borders(xlEdgeBottom).Weight = xlMedium
                End With
            .Range("B:B").ColumnWidth = 12
            .Range("G:G").ColumnWidth = 32

        End With
        
End Sub

Sub Store_Working_Tab()

' Clean Up Store Working Tab

Call Set_Tabs1

'    CuttoffDate = DateSerial(Year(Date), Month(Date), Day(Date) + 90)

        With Working
            WorkingR1 = .Cells(Rows.Count, 1).End(xlUp).Row
            WorkingC1 = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
            .Range(.Cells(1, 1), .Cells(WorkingR1, WorkingC1)).Name = "Working_Data"
                With .Range(.Cells(1, 1), .Cells(WorkingR1, 7))
                    .HorizontalAlignment = xlCenter
                    .EntireColumn.AutoFit
                End With
          On Error Resume Next
                With .Range("Working_Data")
                    .AutoFilter
                    .AutoFilter Field:=12, Criteria1:="=Active"
                    .AutoFilter Field:=WorkingC1 - 3, Criteria1:=">=" & BeginDate, Operator:=xlAnd, _
                                                        Criteria2:="<=" & CuttoffDate
                    .SpecialCells(xlCellTypeVisible).Copy (Order.Cells(6, 1))
                End With
          On Error GoTo 0
            .ShowAllData

        End With
        
End Sub

Sub Order_Tab()

Call Set_Tabs1

        With Order
            .Select
            .Range("B:D").Insert
            .Range("B6").Value = "Booked"
            .Range("C6").Value = "Booked Fixture"
            .Range("D6").Value = "Booked Type"
            .Range("K:L,Q:Q,Y:AA").Delete
            OrderR1 = .Cells(Rows.Count, 1).End(xlUp).Row
            OrderC1 = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
          'Name Data Table
            .Range(.Cells(6, 1), .Cells(6, OrderC1)).Name = "Order_Header"
            .Range(.Cells(6, 1), .Cells(OrderR1, OrderC1)).Name = "Order_Data"
            .Range(.Cells(7, 1), .Cells(OrderR1, OrderC1)).Name = "Order_Data_Filter"
          'Name Columns
            .Range(.Cells(6, 1), .Cells(OrderR1, 1)).Name = "Order_Store"
            .Range(.Cells(6, 2), .Cells(OrderR1, 2)).Name = "Order_Booked"
            .Range(.Cells(7, 2), .Cells(OrderR1, 2)).Name = "Order_Booked_Calc"
            .Range(.Cells(6, 3), .Cells(OrderR1, 3)).Name = "Order_Booked_Fixture"
            .Range(.Cells(7, 3), .Cells(OrderR1, 3)).Name = "Order_Booked_Fixture_Calc"
            .Range(.Cells(6, 4), .Cells(OrderR1, 4)).Name = "Order_Booked_Type"
            .Range(.Cells(7, 4), .Cells(OrderR1, 4)).Name = "Order_Booked_Type_Calc"
            .Range(.Cells(6, 21), .Cells(OrderR1, 21)).Name = "Order_Fixture"
            
                With Range("Order_Booked_Calc")
                    .FormulaR1C1 = "=vlookup(RC[-1],book_lookup,3,false)"
                    .Value = .Value
                    .Replace What:="#N/A", Replacement:=""
                    .NumberFormat = "MM/DD/YY"
                End With
                With Range("Order_Booked_Fixture_Calc")
                    .FormulaR1C1 = "=vlookup(RC[-2],book_lookup,6,false)"
                    .Value = .Value
                    .Replace What:="#N/A", Replacement:=""
                    .NumberFormat = "MM/DD/YY"
                End With
                With Range("Order_Booked_Type_Calc")
                    .FormulaR1C1 = "=vlookup(RC[-3],book_lookup,2,false)"
                    .Value = .Value
                    .Replace What:="#N/A", Replacement:=""
                    .NumberFormat = "General"
                End With
            .Range("A6:J6,L6").EntireColumn.AutoFit
                With .Cells(3, 1)
                    .Value = "DG Order Report"
                    .Font.Bold = True
                    .Font.Size = 12
                End With
                With .Cells(4, 1)
                    .Value = "Processed and Submitted -- " & Application.Text(ReportDate, "MM/DD/YY")
                    .Font.Bold = True
                    .Font.Size = 12
                End With
                With .Cells(2, 10)
                    .Value = "Change"
                    .Font.Bold = True
                    .Font.Size = 12
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Interior.ColorIndex = 3
                End With
                With .Cells(2, 11)
                    .Value = "Indicates a change that has occured form the previous report"
                    .Font.Bold = True
                    .Font.Size = 12
                    .VerticalAlignment = xlCenter
                    .Font.ColorIndex = 3
                End With
                With .Cells(3, 10)
                    .Value = "NEW"
                    .Font.Bold = True
                    .Font.Size = 12
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Interior.ColorIndex = 35
                End With
                With .Cells(3, 11)
                    .Value = "Indicates a Store Number Not on the previous report or Not Booked"
                    .Font.Bold = True
                    .Font.Size = 12
                    .VerticalAlignment = xlCenter
                    .Font.ColorIndex = 1
                End With
                With .Cells(4, 10)
                    .Value = "Review"
                    .Font.Bold = True
                    .Font.Size = 12
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Interior.ColorIndex = 44
                End With
                With .Cells(4, 11)
                    .Value = "Indicates the fixture date has moved out more than " & Days & " days from original"
                    .Font.Bold = True
                    .Font.Size = 12
                    .VerticalAlignment = xlCenter
                    .Font.ColorIndex = 1
                End With
                
           .Range("H:I").ColumnWidth = 8.83
           .Rows("6:6").EntireRow.AutoFit
           
          'Conditional Format Based on Fixture Date
            .Cells(7, 1).Activate
                With .Range("Order_Data_Filter").FormatConditions
                    .Delete
                    .Add Type:=xlExpression, Formula1:="=$C7>($B7+" & Days & ")"
                End With
            .Range("Order_Data_Filter").FormatConditions(.Range("Order_Data_Filter") _
                .FormatConditions.Count).SetFirstPriority
                With .Range("Order_Data_Filter").FormatConditions(1)
                    .Font.Bold = True
                    .Interior.ColorIndex = 44
                    .StopIfTrue = True
                End With
            .Range("Order_Data_Filter").FormatConditions.Add Type:=xlExpression, _
                    Formula1:="=$B7="""""
                With .Range("Order_Data_Filter").FormatConditions(2)
                    .Font.Bold = True
                    .Interior.ColorIndex = 35
                    .StopIfTrue = True
                End With
            .Range("Order_Data_Filter").Sort Key1:=.Range("B6"), Order1:=xlAscending, Header:=xlYes
        End With

End Sub

Sub Send_Email()

' Email Workbook

Call Set_Tabs2
    
    With Order
        OrderR4 = .Cells(Rows.Count, "A").End(xlUp).Row
        OrderC4 = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
        .Range(.Cells(6, 1), .Cells(OrderR1, OrderC1)).Name = "Order_Email_Data"
        .Range(.Cells(7, 1), .Cells(OrderR1, OrderC1)).Name = "Order_Email_Data_Filter"
            With .Range("Order_Email_Data")
                .AutoFilter
                .AutoFilter Field:=3, Criteria1:="="
            End With
    End With

' Clear Report Button and Private Sub
    ActiveSheet.Shapes.Range(Array("Run_Report")).Delete

    ReportDate = Int(Now())
    
' Save Workbook
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Documents and Settings\tlblack\My Documents\Vector Info\Reports 2012\Special Projects 2012\Install Special Projects 2012\DG Templates\DG Order Reports 2012\DG Order Report " & _
            Format(ReportDate, "MMDDYY"), FileFormat:=xlExcel8

' Send Email
            With OutMail
                .To = "tjcline@vectorsecurity.com"
                .CC = "tlblack@vectorsecurity.com"
                .Subject = "DG Order Booking Report Submitted " & Format(ReportDate, "MM/DD/YY")
                .Body = "DG Order Booking Report Submitted " & Format(ReportDate, "MM/DD/YY") & ". If you have any questions, please let me know."
                .Attachments.Add ActiveWorkbook.FullName
                .Send
            End With

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Open in new window

zorvek (Kevin Jones)

Replace the routine Send_Email with this one:

Sub Send_Email()

' Email Workbook

Dim Path As String

Call Set_Tabs2
    
    With Order
        OrderR4 = .Cells(Rows.Count, "A").End(xlUp).Row
        OrderC4 = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
        .Range(.Cells(6, 1), .Cells(OrderR1, OrderC1)).Name = "Order_Email_Data"
        .Range(.Cells(7, 1), .Cells(OrderR1, OrderC1)).Name = "Order_Email_Data_Filter"
            With .Range("Order_Email_Data")
                .AutoFilter
                .AutoFilter Field:=3, Criteria1:="="
            End With
    End With

' Clear Report Button and Private Sub
    ActiveSheet.Shapes.Range(Array("Run_Report")).Delete

    ReportDate = Int(Now())
    
    Path = "C:\Documents and Settings\tlblack\My Documents\Vector Info\Reports 2012\Special Projects 2012\Install Special Projects 2012\DG Templates\DG Order Reports 2012\DG Order Report " & _
            Format(ReportDate, "MMDDYY")
    
' Save Workbook
    ActiveWorkbook.SaveAs Filename:=Path, FileFormat:=xlExcel8
    Dim TargetWorkbook As Workbook
    Set TargetWorkbook = Workbooks.Open(Path & ".xls")
    PurgeCodeInWorkbook TargetWorkbook
    TargetWorkbook.Save
    TargetWorkbook.Close False

' Send Email
            With OutMail
                .To = "tjcline@vectorsecurity.com"
                .CC = "tlblack@vectorsecurity.com"
                .Subject = "DG Order Booking Report Submitted " & Format(ReportDate, "MM/DD/YY")
                .Body = "DG Order Booking Report Submitted " & Format(ReportDate, "MM/DD/YY") & ". If you have any questions, please let me know."
                .Attachments.Add Path & ".xls"
                .Send
            End With

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Open in new window

and include this code in the module:

Public Sub PurgeCodeInWorkbook( _
      ByVal TargetWorkbook As Workbook _
   )

' Purge all VBA code in the specified workbook. The specified workbook must not
' be in the workbook in which this code is running.
   
   Dim VBComponent As Variant
   Dim VBCodeModule As Object
   
   If TargetWorkbook Is ThisWorkbook Then Stop ' Can't delete code in the same workbook
   
   For Each VBComponent In TargetWorkbook.VBProject.VBComponents
      Set VBCodeModule = VBComponent.CodeModule
      If VBCodeModule.CountOfLines > 0 Then
         If VBComponent.Type = 1 Then
            TargetWorkbook.VBProject.VBComponents.Remove VBComponent
         Else
            VBCodeModule.DeleteLines 1, VBCodeModule.CountOfLines
         End If
      End If
   Next VBComponent

End Sub

Open in new window

Kevin

Tom Black

ASKER

I am getting runtime error 1004:

Programmatic access to Visual Basic Project is not trusted

Then if I click debug and try to step thru I get

runtime error 1004:
Method 'VBProject of object_workbook Failed

Aslo what calls up the Public sub to run. I entered it at the bottom fo the original code in the same module.

zorvek (Kevin Jones)

To allow access to a VBA project the "Trust access to Visual Basic Project" option must be checked on (choose the menu command Tools->Macro->Security, navigate to the "Trusted Publishers" tab, and check the "Trust access to Visual Basic Project" check box.) However, sometimes the check box is disabled and cannot be set on or off. The disabling of this checkbox is controlled by a registry entry:

HKEY_LOCAL_MACHINE/Software/Microsoft/Office/[version]/Excel/Security/AccessVBOM

When this key is present the check box is disabled. If the key value is 1 the check box is disabled but always set on. If the key value is zero the check box is always set off. To enable the check box, delete the registry key.

The call is made with this line:

PurgeCodeInWorkbook TargetWorkbook

Kevin

Tom Black

ASKER

Sorry it xtops at line

For Each VBComponent In TargetWorkbook.VBProject.VBComponents

Tom Black

ASKER

Was the code written fairly cleanly so it was easy to follow?

ASKER CERTIFIED SOLUTION

zorvek (Kevin Jones)

membership

This solution is only available to members.

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

Start Free Trial

Tom Black

ASKER

Ok it worked but it emailed the main sheet not the copied sheet. I went back to the directory and all modules and private subs were removed. Now just need to send it rather the full sheet.

zorvek (Kevin Jones)

I don't see how that could have happened. The Attachments method specifically refers to the copy without macros:

.Attachments.Add Path & ".xls"

where Path is set as:

Path = "C:\Documents and Settings\tlblack\My Documents\Vector Info\Reports 2012\Special Projects 2012\Install Special Projects 2012\DG Templates\DG Order Reports 2012\DG Order Report " & _
Format(ReportDate, "MMDDYY")

Kevin

Tom Black

ASKER

Got it to work

Moved TargetWorkbook.Close until afterr the email code!!

Thanks for all your help wish I could give you more points than 500!

Take Care -- Bear

Tom Black

ASKER

Zorvek went way above and beyond to get this resolved wish I could have given 4x the points.

zorvek (Kevin Jones)

That should not have made any difference - but, if it worked, it worked :-)

Kevin