Private Sub CommandButton5_Click()
'Run macro to trigger extract and save Recommendation sheet as separate Excel file
'-----------------------------------------------------
'Declare variables
'-----------------------------------------------------
Dim wbNewBook As Workbook
Dim fName As Variant
Dim sourceWB As String
Dim DGSSPkgNo As String
Dim Alert As String
Const pw As String = "delpdgsskey"
'---------------------------------------------------------
'Initialize variables for storing Buyer Input information
'---------------------------------------------------------
DGSSPkgNo = Sheets("Project Header Sheet - PC").Cells(7, 3).Value
fName = "C:\LeanDGSS\" & DGSSPkgNo & "_LeanWksht_SN"
Application.EnableEvents = False
On Error GoTo Terminate
'*************************************************************
'Prompt the user for a file name, and then saves the workbook
'*************************************************************
If DGSSPkgNo = "" Then
' Define message
Alert = MsgBox("The DGSS Project # must be entered" & _
vbCrLf & "into the Project Header Sheet prior to Export", vbOKOnly, "Warning!")
Application.EnableEvents = True
Exit Sub
Else
ThisWorkbook.Worksheets("Recommended Supplier Data_SN").Copy
ActiveWorkbook.SaveAs Filename:=fName
End If
Application.EnableEvents = True
'Call Module2 Procedure to remove VBA Components
ActiveWorkbook.Sheets("Recommended Supplier Data_SN").Unprotect pw
Dim objDocument As Workbook
Set objDocument = ActiveWorkbook
Call RemoveAllMacros(objDocument)
Exit Sub
Terminate:
MsgBox "Error occurred: Verify file does not already exist in file path"
End Sub
'-----------------------------------------------------
Public Sub RemoveAllMacros(objDocument As Object)
Dim i As Long, l As Long
If objDocument Is Nothing Then Exit Sub
i = 0
On Error Resume Next
i = objDocument.VBProject.VBComponents.Count
On Error GoTo 0
If i < 1 Then ' no VBComponents or protected VBProject
MsgBox "The VBProject in " & objDocument.Name & _
" is protected or has no components!", _
vbInformation, "Remove All Macros"
Exit Sub
End If
With objDocument.VBProject
For i = .VBComponents.Count To 1 Step -1
On Error Resume Next
.VBComponents.Remove .VBComponents(i)
' delete the component
On Error GoTo 0
Next i
End With
With objDocument.VBProject
For i = .VBComponents.Count To 1 Step -1
l = 1
On Error Resume Next
l = .VBComponents(i).CodeModule.CountOfLines
.VBComponents(i).CodeModule.DeleteLines 1, l
' clear lines
On Error GoTo 0
Next i
End With
End Sub
|