I am trying to use a PowerPoint macro written for Windwos on a Mac (Microsoft 365 for Mac). Most of it is working well, but there are two strange things. The major issue: The Mac creates unwanted blank lines.
TextFrame2.TextRange.Text = "Text 1" & vbCrLf & "Text 2" & vbCrLf & "Text 3"
& vbCrLf & creates just a break on Windows PPT, but an additional blank line on the Mac. Any ideas how I can avoid that?
There is a minor issue, too:
I thought it's better to use TextFrame2 instead of TextFrame all time, but on the Mac I get a compiling error, when trying to use it with the ruler function close to the end of the code. If anyone has a solution for this, I would be happy, too.
Private Sub ParameterColumnBodyStandard()
Dim shp As Shape
Dim i As Integer
Set shp = ActiveWindow.Selection.ShapeRange(1)
With shp
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
With .TextFrame2
.TextRange.Text = "Text 1" & vbCrLf & "Text 2" & vbCrLf & "Text 3"
.VerticalAnchor = msoAnchorTop
.MarginBottom = 5.6692878
.MarginLeft = 5.6692878
.MarginRight = 5.6692878
.MarginTop = 5.6692878
.WordWrap = msoTrue
With .TextRange
.Font.Size = 16
.Font.Name = "Arial"
.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
.Font.Bold = msoFalse
.Font.Italic = msoFalse
.Font.UnderlineStyle = msoNoUnderline
.ParagraphFormat.SpaceAfter = 6
.ParagraphFormat.Alignment = ppAlignLeft
.ParagraphFormat.Bullet.UseTextColor = msoFalse
.ParagraphFormat.Bullet.UseTextFont = msoFalse
.ParagraphFormat.Bullet.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
.Characters(1, 6).Font.Bold = msoFalse
For i = 2 To 3
With .Paragraphs(i).ParagraphFormat.Bullet
.Visible = msoTrue
End With
Next
With .Paragraphs(2)
.ParagraphFormat.IndentLevel = 2
.ParagraphFormat.Bullet.Character = 8226
.ParagraphFormat.Bullet.RelativeSize = 1
End With
With .Paragraphs(3)
.ParagraphFormat.IndentLevel = 3
.ParagraphFormat.Bullet.Character = 8226
.ParagraphFormat.Bullet.RelativeSize = 1
End With
End With
End With
With .TextFrame
With .Ruler
.Levels(2).FirstMargin = 14.173219
.Levels(2).LeftMargin = 28.346439
.Levels(3).FirstMargin = 28.346439
.Levels(3).LeftMargin = 42.519658
End With
End With
End With
End Sub
Related
So I'm using the following code to add a text box to the header of several slides:
Set myDocument = ActivePresentation.Slides.Range(Array(4, 5, 6))
Set newTextBox = myDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, _
260, Top:=30, Width:=541.44, Height:=43.218)
With newTextBox.TextFrame.TextRange
.Text = "Test Text"
.Font.Size = 17
.Font.Name = "Arial"
End With
When I run this code I get an automation error and it doesn't work. If I do it on a single slide it does work. Does anyone know why? What I'm attempting to do is add headers to specific slides. So I will be using the same method to add different headers to other slides as well.
You can go through all the slides with numbers from the array you set:
Sub slideTextBoxes()
For Each myDocument In ActivePresentation.Slides.Range(Array(4, 5, 6))
Set newTextBox = myDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, _
260, Top:=30, Width:=541.44, Height:=43.218)
With newTextBox.TextFrame.TextRange
.Text = "Test Text"
.Font.Size = 17
.Font.Name = "Arial"
End With
Next
End Sub
Slides don't have headers. But here is code that will work:
Sub AddTextBoxes()
Dim oSlide As Slide
Dim oShape As Shape
For Each oSlide In ActivePresentation.Slides
If oSlide.SlideIndex = 4 Or oSlide.SlideIndex = 5 Or oSlide.SlideIndex = 6 Then
Set oShape = oSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=260, Top:=30, Width:=541.44, Height:=43.218)
With oShape.TextFrame.TextRange
.Text = "Test Text"
.Font.Size = 17
.Font.Name = "Arial"
End With
End If
Next oSlide
End Sub
I want to take all the articles in Word document and transform them into PowerPoint Presentation.
1 article = 1 slide (if the text does not fit shrink it, else create a new slide).
I managed to recognize each part of the article by its Style in Word. I get text by its style and insert it into a slide and so forth. I retrieve text by paragraphs (Selection.StartOf and EndOf didn't work).
I didn't find a way to avoid overlaying one text over the other.
Maybe I can get what I need by the coordinates of the textframes?
What I have got so far:
For Each StyleInWord In ActiveDocument.Paragraphs
If StyleInWord.Style = "NAME_OF_THE_ARTICLE" Then
wordText0 = StyleInWord.Range
Set pptLayout = pptPres.SlideMaster.CustomLayouts.Add(ppLayoutBlank)
Set pptSlide = pptPres.Slides.AddSlide(1, pptLayout)
If pptPres.Slides(1).Shapes(1).HasTextFrame Then
pptPres.Slides(1).Shapes(1).Delete
End If
With pptPres.PageSetup
.SlideSize = ppSlideSizeCustom
.SlideHeight = CentimetersToPoints(21.008)
.SlideWidth = CentimetersToPoints(28.011)
End With
Set mySlide = pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, CentimetersToPoints(1.31), CentimetersToPoints(3.73), CentimetersToPoints(24.34), CentimetersToPoints(12.57))
With mySlide.TextFrame.TextRange
.Text = wordText0
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
End If
If StyleInWord.Style = "DESCRIPTION_OF_THE_ARTICLE" Then
wordText1 = StyleInWord.Range
Set mySlide = pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, CentimetersToPoints(1.31), CentimetersToPoints(5.73), CentimetersToPoints(24.34), CentimetersToPoints(12.57))
With mySlide.TextFrame
With .TextRange
.Text = wordText1
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
End With
End If
If StyleInWord.Style = "MAIN_TEXT_OF_THE_ARTICLE" Then
Set mySlide = pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, CentimetersToPoints(1.31), CentimetersToPoints(7.73), CentimetersToPoints(24.34), CentimetersToPoints(12.57))
wordText2 = StyleInWord.Range
With mySlide.TextFrame
With .TextRange
.Text = wordText2
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
End With
End If
Next StyleInWord
'Here i change the order, so the first slide i create will stay the first by the end of the forEachLoop
i = 1
For i = 1 To pptPres.Slides.Count
pptPres.Slides(i).MoveTo 1
Next i
Each time you add a textbox you set the top position to simply be 2cm lower than the previous one. This takes no account of the height of the previous text box.
There is a very simple solution to this. A text box has properties for both top and height, so just store those in variables. That way you can add each new text box directly below the previous one.
Your code also needs some improvement as some of the presentation setup you are doing should be outside the loop. You should also rename mySlide as pptTextBox so that the variable has a logical name that is consistent with the others.
Set pptLayout = pptPres.SlideMaster.CustomLayouts.Add(ppLayoutBlank) doesn't do what you think it does and is unnecessary. The presentation will already contain a blank layout, helpfully named "Blank", so all you need to do is set a pointer to it, again outside the loop.
'do presentation setup outside the loop
With pptPres.PageSetup
.SlideSize = ppSlideSizeCustom
.SlideHeight = CentimetersToPoints(21.008)
.SlideWidth = CentimetersToPoints(28.011)
End With
'a presentation will already include a blank layout so there is no need to create one
For Each pptLayout In pptPres.SlideMaster.CustomLayouts
If pptLayout.Name = "Blank" Then Exit For
'pptLayout now points to the Blank layout
Next
For Each StyleInWord In ActiveDocument.Paragraphs
If StyleInWord.Style = "NAME_OF_THE_ARTICLE" Then
wordText0 = StyleInWord.Range
Set pptSlide = pptPres.Slides.AddSlide(1, pptLayout)
If pptPres.Slides(1).Shapes(1).HasTextFrame Then
pptPres.Slides(1).Shapes(1).Delete
End If
Set pptTextBox = _
pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, _
CentimetersToPoints(1.31), CentimetersToPoints(3.73), _
CentimetersToPoints(24.34), CentimetersToPoints(12.57))
With pptTextBox
With .TextFrame.TextRange
.Text = wordText0
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
textBoxTop = .Top
textBoxHeight = .Height
End With
End If
If StyleInWord.Style = "DESCRIPTION_OF_THE_ARTICLE" Then
wordText1 = StyleInWord.Range
Set pptTextBox = _
pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, _
CentimetersToPoints(1.31), textBoxTop + textBoxHeight, _
CentimetersToPoints(24.34), CentimetersToPoints(12.57))
With pptTextBox
With .TextFrame.TextRange
.Text = wordText1
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
textBoxHeight = textBoxHeight + .Height
End With
End If
If StyleInWord.Style = "MAIN_TEXT_OF_THE_ARTICLE" Then
Set pptTextBox = _
pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, _
CentimetersToPoints(1.31), textBoxTop + textBoxHeight, _
CentimetersToPoints(24.34), CentimetersToPoints(12.57))
wordText2 = StyleInWord.Range
With pptTextBox
With .TextFrame.TextRange
.Text = wordText2
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
textBoxHeight = textBoxHeight + .Height
End With
End If
Next StyleInWord
'Here i change the order, so the first slide i create will stay the first by the end of the forEachLoop
i = 1
For i = 1 To pptPres.Slides.Count
pptPres.Slides(i).MoveTo 1
Next i
For internal communication purposes in a group of people I have created a macro adding comment fields to a slide - not those of PPT itself.
Dim shp As Shape
Dim sld As Slide
'Comment field
On Error GoTo ErrMsg
If ActiveWindow.Selection.SlideRange.Count <> 1 Then
MsgBox "This function cannot be used for several slides at the same time"
Exit Sub
Else
Set sld = Application.ActiveWindow.View.Slide
Set shp = sld.Shapes.AddShape(Type:=msoShapeRectangle, Left:=0, Top:=104.88182, Width:=198.42507, Height:=28.913368)
shp.Fill.Visible = msoTrue
shp.Fill.Transparency = 0
shp.Fill.ForeColor.RGB = RGB(211, 61, 95)
shp.Line.Visible = msoTrue
shp.Line.ForeColor.RGB = RGB(255, 255, 255)
shp.Line.Weight = 0.75
shp.Tags.Add "COMMENT", "YES"
shp.Select
shp.TextFrame.TextRange.Font.Color.RGB = RGB(255, 255, 255)
shp.TextFrame.TextRange.Characters.Text = "Comment: "
shp.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
shp.TextFrame.VerticalAnchor = msoAnchorTop
shp.TextFrame.TextRange.Font.Size = 12
shp.TextFrame.TextRange.Font.Name = "Arial"
shp.TextFrame.TextRange.Font.Bold = msoTrue
shp.TextFrame.TextRange.Font.Italic = msoFalse
shp.TextFrame.TextRange.Font.Underline = msoFalse
shp.TextFrame.Orientation = msoTextOrientationHorizontal
shp.TextFrame.MarginBottom = 7.0866097
shp.TextFrame.MarginLeft = 7.0866097
shp.TextFrame.MarginRight = 7.0866097
shp.TextFrame.MarginTop = 7.0866097
shp.TextFrame.WordWrap = msoTrue
shp.TextFrame.AutoSize = ppAutoSizeShapeToFitText
shp.TextFrame.TextRange.Select
End If
Exit Sub
ErrMsg:
MsgBox "Please select a slide"
End Sub
Works well.
I have tagged them, because I want it to be easy to delete all of them at once, e.g., in case you find comments 5 minutes before you have to present. Here's my way to delete them:
Sub CommDel()
Dim sld As Slide
Dim L As Long
If MsgBox("Do you want to delete ALL comments from the entire presentation?", vbYesNo) <> vbYes Then Exit Sub
On Error Resume Next
For Each sld In ActivePresentation.Slides
For L = sld.Shapes.Count To 1 Step -1
If sld.Shapes(L).Tags("COMMENT") = "YES" Then sld.Shapes(L).Delete
Next L
Next sld
End Sub
Works fine, too.
Third step I would like to do, is creating a third macro, called "find next comment". On every click it jumps to the next shape tagged with the tag "COMMENT", no matter if that shape is on the same slide or the next or somewhere else in the presentation. Just the next one, where ever it is. And now I'm completely lost. I am able to do something to all tagged shapes on one slide or inthe entire presentation - as you can see in the function to delete. But what I'm looking for is not selecting all shapes at the same time. In another try I was able to find the first one - but after clicking the macro again nothing seemed to happen, because the macro started searching at the same point and selected the same shape again and again, never jumping to the next one, except I deleted the first one.
Would be great to read your ideas. Thank you in advance. But be careful, I'm far from being a good programmer. ;-)
This starts at the current slide and works toward the end, dropping out of the Sub as soon as the first comment is found:
Sub FindNextComment()
Dim oSlide As Slide
Dim oShape As Shape
Set oSlide = ActiveWindow.View.Slide
For Each oShape In oSlide.Shapes
If oShape.Tags.Count > 0 Then
For y = 1 To oShape.Tags.Count
If oShape.Tags.Name(y) = "COMMENT" Then
oShape.Select
Exit Sub
End If
Next y
End If
Next oShape
For x = oSlide.SlideIndex + 1 To ActivePresentation.Slides.Count
For Each oShape In ActivePresentation.Slides(x).Shapes
If oShape.Tags.Count > 0 Then
For y = 1 To oShape.Tags.Count
If oShape.Tags.Name(y) = "COMMENT" Then
ActivePresentation.Slides(x).Select
oShape.Select
Exit Sub
End If
Next y
End If
Next oShape
Next x
End Sub
Bonus VBA Tip: You can make your code run a little faster by using With statements:
With shp.TextFrame
.MarginBottom = 7.0866097
.MarginLeft = 7.0866097
.MarginRight = 7.0866097
.MarginTop = 7.0866097
.WordWrap = msoTrue
.AutoSize = ppAutoSizeShapeToFitText
.Orientation = msoTextOrientationHorizontal
.VerticalAnchor = msoAnchorTop
With .TextRange
.Characters.Text = "Comment: "
.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
With .Font
.Size = 12
.Name = "Arial"
.Bold = msoTrue
.Italic = msoFalse
.Underline = msoFalse
End With
End With
End With
I am trying to create a simple PowerPoint file to capture a series of milestones for a project portfolio. I have created the following Macro to create the milestone visual and group the shapes. However, I am looking to create another macro for updating/statusing the milestone. Specifically, I want the user to select the group and then run a macro to that will allow the user to update the date and move the shapes accordingly or, if the task is complete, fill in the shape.
I struggle with the initiation of the update macro to identify the shapes and its' content to complete the calculation. For example, I don't know how to read in the date in to move the milestone left/right based on the new date. Any help is appreciated!
Code:
Private Sub EnterTask_Click()
Dim Sld As Slide
Dim shapeMile As Shape
Dim shapeTask As Shape
Dim shapeECD As Shape
Dim dateECD As String
Dim taskText As String
Dim StatusBox As Shape
dateECD = "6/12/18"
taskText = "Task #1"
Set Sld = Application.ActiveWindow.View.Slide
With Sld
'Create shape with Specified Dimensions and Slide Position
Set shapeMile = Sld.Shapes.AddShape(Type:=msoShapeIsoscelesTriangle, _
Left:=25, Top:=150, Width:=15, Height:=15)
With shapeMile
.Rotation = 180
.Tags.Add "Milestone", "Bug"
.Line.Visible = msoTrue
.Fill.Visible = msoFalse
.Shadow.Visible = msoFalse
End With
Set shapeECD = Sld.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Left:=8, Top:=165, Width:=50, Height:=30)
With shapeECD
.Tags.Add "Milestone", "ECD"
.Line.Visible = msoFalse
.Fill.Visible = msoFalse
.Shadow.Visible = msoFalse
.TextFrame.TextRange.Characters.Text = dateECD
.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter
.TextFrame.VerticalAnchor = msoAnchorTop
.TextFrame.HorizontalAnchor = msoAnchorCenter
.TextFrame.TextRange.Font.Size = 8
.TextFrame.TextRange.Font.Name = "Arial"
.TextFrame.TextRange.Font.Italic = msoFalse
.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
End With
Set shapeTask = Sld.Shapes.AddTextbox(msoTextOrientationHorizontal, _
Left:=8, Top:=135, Width:=50, Height:=30)
With shapeTask
.Tags.Add "Milestone", "Task"
.Line.Visible = msoFalse
.Fill.Visible = msoFalse
.Shadow.Visible = msoFalse
.TextFrame.TextRange.Characters.Text = taskText
.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter
.TextFrame.VerticalAnchor = msoAnchorTop
.TextFrame.HorizontalAnchor = msoAnchorCenter
.TextFrame.TextRange.Font.Size = 8
.TextFrame.TextRange.Font.Name = "Arial"
.TextFrame.TextRange.Font.Italic = msoFalse
.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
End With
.Shapes.Range(Array(shapeMile.Name, shapeECD.Name, shapeTask.Name)).Group
End With
End Sub
I am looking to format multiple selected charts on Excel 2010 using VBA. The code below works when only one chart is selected but when multiple charts are selected, I get a "run-time error '91' Object variable or With Block variable not set". Any idea how to run the macro for number of selected charts?
Sub ChartFormat5_Click()
''Adjust chart area
'Size
Selection.Width = 631.9
Selection.Height = 290.1
'Border
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Weight = 1
.DashStyle = msoLineSolid
End With
'Font
With Selection.Format.TextFrame2.TextRange.Font
.Name = "Calibri"
.Size = 10
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorText1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
End With
End Sub
Thanks!
This will process the active chart or all selected charts. The first routine determines what to process (active chart or selected charts) and the second processes each.
Sub FormatCharts()
Dim obj As Object
If Not ActiveChart Is Nothing Then
FormatOneChart ActiveChart
Else
For Each obj In Selection
If TypeName(obj) = "ChartObject" Then
FormatOneChart obj.Chart
End If
Next
End If
End Sub
Sub FormatOneChart(cht As Chart)
' do all your formatting here, based on cht not on ActiveChart
End Sub
Don't select parts of the chart, just fully reference them. Instead of
ActiveChart.ChartArea.Select
With Selection.Format.Line
use this
With cht.ChartArea.Format.Line
etc.
Note: this is a duplicate of VBA: Formatting Multiple Selected Charts (Chart, Plot, Legend, etc.)
After some trial-n-error, I figured out how to make it work if you have just one or multiple charts selected. It was straightforward, but this worked when I tested it.
Note that I broke the actual Chart Area formatting into a separate sub.
Sub ChartFormat5_Click()
Select Case TypeName(Selection)
Case Is = "ChartArea" `only 1 selected
FormatChart Selection
Case Is = "DrawingObjects" 'more than 1 selected
Dim cht As ChartObject
For Each cht In Selection
FormatChart cht.Chart.ChartArea
Next
End Select
End Sub
Sub FormatChart(chtArea As ChartArea)
With chtArea
'size
.Width = 631.9
.Height = 290.1
With .Format
'Border
With .Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Weight = 1
.DashStyle = msoLineSolid
End With
'Font
With .TextFrame2.TextRange.Font
.Name = "Calibri"
.Size = 10
With .Fill
.Visible = msoTrue
With .ForeColor
.ObjectThemeColor = msoThemeColorText1
.TintAndShade = 0
.Brightness = 0
End With
.Transparency = 0
.Solid
End With
End With
End With
End With
End Sub
Hy try:
Sub ChartFormat5_Click_v02()
For i = 1 To Application.Sheets.Count
Application.Sheets(i).Activate
For j = 1 To ActiveSheet.ChartObjects.Count
ActiveSheet.ChartObjects(j).Activate
'your code here
Next j
Next i
End Sub