I'm trying to optimise my macro which allow me to ungroup all the shapes that are located in that active Page and if those shapes are already Ungrouped this macro will Group them
What I want to do is to modify this code to allow to group and Ungroup all in the Active page only not all te document . I'm a little noobi with VBA
this is my code
Private Sub degroupage_Click()
Dim mydocument As Document
Set mydocument = ActiveDocument
On Error Resume Next
ActiveDocument.Unprotect 'enregistré manuellement
Dim S As Shape, t As Shape
For i = 0 To mydocument.Shapes.Item(1).GroupItems.Count
For Each S In mydocument.Shapes
If S.Type = msoGroup Then S.Ungroup 'Ungrouping all shapes in all the document :(
If S.Selection.Ungroup = True Then
ActiveDocument.Selection.ShapeRange.Regroup ' Problem here
Next
Next
End Sub
I need a quick help
the error is methode unfound for the Regroup and S.Selection.Ungoup
Related
I would like to simplify updating my orgcharts in Visio. So far I have a macro borrowed from here https://bvisual.net/2010/01/28/applying-selected-datagraphic-to-the-whole-document/ and written out below. I would like to adapt it to make some changes to the format of the text withing shapes e.g. to make the font bold and potentially to change it's colour. I'm finding it really difficult to find examples of this online so any help/suggestion would be greatly appreciated.
Public Sub ApplyDataGraphicToDocument()
Dim mstDG As Visio.Master
Dim shp As Visio.Shape
Dim pag As Visio.Page
Dim firstProp As String
If Visio.ActiveWindow.Selection.Count = 0 Then
MsgBox "Please select a shape which already has data graphics"
Exit Sub
Else
Set shp = Visio.ActiveWindow.Selection.PrimaryItem
If shp.DataGraphic Is Nothing Then
MsgBox "Please select a shape which already has data graphics"
Exit Sub
Else
'Get the shapes DataGraphic master
Set mstDG = shp.DataGraphic
'Get the name of the first Shape Data row
firstProp = "Prop." & _
shp.CellsSRC(Visio.visSectionProp, 0, 0).RowNameU
End If
End If
For Each pag In Visio.ActiveDocument.Pages
If pag.Type = visTypeForeground Then
For Each shp In pag.Shapes
'Check that the named Shape Data row exists
If shp.CellExistsU(firstProp, Visio.visExistsAnywhere) Then
'Set the DataGraphic
shp.DataGraphic = mstDG
End If
Next
End If
Next
End Sub
You can modify the default OrgChart shapes, although it is not officially supported. To change the default shapes (make their font bold), you'll need to edit the templates (masters) for those OrgChart shapes. In the same blog you can find more information on customizing the OrgChart diagrams, here: https://bvisual.net/2012/05/08/creating-a-custom-org-chart-template-with-extra-properties
The procedure is mostly the same, just instead of adding the properties, you make the text bold.
I have a PowerPoint document where users can input text into several TextBoxes, over 6 slides in total.
On the last slide, I want to check if the user has filled in every TextBox in the presentation.
I tried using lots of code snippets on the internet and modifying them, however I am a complete VBA noob and, surprisingly, it did not work out. :')
I would greatly appreciate your help with this task.
It would be even better if it is possible to check whether the user has input AT LEAST 4 characters in each textbox. However I have no idea how to start programming this...
Here is my code, it does not show errors however nothing happens when clicking the CheckBox at the end.
Public Sub CheckTextBox()
Dim fTextBox As Object
For Each Slide In ActivePresentation.Slides
For Each fTextBox In ActivePresentation.Slides
If TypeName(fTextBox) = "TextBox" Then
If fTextBox.Text = "" Then
MsgBox "Please make sure to fill out all fields!"
End If
End If
Next
Next
End Sub
'When ticking this CheckBox, the MsgBox should show up
Private Sub CheckBox1_Click()
CheckTextBox
End Sub
Thank you guys so much for your help.
Your inner For-loop is wrong, you need to loop over all Shapes of the slide, instead, you start another loop over all slides.
Basically, all objects that you place on a slide are Shapes. If you use TypeName, you will get Shape. To distinguish the single shape-types, use the property type of the shape-object. A list of types can be found at https://learn.microsoft.com/de-de/office/vba/api/office.msoshapetype - a textbox has a type msoTextBox (17).
To get the text of a shape, use the property TextFrame.TextRange.Text of the shape.
Try the following code (it checks already for a length of at least 4 characters). It will stop at the first textbox that has less than 4 chars in it (else, you would get one MsgBox for every textbox) and select it.
Public Sub CheckTextBox()
Dim sh As Shape, slide As slide
For Each slide In ActivePresentation.Slides
For Each sh In slide.Shapes
Debug.Print TypeName(sh)
If sh.Type = msoTextBox Then
If Len(sh.TextFrame.TextRange.Text) < 4 Then
MsgBox "Please make sure to fill out all fields!"
slide.Select
sh.Select
Exit For
End If
End If
Next
Next
End Sub
UPDATE
The code above didn't take into account the shapes within groups. The following code loops over all shapes of all slides and calls the function checkShape that will check
a) If the shape is a textBox (msoTextBox, 17) - if yes, the length of the text is checked and if too short, that shape is returned.
b) If the shape is a group (msoGroup, 6), it calls (recursively) the function for all child shapes and returns the first child textbox found.
The main routine (CheckAllTextBoxes) checks if any textBox was found, and, if yes, will select it and issue the message.
Public Sub CheckAllTextBoxes()
Dim slide As slide, sh As Shape
For Each slide In ActivePresentation.Slides
For Each sh In slide.Shapes
Dim textBox As Shape
Set textBox = CheckShape(sh, 4)
If Not textBox Is Nothing Then
slide.Select
textBox.Select
MsgBox "Please make sure to fill out all fields!"
Exit Sub
End If
Next
Next
End Sub
Function CheckShape(sh As Shape, minLen As Integer) As Shape
' Check if shape is a Textbox and then text is not long enough
If sh.Type = msoTextBox Then
If Len(sh.TextFrame.TextRange.Text) < minLen Then
Set CheckShape = sh
Exit Function
End If
End If
' For a group, check all it's child shapes
If sh.Type = msoGroup Then
Dim child As Shape
For Each child In sh.GroupItems
Dim textBox As Shape
Set textBox = CheckShape(child, minLen)
If Not textBox Is Nothing Then
' Found a Textbox within the group, return it
Set CheckShape = textBox
Exit Function
End If
Next child
End If
End Function
For those looking for c# code to list all text boxes in a presentation:
using Microsoft.Office.Interop.PowerPoint;
using MsoShapeType = Microsoft.Office.Core.MsoShapeType;
public static IEnumerable<Shape> AllTextBoxes (Presentation presentation) =>
from slide in presentation.Slides.Cast<Slide>()
from shape in slide.Shapes.Cast<Shape>()
from textBox in AllTextBoxes(shape)
select textBox;
public static IEnumerable<Shape> AllTextBoxes (Shape sh)
{
IEnumerable<Shape> _() { if (sh.Type == MsoShapeType.msoTextBox) yield return sh; }
return sh.Type == MsoShapeType.msoGroup ? sh.GroupItems.Cast<Shape>().SelectMany(AllTextBoxes) : _();
}
Is there a way to edit connections through VBA?
For example, change the line weight of a connector when running a VBA script.
Sub Macro1()
Dim shp As Shape, mst As Master
' iterate all shapes per page
For Each shp In ActivePage.Shapes
' declare parent master for current shape
Set mst = shp.Master
' Process only shapes that have parent master-shape
If Not (mst Is Nothing) Then
' change only shapes, which master-shape is dynamic connector
If mst.Name = "Dynamic connector" Then shp.Cells("LineWeight").Formula = "0.5 pt"
End If
Next
End Sub
This code set Line Weight of each connector on page to 0.5 pt
This code changed Line Weight of selected shape
Set shp = ActiveWindow.Selection.PrimaryItem
shp.Cells("LineWeight").Formula = "0.5 pt"
I work from excel, and i open several powerpoint in a loop inside a directory, in vba.
While i run the macro (from excel), I make a loop within every shape inside every slides in powerpoints presentation.
I stop the macro to see if AutoShapeType = -2, and i select it in vba just to check visualy if the shape is the right shape i want.
Otherwise, if the selected shape doesn't seems right, I select it manually and I want to know how the syntaxe to get the id of the current selected shape, in order to name it.
Set PPtapp = CreateObject("Powerpoint.Application")
PPtapp.Visible = True
Dim sld As Slide
Dim numslide As Long
Dim nbslide As Long
Dim WVL_CptShape As Integer
'list of every powerpoint path
ppt = ThisWorkbook.Worksheets("Template").Range("A" & i).Value
For i = 2 To ThisWorkbook.Worksheets("Template").Range("A65536").End(xlUp).Row + 1
Set PptDoc = PPtapp.Presentations.Open(ppt)
With PptDoc
For Each sld In PptDoc.Slides
For WVL_CptShape = 1 To .Slides(sld.SlideNumber).Shapes.Count
WVL_Id = .Slides(sld.SlideNumber).Shapes(WVL_CptShape).ID
If PptDoc.Slides(sld.SlideNumber).Shapes(WVL_CptShape).AutoShapeType = -2 Then
'I select the shape to see visualy if it's a good selection and I stop the macro
PptDoc.Slides(sld.SlideNumber).Shapes(WVL_CptShape).Select
Stop
'if the selection doesnt seems right I select the right shape manualy
'Question : in vba, i want to change the name of the selected shape.
'But i don't know how to get the id of the current selected shape (see below : ID_OF_CURRENT_SHAPE_SELECTED_MANUALY)
'I would like to rename it, in order to recognize it easily next time
PptDoc.Slides(sld.SlideNumber). Shapes(ID_OF_CURRENT_SHAPE_SELECTED_MANUALY).Selection.Name = "Myshape"
end if
Next WVL_CptShapeNext
sld.Close
End With
Next
PPtapp.Quit
Set PPtapp = Nothing
Set PptDoc = PPtapp.Presentations.Open(ppt)
With PptDoc
For Each sld In PptDoc.Slides
For WVL_CptShape = 1 To sld.Shapes.Count
WVL_Id = sld.Shapes(WVL_CptShape).ID
If sld.Shapes(WVL_CptShape).AutoShapeType = -2 Then
'I select the shape to see visualy if it's a good selection and I stop the macro
sld.Shapes(WVL_CptShape).Select
Stop
' And to change the name of the shape:
sld.Shapes(WVL_CptShape).Name = "New name for shape"
' or better, in case you selected a different shape:
ActiveWindow.Selection.ShapeRange(1).Name = "New name for shape"
In this type of situation, you want to work with the shape's Index, not its ID.
Note that you can iterate through the shapes collection on a slide just as you can iterate through the slides collection in a presentation. It makes the code a lot simpler to write and to follow:
Set PptDoc = PPtapp.Presentations.Open(ppt)
With PptDoc
For Each sld In PptDoc.Slides
For each shp in sld.shapes
If shp.AutoShapeType = -2 Then
'I select the shape to see visualy if it's a good selection and I stop the macro
shp.Select
Stop
I have this Problem for deleting a shape in Excel with vba. Excel gives all the time different Name to These shapes, thatswhy i get error on this line:Here Activesheet is my open sheet and straight connectgor 1 is the Name of the shape, it is set as "Straight Connector 1" but when i reuse the macro it can not be found.
ActiveSheet.Shapes.Range(Array("Straight Connector 1")).Select
Selection.Delete
It can not find the element if i use the macro again. What should i do for this ?
use the activtsheet.shapes collection
Sub connector_delete()
Dim s As Shape
For Each s In ActiveSheet.Shapes
If s.AutoShapeType = msoShapeMixed And s.Name Like "*Connector*" Then
s.Delete
End If
Next s
End Sub