Macro on toolbar only allowed to run once

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.

[VBA]*****************************************************************

'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[/VBA]

Is that really Shyam's original code (I'd be surprized) or did you adapt it. Can you post a link to the original.

Quote:

---

Originally Posted by John Wilson

Is that really Shyam's original code (I'd be surprized) or did you adapt it. Can you post a link to the original.

---

I've modified it. I haven't taken the time to fully clean it to my exact liking until I've figured out the issue (for example, I've only commented out the filename correction for the time being). I've placed the original text in the stead of this macro however, and the same problem still occurred.

You know, Shyam is a good friend and an excellent coder. I really couldn't see him making some of the mistakes in the code you posted.

In you other code are there PUBLIC or Global variables? Any untrapped error will kill these and cause problems.

See if this improves things or at least gives a start point.

Code:

---

Sub AttachSelection()
Dim oPres As Presentation
Dim oSlide As Slide
Dim sIDs As String
Dim sTempFile As String
Dim sFileName As String
Dim sFilePath As String
Dim iCounter As Integer
Dim ActiveSlideNumber As Long
Dim oOutlookApp As Object
Dim olMailItem As Variant

sFileName = ActivePresentation.Name

If ActivePresentation.Path = "" Then  ' not saved
MsgBox "Save me"
Exit Sub
End If

'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 - NOT the same path as open presentation!
sTempFile = Environ("TEMP") & "\" & sFileName

'Save a copy of the original file
Call ActivePresentation.SaveCopyAs(sTempFile)

'Open the copy
Set oPres = Application.Presentations.Open(FileName:=sTempFile, WithWindow:=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

ActiveSlideNumber = oPres.Slides.Count
oPres.Save
oPres.Close ' note close AFTER checking selected slides!

'Attaches temp file to Outlook email
'If Outlook is not open this takes for ever - you want to  open a new instance of outlook in this case?
err.Clear
On Error Resume Next
Set oOutlookApp = GetObject(Class:="Outlook.application")
If err <> 0 Then ' outlook is closed
Set oOutlookApp = CreateObject("Outlook.application")
End If
On Error GoTo err
With oOutlookApp.CreateItem(olMailItem)
.Attachments.Add sTempFile
.Subject = sFileName & " (" & ActiveSlideNumber & " Slide(s))"
.Display
End With

'Delete temp file
Kill sTempFile
Exit Sub
err:
MsgBox err.Description

End Sub

---

Is there a link to Shyam's original code?

John,

Thanks for this. I appreciate you taking the time to clean the code. It's true that Shyam's code was almost definitely much better than what I posted (I make no claims about my abilities) and I should have removed or at least modified his copyright notice at the top. I don't have the original link to his code since I received the code snippets from someone else who probably also made some minor modifications as well.

Unfortunately after swapping in your code and then removing all the global variables, the same issue is still occurring.

On another note, when I run the below sub (another sub from the same module), everything continues to run fine.

Thanks for your continued help.

Code:

---

********************************************

Sub AttachFullDoc(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 wshShell


'Forms temp file name
sFileName = ActivePresentation.Name


If sFileName = "" Then Exit Sub


sFileName = CleanFileNameFullDoc(sFileName)


'Determines directory for temp file
Set wshShell = CreateObject("WScript.Shell")
sFilePath = wshShell.SpecialFolders("MyDocuments")


'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)


'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
      .Display
End With


'Delete temp file
Kill sTempFile


End Sub

---

Without seeing all of the code modules there's not a lot I can do.

The second code module won't run at all here. None of our production PCs allow undeclared variables (oOutlookApp, oMessage, olMailItem, sFilePath) and CleanFileNameFullDoc must be a custom function (which obviously I don't have).

It can't be a good idea to save the temp copy with (possibly) the exact same path as the main presentation, This is why I accessd the TEMP dir.

If sFileName = "" Then Exit Sub --- sFileName can NEVER be "" so this is not needed, You do need to check that the file has been saved though otherwixe the name will be PresentationX (without .pptx) and error later.

If I fix the above and comment out the CleanFile function I get a run time error at Kill sTempFile (This is because it is still open and cannot be killed.)

If you want to send me the whole addin as a ppam I can take a look (probably next week)

john AT SIGN PPTAlchemy.co.uk

This runs multiple time without error here but this doesn't mean it doesn't conflict with any other code

Code:

---

Sub TestMe()
Dim oPres As Presentation
Dim oSlide As Slide
Dim sTempFile As String
Dim sFileName As String
Dim iCounter As Integer
Dim oMessage As Variant
Dim olMailItem As Variant
Dim sFilePath As String
Dim oOutlookApp As Object

If ActivePresentation.Path = "" Then
MsgBox "You need to save me!"
Exit Sub
End If

' if saved not up to date then save
If ActivePresentation.Saved = False Then ActivePresentation.Save
sFileName = ActivePresentation.Name
'remove old tags
For Each oSlide In ActivePresentation.Slides
oSlide.Tags.Delete ("SEL")
Next oSlide

'add selected tag
For Each oSlide In ActiveWindow.Selection.SlideRange
oSlide.Tags.Add "SEL", "YES"
Next oSlide

ActivePresentation.SaveCopyAs (Environ("TEMP") & "\" & sFileName)
Set oPres = Presentations.Open(Environ("TEMP") & "\" & sFileName)
sTempFile = oPres.FullName
For iCounter = oPres.Slides.Count To 1 Step -1
If oPres.Slides(iCounter).Tags("SEL") <> "YES" Then oPres.Slides(iCounter).Delete
Next iCounter


'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(Class:= "Outlook.application")
Set oMessage = oOutlookApp.CreateItem(olMailItem)
With oMessage
.Attachments.Add sTempFile
.Subject = sFileName
.Display
End With

oPres.Saved = True
oPres.Close
'Delete temp file
Kill sTempFile

End Sub

---