Im new to Powerpoint VBA which is totally different from excel VBA. I can do it in excel but not powerpoint and need some help. I need to enter a score in the textbox. After that press a button, the shape will fill with color based on the score value. The higher the score, more shape will fill up. Below is my code:
Sub AddShape()
Dim counter As Integer
Dim TopValue As Integer
TopValue = 500
For counter = 1 To 5
Set myDocument = ActivePresentation.Slides(2)
With myDocument.Shapes.AddShape(Type:=msoShapeRectangle, Left:=144, _
Top:=TopValue, Width:=72, Height:=5)
.Name = "Rectangle" & counter
.Fill.Visible = msoFalse
.Line.DashStyle = msoLineSolid
End With
TopValue = TopValue - 50
Next counter
Dim tshape As Shape
Set tshape = ActiveWindow.Selection.SlideRange.Shapes.AddOLEObject(Left:=850, Top:=100,
Width:=90, Height:=40, ClassName:="Forms.TextBox.1", Link:=msoFalse)
End Sub
Private Sub CommandButton1_Click()
If CInt(TextBox1.Text) > 0 And CInt(TextBox1.Text) < 11 Then
ActivePresentation.Slides(2).Shapes("Rectangle1").Fill.ForeColor.RGB = RGB(255, 0, 0)
End If
End Sub
Private Sub TextBox1_Change()
Me.TextBox1.SpecialEffect = fmSpecialEffectFlat
End Sub
The code inside the Private Sub CommandButton1_Click doesn't seen to work... Please advise. I got prompt running error '424' object required. Specific code is appreciated as all the above code is direct copy from google search. I do not have much vba powerpoint knowledge.
Thank you very much.
You need to access OLE objects and their properties a bit differently from the way you work with regular shapes on slides.
Instead of TextBox1.Text, use
ActivePresentation.Slides(2).Shapes("TextBox1").OLEFormat.Object.Text
Related
I received a PowerPoint file with multiple slides which were supposed to be templates (designs - customlayouts) but instead were regular slides.
Transforming them into SlideMaster and custom layouts and replacing the titles and bodys (textboxes) with actual placeholders by hand was a pain.
So I came with this script to make the process faster.
If anybody has a better approach, it's welcome.
Had to look for a workaround to get the customlayout object.
Several things are missing, for example error handling.
To test it, copy a textbox into a slidemaster layout slide, select it and run the ReplaceWithPHTitle macro
Option Explicit
Public Sub ReplaceWithPHTitle()
ReplaceTexboxWithPlaceholder ppPlaceholderTitle
End Sub
Public Sub ReplaceWithPHBody()
ReplaceTexboxWithPlaceholder ppPlaceholderBody
End Sub
Private Sub ReplaceTexboxWithPlaceholder(ByVal placeholderType As PpPlaceholderType)
Dim targetLayout As CustomLayout
Dim activeShape As Shape
Dim newPlaceHolder As Shape
Set activeShape = ActiveWindow.Selection.ShapeRange(1)
Set targetLayout = activeShape.Parent
Set newPlaceHolder = targetLayout.Shapes.AddPlaceholder(Type:=placeholderType, Left:=activeShape.Left, Top:=activeShape.Top, Width:=activeShape.Width + 15, Height:=activeShape.Height)
With newPlaceHolder.TextFrame
.TextRange.Font.Name = activeShape.TextFrame.TextRange.Font.Name
.TextRange.Characters.Font.Color.RGB = activeShape.TextFrame.TextRange.Characters.Font.Color.RGB
.TextRange.Font.Size = activeShape.TextFrame.TextRange.Font.Size
.TextRange.Font.Bold = activeShape.TextFrame.TextRange.Font.Bold
.TextRange.ParagraphFormat.Bullet.Type = activeShape.TextFrame.TextRange.ParagraphFormat.Bullet.Type
.TextRange.ParagraphFormat.SpaceWithin = activeShape.TextFrame.TextRange.ParagraphFormat.SpaceWithin
.TextRange.ParagraphFormat.Alignment = activeShape.TextFrame.TextRange.ParagraphFormat.Alignment
.TextRange.ParagraphFormat.SpaceBefore = activeShape.TextFrame.TextRange.ParagraphFormat.SpaceBefore
.TextRange.ParagraphFormat.SpaceAfter = activeShape.TextFrame.TextRange.ParagraphFormat.SpaceAfter
.TextRange.ParagraphFormat.BaseLineAlignment = activeShape.TextFrame.TextRange.ParagraphFormat.BaseLineAlignment
.TextRange.Text = activeShape.TextFrame.TextRange.Text
End With
With newPlaceHolder.TextFrame2
.TextRange.Font.Spacing = activeShape.TextFrame2.TextRange.Font.Spacing
End With
newPlaceHolder.ZOrder msoSendToBack
newPlaceHolder.Select
End Sub
Any improvements are welcome too.
After selecting a shape (f.e. square or more squares) all the connectors glued to this shape would highlight red, yellow whatever.
The found code below is not working for me, any advice? (I am not coder, so please have patience with me)
Set shpAtEnd = cnx(1).ToSheet
' use HitTest to determine whether Begin end of connector
' is outside shpAtEnd
x = shpAtEnd.HitTest(shpTaskLink.Cells("BeginX"), _
shpTaskLink.Cells("BeginY"), 0.01)
If x = visHitOutside Then
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 2
Else
' do other stuff
End If
This is my first answer on stackoverflow and I hope the following VBA code can solve your problem on how to highlight connectors or connected shapes in Visio!
Public Sub HighlightConnectedShapes()
Dim vsoShape As Visio.Shape
Dim connectedShapeIDs() As Long
Dim connectorIDs() As Long
Dim intCount As Integer
' Highlight the selected shape
Set vsoShape = ActiveWindow.Selection(1)
vsoShape.CellsU("Fillforegnd").FormulaU = "RGB(146, 212, 0)"
vsoShape.Cells("LineColor").FormulaU = "RGB(168,0,0)"
vsoShape.Cells("LineWeight").Formula = "2.5 pt"
' Highlight connectors from/to the selected shape
connectorIDs = vsoShape.GluedShapes _
(visGluedShapesAll1D, "")
For intCount = 0 To UBound(connectorIDs)
ActivePage.Shapes.ItemFromID(connectorIDs(intCount)).Cells("LineColor").FormulaU = "RGB(168,0,0)"
ActivePage.Shapes.ItemFromID(connectorIDs(intCount)).Cells("LineWeight").Formula = "2.5 pt"
Next
' Highlight shapes that are connected to the selected shape
connectedShapeIDs = vsoShape.connectedShapes(visConnectedShapesAllNodes, "")
For intCount = 0 To UBound(connectedShapeIDs)
ActivePage.Shapes.ItemFromID(connectedShapeIDs(intCount)).Cells("LineColor").FormulaU = "RGB(168,0,0)"
ActivePage.Shapes.ItemFromID(connectedShapeIDs(intCount)).Cells("LineWeight").Formula = "2.5 pt"
Next
End Sub
To run the macro, you can consider associating with double-click behavior of shapes.
If you only need to highlight incoming/outgoing connectors and incoming/outgoing shapes, replace visGluedShapesAll1D with visGluedShapesIncoming1D/visGluedShapesOutgoing1D and visConnectedShapesAllNodes with visConnectedShapesIncomingNodes/visConnectedShapesOutgoingNodes.
Learn more at visgluedshapesflags and visconnectedshapesflags. Good luck!
The following code will loop though all 1d-Shapes glued to the first shape in your Selection and write their name to the Immediate window. This should be a good starting point.
Visio has no Event that fires if a Shape is selected (at least not without some workarounds), so maybe bind the macro to a keybind.
The visGluedShapesAll1D flag can be replace with another filter as described here: Microsoft Office Reference
Sub colorConnectors()
If ActiveWindow.Selection(1) Is Nothing Then Exit Sub
Dim selectedShape As Shape
Set selectedShape = ActiveWindow.Selection(1)
Dim pg As Page
Set pg = ActivePage
Dim gluedConnectorID As Variant 'variant is needed because of "For Each" Loop
For Each gluedConnectorID In selectedShape.GluedShapes(visGluedShapesAll1D, "")
Debug.Print pg.Shapes.ItemFromID(gluedConnectorID).NameU
Next gluedConnectorID
End Sub
I need to create ComboBox's and then AddItems to each ComboBox. This will all be done to a userform. I need to do this entirely within the VBA code, this is because each time the userform is opened new information will be shown.
this is what I have so far:
Private Sub UserForm_Initialize()
for i = 1 to size
Set CmbBX = Me.Controls.Add("Forms.ComboBox.1")
CmbBX.Top = ((90 * i) - 18) + 12 + 20
CmbBX.Left = 30
CmbBX.Text = "Please select an item from the drop down"
CmbBX.TextAlign = fmTextAlignCenter
CmbBX.Width = 324
CmbBX.Visible = False
CmbBX.Name = "ComBox2" & i
Next
end sub
the problem is, once each ComboBox is created its like its name isnt there. I cannot referance the combobox. this is what I have tried:
ComBox21.AddItems "Test1"
ComBox22.AddItems "Test2"
And it errors out. When I look at the UserForms function bar at the top of the screen (where I would usually select ComBox22_Change() for example), It shows that no ComboBoxes even exist!
Any Ideas on how to dynamically create and additems to comboboxes?
Thank you in advance
Here an sample of the code.
You need still to change it for you needs but this will be easy.
I have created a simple userform and one button to do test and it works fast.
To imput the comboboxes replace ".additem" with a loop to load each of them.
How to do that -- search in google
how to Populate a combobox with vba
You cannot refferance any controls on userform if they dont exist.
You need to search for them after creation and then modify them.
Example below with button code.
I think this should bring you to an idea how to manage this.
Option Explicit
Private Sub CommandButton1_Click()
Dim refControl As Control, frm As UserForm
Dim x
Set frm = Me
With Me
For Each x In Me.Controls
If TypeName(x) = "ComboBox" Then
Select Case x.Name
Case "cmbDemo3"
MsgBox "works!"
'here you can put your code
End Select
MsgBox x.Name
End If
Next x
End With
End Sub
Private Sub UserForm_Initialize()
Dim combobox_Control As Control
Dim i
For i = 0 To 5
Set combobox_Control = Controls.Add("forms.combobox.1")
With combobox_Control
.Name = "cmbDemo" & i
.Height = 20
.Width = 50
.Left = 10
.Top = 10 * i * 2
.AddItem "hihi" 'here you can add your input code
End With
Next i
End Sub
I have been trying to write a macro that will dynamically fill a textbox on a new sheet will the value of a cell from another sheet.
I have managed to get it working using this:
Sub copyDetail()
' Define variables
Dim pre As Worksheet
Dim des As Worksheet
Set pre = Sheets("Presentation")
Set des = Sheets("Description")
Dim i As Integer
Dim lbl As String
' Scroll through labels and copy where boolean = 1
For i = 2 To 17
If des.Cells(i, 2) = 1 Then
lbl = des.Cells(i, 11)
Sheets("Presentation").Select
ActiveSheet.Shapes.Range(Array("TextBox 1")).Select
Selection.Text = lbl
Else
End If
Next i
End Sub
I basically want to be able to do exactly what this does but without using select all the time as this changes sheets and slows down my code (I have many other sub's to run alongside this one). I've tried things like defining the textbox using this:
Dim myLabel As Object
Set myLabel = pre.Shapes.Range(Array("TextBox 1"))
But then I get an "object doesn't support this property or method" error when I try and call:
myLabel.Text = lbl
You can set the text of a TextBox like so:
ActiveSheet.Shapes("TextBox 1").TextFrame.Characters.Text = "Hello world"
You can set-up a little helper Sub in a Module to make the code re-usable:
Public Sub SetTextBoxText(ws As Worksheet, strShapeName As String, strText As String)
Dim shp As Shape
On Error Resume Next
Set shp = ws.Shapes(strShapeName)
If Not shp Is Nothing Then
shp.TextFrame.Characters.Text = strText
Else
Debug.Print "Shape not found"
End If
End Sub
I'm trying to change the background color of a form control checkbox via VBA code. I've tried every variation of code I can find on the internet and am still getting failures.
The line I have currently is below, and is the only one I've found so far that doesn't give me compiler errors. When I run it though I get a "Run-time error '438': Object doesn't support this property or method" error on executing this line. This is true whether I set it = to xlBlack, RGB(255,255,255) or "11398133" (not black I know, but I was just trying to see if any color would work).
Anyone know what's going on and how I can actually do this?
Sheets("Controls").Shapes.Range(Array("Check Box 8")).BackColor = "11398133"
Answer
I found the answer. For some reason none of the responses worked, but Johnny's answer did help me get closer to it by loading the right object in memory and I could then use the Locals window to track down the property I wanted.
In the end it was identifying the object as Johnny suggested and then just cb.Interior.Color = xlBlack I was looking for. No .Fill and no .DrawingObject. Not sure what makes this different than others that would make that work that way, but there you go.
So, for any others who come looking, the code that ended up working for me was the simple addition of the below, and you can find out what the Excel name of the object is (Check Box 8 in my case) by selecting it while recording macros.
For Each cb In Sheets("Controls").CheckBoxes
If cb.Name = "Check Box 8" Then
cb.Interior.Color = xlNone
Exit Sub
End If
Next
This should do it for you. Follow these steps:
Make some form check boxes on a sheet
Copy the below code into a module (alt F11, insert, module)
run SetMacro
Save and test
code:
Sub SetMacro()
Dim cb, ws
For Each ws In ThisWorkbook.Sheets
For Each cb In ws.CheckBoxes
If cb.OnAction = "" Then cb.OnAction = "CheckedUnchecked"
Next cb
Next ws
End Sub
Sub CheckedUnchecked()
With ActiveSheet.Shapes(Application.Caller).DrawingObject
If .Value = 1 Then
.Interior.ColorIndex = 4
Else
.Interior.ColorIndex = 2
End If
End With
If you're only looking to do it on the active sheet, use this block instead:
Sub SetMacro()
Dim cb
For Each cb In ActiveSheet.CheckBoxes
If cb.OnAction = "" Then cb.OnAction = "CheckedUnchecked"
Next cb
End Sub
Sub CheckedUnchecked()
With ActiveSheet.Shapes(Application.Caller).DrawingObject
If .Value = 1 Then
.Interior.ColorIndex = 4
Else
.Interior.ColorIndex = 2
End If
End With
End Sub
Another possibility is that you want to set the ForeColor not the BackColor.
Very simply:
Sub changegColor()
Dim wb As Workbook
Dim ws As Worksheet
Dim cb As Object
Dim rng As Range
Set wb = ActiveWorkbook
Set ws = wb.ActiveSheet
Set cb = ws.Shapes.Range(1)
With cb.Fill
.Solid
.ForeColor.RGB = RGB(0, 255, 0)
End With
End Sub