Adding event code to checkbox in PowerPoint VBA - vba

I am developing a PowerPoint 2010 deck that presents the user with a series of pages containing one statement, one checkbox (built from a label element to enable changing the size of the checkbox) and forward/back arrows on each page.
Since this will be used on numerous projects with varying numbers of pages I am building the “deck” dynamically using PowerPoint VBA to construct the pages dynamically from an Excel spreadsheet containing the list of individual statements.
I have been able to write the VBA code to open the Excel file, read the statements into an array in PowerPoint and construct the appropriate number of pages with all of the elements on the page. To this point everything works fine. Where I am having difficulty is in assigning the click action to the checkbox.
Here is the code that is called by the page building routine to insert the checkbox (obviously there is more code prior to this for accessing the Excel file, creating the pages and adding the “statement” text boxes...all of which works):
Sub AddSelectBox(Index As Integer, pptBuildingSlide As Slide)
'Add Checkbox
With pptBuildingSlide.Shapes.AddOLEObject(Left:=342, Top:=294, Width:=42, Height:=42, ClassName:="Forms.Label.1")
.Name = "label" & Index
.OLEFormat.Object.Font.Name = "Wingdings 2"
.OLEFormat.Object.Font.Charset = "2"
.OLEFormat.Object.Caption = "£"
.OLEFormat.Object.Font.Size = 40
End With
'Add Checkbox Click Code
'(CODE FOR ADDING CLICK EVENT TO EACH BOX GOES HERE)
End Sub
The checkbox on each page has a discreet name keyed to the page number (e.g. Label1, Label2, etc.). I need to add the following code to each checkbox on each page to toggle the checkmark so later in the program I can see which were checked by reading the “caption” attributes. (The font is set to “Wingdings 2” to give a blank box and a checked box on click)
Private Sub Label1_Click()
If Label1.Caption = "£" Then
Label1.Caption = "R"
Else
Label1.Caption = "£"
End If
End Sub
I have searched the web looking for any references to add event code dynamically and found a number of examples (e.g. Assign on-click VBA function to a dynamically created button on Excel Userform) but almost all are for Excel or Access. I should point out that coding is “not my day job” and I have managed to get this far reading “Mastering VBA for Office 2003” and web searching…so my ability to translate those examples to PowerPoint has come up short. Thanks for any help you can offer.
5/29 Additional information:
I came across the .CreateEventProc method as a way to write code into VBA. The example I found was written for Excel at this site. I've gotten this far with it (the message box code would be replaced with the click code but I was just using this for testing to avoid introducing other errors)...
Sub CreateEventProcedure()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim LineNum As Long
Const DQUOTE = """" ' one " character
Set VBProj = ActivePresentation.VBProject
Set VBComp = VBProj.VBComponents(Slides(1))
Set CodeMod = VBComp.CodeModule
With CodeMod
LineNum = .CreateEventProc("Click", "Label1")
LineNum = LineNum + 1
.InsertLines LineNum, " MsgBox " & DQUOTE & "Hello World" & DQUOTE
End With
End Sub
...but get a "Compile Error: Sub or Function not defined" at (slides(1)). Any help cleaning it up (if it is in fact an appropriate solution) would be appreciated.

Do you have to use a label? (I understand the size thing but you can maybe add a shape which would be easier.)
Something based on:
This can only work if you allow access to the VBE in Security (cannot be done in code)
Sub makeBox()
Dim strCode As String
With ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRectangle, 10, 10, 20, 20)
.Fill.Visible = False
.Line.Visible = False
With .TextFrame.TextRange.Font
.Name = "Wingdings 2"
.Size = 40
.Color.RGB = vbBlack
End With
.TextFrame.TextRange = "£"
With .ActionSettings(ppMouseClick)
.Action = ppActionRunMacro
.Run = "chex"
End With
End With
strCode = "Sub chex(oshp As Shape)" & vbCrLf & "If oshp.TextFrame.TextRange =" & Chr(34) & "£" & Chr(34) & "Then" _
& vbCrLf & "oshp.TextFrame.TextRange = " & Chr(34) & "R" & Chr(34) & vbCrLf _
& "Else" & vbCrLf & "oshp.TextFrame.TextRange =" & Chr(34) & "£" & Chr(34) & vbCrLf & "End If" & vbCrLf & "End Sub"
With ActivePresentation.VBProject.VBComponents.Add(vbext_ct_StdModule)
.CodeModule.AddFromString (strCode)
End With
End Sub

Related

Inserting text from VBA UserForm textbox into part of a string

I'm new to VBA and hoping someone could help, if this might even be possible.
A date will be manually added by the user into UserForm TEXTBOX1 which will be placed at a bookmark in the document.
.Bookmarks("BOOKMARK1").Range _
.InsertBefore TEXTBOX1
I have option buttons for the user to select, which will place specific text (depending on the button selected) into the document as follows:
Private Sub OptionButton2_Click()
If Me.OptionButton2.Value = True Then
Set oRng = ActiveDocument.Bookmarks("BOOKMARK2").Range
oRng.Text = "EXAMPLE SENTENCE 1" & Chr(11) & Chr(9) & _
"EXAMPLE SENTENCE 2" & Chr(11) & _
"EXAMPLE SENTENCE 3" & vbNewLine & " "
ActiveDocument.Bookmarks.Add "BOOKMARK2", oRng
End If
End Sub
I am trying to get the date that was entered in TEXTBOX1 to appear at the end of the sentence of EXAMPLE SENTENCE 2 before the & CHR(11) &. Can anybody please help with this? Thank you!
I've tried numerous online searches to find the answer for my problem but haven't come across anything so far unfortunately.
"EXAMPLE SENTENCE 2" & TEXTBOX1.Text & Chr(11)

VBA macro for printing is having performance issues

I have a subroutine in an Access db that takes the active Word document and sends the first of every n pages to one printer, and the rest to another. The macro works, but it runs progressively slower with each loop. So far it's taken 1h 40m to print 300 pages (100 recipients, 3 pages each).
Anyone out there know how I can speed things up?
Here's an example of the typical params being passed in: cmdPrintStart(3, 1, 247, "\Main", "\Letterhead")
Public Sub cmdPrintStart(tbPageCount As Long, tbStart As Long, tbEnd As Long, Printer1 As String, Printer2 As String)
On Error GoTo Exit_Handler
Dim wApp As Word.Application
SetWordApp wApp 'This sub sets wApp to an instance of Word, or creates one if none is found.
With wApp.ActiveDocument
Dim DefaultPrinter As String, i As Long
DefaultPrinter = ActivePrinter
For i = tbStart To tbEnd
Debug.Print = "Printing recipient " & i & " of " & (tbStart - tbEnd + 1) & "..."
'Switch active printer and print first page of section
ActivePrinter = Printer1
.PrintOut Range:=wdPrintFromTo, From:="p1s" & i, To:="p1s" & i
'Switch active printer and print the rest of the section
ActivePrinter = Printer2
.PrintOut Range:=wdPrintFromTo, From:="p2s" & i, To:="p" & tbPageCount & "s" & i
Next i
End With
ActivePrinter = DefaultPrinter
Exit_Handler:
If Err Then
MsgBox "Unexpected error #" & Str(Err.Number) & " occurred: " & Err.Description, vbCritical, "Well shoot."
Debug.Print = "Printed up to recipient " & i & " before encountering an error."
Else
Debug.Print = "All done! Printed recipients " & tbStart & " to " & tbEnd & "."
End If
End Sub
Further info:
The purpose is to send page 1 of each section in a mail merge document to a tray with letterhead paper, and the other pages to normal paper, printed in collated order. Surprisingly, there doesn't seem to be anything in Word that allows you to do this.
The active document is a post-merged document. If it will improve performance, I can try writing a sub to print from the mail merge template with the connected data source instead.
Thanks in advance for your help.
I'm just taking a wild guess here: does each loop open a new instance of Word in memory, with the result that after many loop executions you're running out of memory? Maybe try dereferencing your Word object at the end of each loop, something like
wApp.Close
Set wApp = nothing
I don't know that it will help but it surely can't hurt.

Indent list item of bulleted list in table in Outlook WordEditor

I'm trying to compose an email with Outlook VBA with data from an Excel sheet.
I pasted a table from Excel into the mail and now want to format some cells as a bulleted list inside the table.
Now I need to format the text of the cell e.g. as a bulleted list.
This works with this code:
Dim currentCell As Variant
currentCell = wdDoc.Tables(1).Cell(2, 2)
currentCell.ListFormat.ApplyBulletDefault
How would I format the text in the Cell(2,2) as a bulleted list with multiple indentations?
When I use currentCell.ListFormat.ListIndent the whole cell shifts to the left, not just the list.
This is the structure I am looking for
Not sure how this works when you're in Outlook, but in Word you would need to create a ListTemplate with the relevant bullet style layout, then apply it. Something like this:
Const bulletLTName As String = "mybullet"
With ActiveDocument
' Unless you are always creating new documents, you might
' need to verify that mybullet doesn't exist and delete then recreate,
' or modify. Not done here.
With .ListTemplates.Add(OutlineNumbered:=False, Name:=BulletLTName)
With .ListLevels(1)
.NumberFormat = "-"
' If you need to modify the bullet font, you can do it
' like this...
With .Font
.Name = "<whatever font name you want to use>"
.Size = 10 ' etc.
End With
' You can modify other layout properties - best to
' look at Word's object model, but for example
.NumberPosition = 0
.TabPosition = 10
.TextPosition = 10 ' and so on.
End With
End With
With .Tables(1).Cell(2, 2).Range
.Text = "text"
.ListFormat.ApplyListTemplate .Document.ListTemplates(bulletLTName)
End With
End With
Although it does function, I would try to avoid defining currentCell as a Variant because it makes the code less obvious (e.g. it's not obvious that, as written, currentCell is a Word Range and not a Word Cell).
This VBA function creates a mail and adds a bullet list in the mail body.
Now you just need to replace the text variable with the data from the cells
Sub send()
Dim objOutlook As Object
Dim objMail As Object
Dim text As String
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
text = "This is a summary" & Chr(10) & _
Chr(149) & " First point" & Chr(10) & _
Chr(149) & " Second point" & Chr(10) & _
Chr(149) & " Last point"
With objMail
.To = "name#domain.de"
.Subject = "Subject"
.Body = text
.Display
End With
End Sub
If you want to add a bullet list into one cell you can use the same method, e.g. the below code adds the list into the current active cell:
Sub Bullets()
Text = "This is a summary" & Chr(10) & _
Chr(149) & " First point" & Chr(10) & _
Chr(149) & " Second point" & Chr(10) & _
Chr(149) & " Last point"
ActiveCell.Value = Text
End Sub

VBA execute code in string

I am trying to execute vba code that is inside a string WITHOUT writting the code in a temp file.
For exemple :
Dim code As String
code = "n = 0 : e_i_e = 0 : For e_i_e = 0 To 100 : n+=1 : Next"
I have tried Eval, Evaluate, Run, executeGlobal and adding a new module with
Set VBComp = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule)
VBComp.Name = "NewModule"
Set VBCodeMod = ThisWorkbook.VBProject.VBComponents("NewModule").CodeModule
With VBCodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, _
"Sub MyNewProcedure()" & Chr(13) & _
code & Chr(13) & _
"End Sub"
End With
Application.Run "MyNewProcedure"
but all of these are returning errors ='(.
Thank you !
You cannot break in code that's been generated after you've compiled your project, so you need to make sure you build that dynamic module with valid, compilable code.
You know before you hit that F5 button that your code is going to look like this:
Sub MyNewProcedure()
n = 0 : e_i_e = 0 : For e_i_e = 0 To 100 : n+=1 : Next
End Sub
Why not just take that snippet and paste it somewhere and see what the VBE complains about?
Wow. See, this is why cramming half a dozen instructions on the same line of code is a bad idea - if it was one instruction per line you wouldn't be wondering which one is broken.
As was already mentioned, n += 1 is not VBA syntax (it's not specifically C# syntax either); incrementing a value in VBA needs to access the current value, so n = n + 1.
It's not clear where n and e_i_e are coming from. If both are locals, then your procedure accomplishes essentially nothing. If n is declared outside MyNewProcedure, then you should consider passing it as a ByRef parameter, or better, leaving it out completely and making a Function with the result of which the calling code assigns n to.
Sub MyNewProcedure(ByRef n As Long)
Dim i As Long
For i = 0 To 100
n = i
Next
End Sub
Which boils down to:
Function MyNewFunction() As Long
MyNewFunction = 100
End Function
Which makes me wonder what the heck you're trying to accomplish.
If there is a bug in your generated code, you're going to have to debug it in a string, because the VBE's debugger won't let you break on generated code - this means it's crucially important that you generate code in a readable and maintainable way. There's currently nowhere in your code where you have the actual full generated code in a clear string - it's concatenated inline inside the InsertLines call.
Consider:
Dim code As String
code = "'Option Explicit" & vbNewLine & _
"Public Sub MyNewProcedure()" & vbNewLine & _
" n = 0" & vbNewLine & _
" e_i_e = 0" & vbNewLine & _
" For e_i_e = 0 To 100" & vbNewLine & _
" n = n + 1 ' fixed from n += 1" & vbNewLine & _
" Next" & vbNewLine & _
"End Sub" & vbNewLine
'...
'Debug.Print code
.InsertLines LineNum, code
It's much easier to get the full code back while debugging, and much easier to review and fix as well. Note that there's a limit to how many line continuations you can chain though.
Your code is c# addition, it needs to be n=n+1
You can create a module and populate it with a sub from a string. In fact one of the way developers place their vba code into a repository is to do just that: extract the code from modules as strings and then read them back in from whatever version control software they're using.
Here's a full example to do what you're looking to do (assuming you want your sub in a new separate module):
Sub make_module_sub_and_run():
Dim strMacro As String
Dim myModule As VBComponent
Set myModule = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule)
strMacro = "Public Sub exampleSub()" & vbCrLf & _
" n=0" & vbCrLf & _
" For e_i_e = 0 to 100:" & vbCrLf & _
" n=n+1" & vbCrLf & _
" Next" & vbCrLf & _
" MsgBox(""Hello World. Oh and n="" & n)" & vbCrLf & _
"End Sub"
myModule.CodeModule.AddFromString strMacro
Application.Run myModule.Name & ".exampleSub"
End Sub
Note that what should happen as you type "vbext_ct_StdModule" is that excel intellisense will note that this is missing and will ask whether you want to load it in - which you, of course, do.
Also note that I've deliberately prefixed the sub with the module name when running it - otherwise if you were to run it repeatedly you'll create new modules with a sub of the same name and excel wouldn't know which one to run.

Determining the Number of Lines in a Textbox in VBA

I have a textbox set up in a GUI where the user can enter information. This string is then spit out in a textbox within a PPT slide. Depending on the number of lines used in the textbox within the PPT slide, I need to enter the next set of information so many new lines below the text from the textbox. Here is what I have so far:
This is the code that takes the text the user enters in the textbox within the GUI and places it in the textbox within the PPT slide:
Private Sub Location()
With ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2
'Make sure there is text in the call to action textbox. If not, display an error message.
If C2AText = "" Then
MsgBox "Woah there! You need to enter text in the location/call to action box."
'Otherwise, if text is inserted, place that text in the WarningData box found on the PPT slide.
Else
.TextRange = C2AText
.TextRange.Paragraphs.Font.Size = 21
.TextRange.Paragraphs.Font.Name = "Calibri"
.TextRange.Paragraphs.Font.Shadow.Visible = True
.TextRange.Paragraphs.Font.Bold = msoTrue
End If
End With
End Sub
This text determines whether or not anything is selected in the HailInfo drop down. If it is, I need to place this text so many lines below the C2AText that was inserted in the previous Sub:
Private Sub HailInfo()
Call Dictionary.HailInfo
ComboBoxList = Array(CStr(HailDropDown))
For Each Ky In ComboBoxList
'On Error Resume Next
With ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2
'If nothing is selected in HailDropDown, do nothing and exit this sub.
If HailDropDown = "" Then
Exit Sub
'If a hail option is selected, execute the following code.
ElseIf HailDropDown <> "" And C2AText.LineCount = 2 Then
.TextRange = .TextRange & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & dict2.Item(Ky)(0)
ElseIf HailDropDown <> "" And C2AText.LineCount = 3 Then
.TextRange = .TextRange & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & dict2.Item(Ky)(0)
End If
End With
Next
Set dict2 = Nothing
End Sub
Using the C2AText.LineCount within the HailInfo sub does not appear to do anything. It will not insert the hail text anywhere, so I am not sure what I am doing wrong. Any help would be greatly appreciated...thanks!!
You should try the following ...
Private Sub HailInfo()
Call Dictionary.HailInfo
ComboBoxList = Array(CStr(HailDropDown))
For Each Ky In ComboBoxList
'On Error Resume Next
With ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2
'If nothing is selected in HailDropDown, do nothing and exit this sub.
If HailDropDown = "" Then
Exit Sub
'If a hail option is selected, execute the following code.
Else
.TextRange.Text = .TextRange.Text & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & dict2.Item(Ky)(0)
End If
End With
Next
Set dict2 = Nothing
End Sub
You were only referencing .TextRange, rather than .TextRange.Text.
Also, because you need to add the text at the end, you only need an Else condition, rather than two ElseIfs that both do the same thing! ;0)
More example code ... https://msdn.microsoft.com/en-us/library/office/ff822136.aspx