PPoinTer
09-10-2013, 03:52 PM
Hello,
I've built / modified a few macros that I want to place on the Home toolbar. I've built a set of macros that work great, and have used the UI editor to attach these to the home toolbar. The issue is that after one of the macros runs, it then disables any of the macros from the file (the macro runs successfully w/o error the first time). Only one macro causes this issue, and I can't figure out why it is doing this. The code for the macro causing the issue is posted below. Thanks in advance.
*****************************************************************
'This macro attaches the selected slide(s) to an email in Outlook
' --------------------------------------------------------------------------------
' Copyright ©1999-2011, Shyam Pillai, All Rights Reserved.
' --------------------------------------------------------------------------------
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
' --------------------------------------------------------------------------------
Sub AttachSelection(Optional control As IRibbonControl)
Dim oPres As Presentation
Dim oSlide As Slide
Dim sIDs As String
Dim sTempFile As String
Dim sFileName As String
Dim iCounter As Integer
'Dim sBadChars As String
Dim ActiveSlideNumber As String
Dim ActiveSlides As SlideRange
Dim wshShell
'On Error Resume Next
'Reset:
'Solicits user input for temp file name
sFileName = ActivePresentation.Name
If sFileName = "" Then Exit Sub
sFileName = CleanFileName(sFileName) & ".pptx"
'Exit the sub if no filename was entered, or cancel was pressed
'If sFileName = ".pptx" Then
' MsgBox "Please enter a valid filename", vbOKOnly, "Error"
' GoTo Reset
'End If
'If InStr(sFileName, "?") > 0 Or InStr(sFileName, "*") > 0 Or InStr(sFileName, "|") > 0 Or InStr(sFileName, "\") > 0 Or InStr(sFileName, ":") > 0 Or InStr(sFileName, "<") > 0 Or InStr(sFileName, ">") > 0 Then
' MsgBox "Error: Cannot save a file using the following characters - Asterisk (*), Vertical bar (|), Backslash (\), Colon (:), Double quotation mark (''), Less than (<), Greater than (>), Question mark (?), Forward slash (/)"
'Exit Sub
'
'End If
'Determines directory for temp file
Set wshShell = CreateObject("WScript.Shell")
sFilePath = wshShell.SpecialFolders("MyDocuments")
'Create a string containing slide IDs of selection
sIDs = ":"
For Each oSlide In ActiveWindow.Selection.SlideRange
sIDs = sIDs & CStr(oSlide.SlideID) & ":"
Next oSlide
'Create path to store dummy file
sTempFile = sFilePath & "\" & sFileName
'Save a copy of the original file
Call ActivePresentation.SaveCopyAs(sTempFile)
'Open the copy
Set oPres = Application.Presentations.Open(sTempFile, False, False, False)
'Search for IDs which do not appear in the ID string and delete those slide
With oPres
For iCounter = .Slides.Count To 1 Step -1
If InStr(1, sIDs, ":" & CStr(.Slides(iCounter).SlideID) & ":") = 0 Then
.Slides(iCounter).Delete
End If
Next iCounter
End With
oPres.Save
oPres.Close
Set ActiveSlides = ActiveWindow.Selection.SlideRange
ActiveSlideNumber = ActiveSlides.Count
'Attaches temp file to Outlook email
'If Outlook is not open this takes a while - may want to consider opening a new instance of outlook for this?
Set oOutlookApp = GetObject("", "Outlook.application")
Set oMessage = oOutlookApp.CreateItem(olMailItem)
With oMessage
.Attachments.Add sTempFile
.Subject = sFileName & " (" & ActiveSlideNumber & " Slide(s))"
.Display
End With
'Delete temp file
Kill sTempFile
End Sub
I've built / modified a few macros that I want to place on the Home toolbar. I've built a set of macros that work great, and have used the UI editor to attach these to the home toolbar. The issue is that after one of the macros runs, it then disables any of the macros from the file (the macro runs successfully w/o error the first time). Only one macro causes this issue, and I can't figure out why it is doing this. The code for the macro causing the issue is posted below. Thanks in advance.
*****************************************************************
'This macro attaches the selected slide(s) to an email in Outlook
' --------------------------------------------------------------------------------
' Copyright ©1999-2011, Shyam Pillai, All Rights Reserved.
' --------------------------------------------------------------------------------
' You are free to use this code within your own applications, add-ins,
' documents etc but you are expressly forbidden from selling or
' otherwise distributing this source code without prior consent.
' This includes both posting free demo projects made from this
' code as well as reproducing the code in text or html format.
' --------------------------------------------------------------------------------
Sub AttachSelection(Optional control As IRibbonControl)
Dim oPres As Presentation
Dim oSlide As Slide
Dim sIDs As String
Dim sTempFile As String
Dim sFileName As String
Dim iCounter As Integer
'Dim sBadChars As String
Dim ActiveSlideNumber As String
Dim ActiveSlides As SlideRange
Dim wshShell
'On Error Resume Next
'Reset:
'Solicits user input for temp file name
sFileName = ActivePresentation.Name
If sFileName = "" Then Exit Sub
sFileName = CleanFileName(sFileName) & ".pptx"
'Exit the sub if no filename was entered, or cancel was pressed
'If sFileName = ".pptx" Then
' MsgBox "Please enter a valid filename", vbOKOnly, "Error"
' GoTo Reset
'End If
'If InStr(sFileName, "?") > 0 Or InStr(sFileName, "*") > 0 Or InStr(sFileName, "|") > 0 Or InStr(sFileName, "\") > 0 Or InStr(sFileName, ":") > 0 Or InStr(sFileName, "<") > 0 Or InStr(sFileName, ">") > 0 Then
' MsgBox "Error: Cannot save a file using the following characters - Asterisk (*), Vertical bar (|), Backslash (\), Colon (:), Double quotation mark (''), Less than (<), Greater than (>), Question mark (?), Forward slash (/)"
'Exit Sub
'
'End If
'Determines directory for temp file
Set wshShell = CreateObject("WScript.Shell")
sFilePath = wshShell.SpecialFolders("MyDocuments")
'Create a string containing slide IDs of selection
sIDs = ":"
For Each oSlide In ActiveWindow.Selection.SlideRange
sIDs = sIDs & CStr(oSlide.SlideID) & ":"
Next oSlide
'Create path to store dummy file
sTempFile = sFilePath & "\" & sFileName
'Save a copy of the original file
Call ActivePresentation.SaveCopyAs(sTempFile)
'Open the copy
Set oPres = Application.Presentations.Open(sTempFile, False, False, False)
'Search for IDs which do not appear in the ID string and delete those slide
With oPres
For iCounter = .Slides.Count To 1 Step -1
If InStr(1, sIDs, ":" & CStr(.Slides(iCounter).SlideID) & ":") = 0 Then
.Slides(iCounter).Delete
End If
Next iCounter
End With
oPres.Save
oPres.Close
Set ActiveSlides = ActiveWindow.Selection.SlideRange
ActiveSlideNumber = ActiveSlides.Count
'Attaches temp file to Outlook email
'If Outlook is not open this takes a while - may want to consider opening a new instance of outlook for this?
Set oOutlookApp = GetObject("", "Outlook.application")
Set oMessage = oOutlookApp.CreateItem(olMailItem)
With oMessage
.Attachments.Add sTempFile
.Subject = sFileName & " (" & ActiveSlideNumber & " Slide(s))"
.Display
End With
'Delete temp file
Kill sTempFile
End Sub