Is there an easy way to pro-actively or retro-actively apply a 'Picture Style' to all images stored in a word document?
I want to apply the 'Center Shadow Rectangle' picture style to all images that I add to a document without changing them 1 by 1.
The picture style concept only exists at the UI level. To apply it to an image, you will have to check the properties of the style in the UI and apply them one by one using VBA:
Sub FormatPictures()
Dim oInlineShape As inlineShape
For Each oInlineShape In ActiveDocument.InlineShapes
ApplyPictureStyleToInlineShape oInlineShape
Next
Dim oShape As Shape
For Each oShape In ActiveDocument.Shapes
ApplyPictureStyleToShape oShape
Next
End Sub
Sub ApplyPictureStyleToInlineShape(shape As inlineShape)
' borders
shape.Borders.Enable = False
' fill
shape.Fill.Visible = msoFalse
' line
shape.Line.Visible = msoFalse
' shadow
shape.Shadow.Style = msoShadowStyleOuterShadow
shape.Shadow.Type = msoShadow21
shape.Shadow.ForeColor = WdColor.wdColorBlack
shape.Shadow.Transparency = 0.3
shape.Shadow.Size = 100
shape.Shadow.Blur = 15
shape.Shadow.OffsetX = 0
shape.Shadow.OffsetY = 0
' reflection
shape.Reflection.Type = msoReflectionTypeNone
' glow
shape.Glow.Radius = 0
shape.SoftEdge.Radius = 0
End Sub
Sub ApplyPictureStyleToShape(shape As shape)
' fill
shape.Fill.Visible = msoFalse
' line
shape.Line.Visible = msoFalse
' shadow
shape.Shadow.Style = msoShadowStyleOuterShadow
shape.Shadow.Type = msoShadow21
shape.Shadow.ForeColor = WdColor.wdColorBlack
shape.Shadow.Transparency = 0.3
shape.Shadow.Size = 100
shape.Shadow.Blur = 15
shape.Shadow.OffsetX = 0
shape.Shadow.OffsetY = 0
' reflection
shape.Reflection.Type = msoReflectionTypeNone
' glow
shape.Glow.Radius = 0
shape.SoftEdge.Radius = 0
End Sub
Just got inspired by you guys (and others, so Thanks all!), and made my own macro to format a selected pasted picture with a single border (0.75 pt width) and simple shadow offset by 3 pts...
I assigned that macro to an icon, and voila!
Once I paste my image (most of them are screenshot for procedures and documentation of systems).
Works well in Word 2010.
I did not tested other versions ...
Sub FormatPictureWithLineAndShadow()
Dim oInlineShp As InlineShape
For Each oInlineShp In Selection.InlineShapes
With oInlineShp
'Line border
With .Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth075pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth075pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth075pt
.Color = wdColorAutomatic
End With
With .Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth075pt
.Color = wdColorAutomatic
End With
' shadow
.Shadow.Style = msoShadowStyleOuterShadow
.Shadow.Type = msoShadow21
.Shadow.ForeColor = WdColor.wdColorBlack
.Shadow.Transparency = 0.6
.Shadow.Size = 100
.Shadow.Blur = 5
.Shadow.OffsetX = 3
.Shadow.OffsetY = 3
' reflection
.Reflection.Type = msoReflectionTypeNone
' glow
.Glow.Radius = 0
.SoftEdge.Radius = 0
End With
Next
End Sub
Related
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
I have some vsto add-in to PowerPoint.
I need to know which part of chart is selected by user (series, title, charta area, plot area, legend etc.). Is it possible to get such information?
I know, of course, how to get selected chart.
My add-in is written in VBA, but I think the below will help you. The PPT object model doesn't support this, so my hacky solution was to apply Strikethrough font as an ExecuteMSO command (i.e., Strikethrough is applied to whatever is selected), then I go through every element of the chart and look for Strikethrough. When we find it, we can tell what the user had selected, apply whatever rules we want, and remove the Strikethrough.
In my case, I wanted to rewrite the Bold command so that we could apply a different font weight to the user's selection, rather than using the native faux-bolding. Here is part of my solution:
First, this is the sub that's called when the selection contains shapes. Note how we handle the chart scenario:
Private Sub commandBoldSelectedShapes(mySelection As Selection)
Debug.Print "IN_commandBoldSelectedShapes"
Dim oShp As Shape
Dim oSmrtArt As SmartArt
Dim oTable As Table
Dim oChart As Chart
Dim oCell As Cell
Dim i As Long
Dim j As Long
Dim ctr As Long
Dim oFont As Font
For ctr = 1 To mySelection.ShapeRange.Count
Set oShp = mySelection.ShapeRange(ctr)
If oShp.Type = msoGroup Then
RefontTypoGroup oShp, mySelection
ElseIf oShp.HasSmartArt Then
Set oSmrtArt = oShp.SmartArt
DoEvents
Application.CommandBars.ExecuteMso ("Strikethrough")
DoEvents
RefontTypoSmartArt oSmrtArt
ElseIf oShp.HasTable Then
Debug.Print "Seeing a table!"
Set oTable = oShp.Table
If ctr = 1 And mySelection.ShapeRange.Count = 1 Then
With oTable
For i = 1 To oTable.Rows.Count
For j = 1 To oTable.Columns.Count
Set oCell = oTable.Rows(i).Cells(j)
If oCell.Selected Then
Set oFont = oCell.Shape.TextFrame.TextRange.Font
checkBoldsNoStrikethrough oFont
End If
Next
Next
End With
Else
For i = 1 To oTable.Rows.Count
For j = 1 To oTable.Columns.Count
Set oCell = oTable.Rows(i).Cells(j)
Set oFont = oCell.Shape.TextFrame.TextRange.Font
checkBoldsNoStrikethrough oFont
Next
Next
End If
' Charts are highly problematic because the VBA Selection object
' doesn't allow you to figure out which element(s) in a chart the user
' may have selected. You can only see that the full shape containing a chart
' has been selected. So my solution was to run an
' ExecuteMso - Strikethrough command. Then, separate macros
' go through the whole chart looking for strikethoughs and replace them
' with bolded/unbolded text and the correct font weight.
ElseIf oShp.HasChart Then
Debug.Print "Seeing a chart!"
Set oChart = oShp.Chart
If ctr = 1 And mySelection.ShapeRange.Count = 1 Then
DoEvents
Application.CommandBars.ExecuteMso ("Strikethrough")
DoEvents
RefontTypoChart oChart
Exit Sub
' If there is more than one shape selected, including a chart,
' and that chart is not the first shape selected, we know that
' the whole chart has been selected. As a result, we can simply
' apply bolding to the whole chart.
Else
With oChart.ChartArea.Format.TextFrame2.TextRange.Font
If GlobalSettings.IsBoldPressed = False Then
.Bold = False
.Name = FontsSettings.ActiveFonts.bodyFont
Else
.Bold = True
.Name = FontsSettings.ActiveFonts.headingFont
End If
End With
End If
ElseIf oShp.HasTextFrame Then
If oShp.TextFrame.HasText Then
Set oFont = oShp.TextFrame.TextRange.Font
checkBoldsNoStrikethrough oFont
End If
End If
Next
End Sub
And there is the sub that starts going through the chart elements. Most checks are outsourcing the Strikethrough hunt to yet another sub:
Sub RefontTypoChart(chrt As Chart)
On Error GoTo Errhandler
' Dim s As Series
Dim A As axis
' Dim scnt As Integer
Dim i As Integer
Dim oShp As Shape
Dim oTxtRange2 As TextRange2
Dim oTickLabels As TickLabels
Dim oLegendEntries As LegendEntries
Set oTxtRange2 = chrt.Format.TextFrame2.TextRange
If oTxtRange2.Font.Strikethrough = msoTrue Then
RefontTypoChartShapeRange oTxtRange2
Exit Sub
End If
If chrt.HasLegend Then
Set oLegendEntries = chrt.Legend.LegendEntries
For i = 1 To oLegendEntries.Count
With oLegendEntries(i).Font
If GlobalSettings.IsBoldPressed = False Then
If .Strikethrough = True Then
.Bold = False
.Name = FontsSettings.ActiveFonts.bodyFont
.Strikethrough = False
End If
Else
If .Strikethrough = True Then
.Bold = True
.Name = FontsSettings.ActiveFonts.headingFont
.Strikethrough = False
End If
End If
End With
Next
With chrt.Legend.Format.TextFrame2.TextRange.Font
If GlobalSettings.IsBoldPressed = False Then
If .Strikethrough = True Then
.Bold = False
.Name = FontsSettings.ActiveFonts.bodyFont
.Strikethrough = False
End If
Else
If .Strikethrough = True Then
.Bold = True
.Name = FontsSettings.ActiveFonts.headingFont
.Strikethrough = False
End If
End If
End With
End If
If chrt.HasTitle Then
Set oTxtRange2 = chrt.ChartTitle.Format.TextFrame2.TextRange
RefontTypoShapeRange oTxtRange2
End If
If chrt.HasAxis(xlCategory, xlPrimary) Then
Set A = chrt.Axes(xlCategory, xlPrimary)
If A.HasTitle = True Then
Set oTxtRange2 = A.AxisTitle.Format.TextFrame2.TextRange
RefontTypoShapeRange oTxtRange2
End If
Set oTickLabels = A.TickLabels
RefontTypoTickLabels oTickLabels
End If
If chrt.HasAxis(xlCategory, xlSecondary) Then
Set A = chrt.Axes(xlCategory, xlSecondary)
If A.HasTitle = True Then
Set oTxtRange2 = A.AxisTitle.Format.TextFrame2.TextRange
RefontTypoShapeRange oTxtRange2
End If
Set oTickLabels = A.TickLabels
RefontTypoTickLabels oTickLabels
End If
If chrt.HasAxis(xlValue, xlPrimary) Then
Set A = chrt.Axes(xlValue, xlPrimary)
If A.HasTitle = True Then
Set oTxtRange2 = A.AxisTitle.Format.TextFrame2.TextRange
RefontTypoShapeRange oTxtRange2
End If
Set oTickLabels = A.TickLabels
RefontTypoTickLabels oTickLabels
End If
If chrt.HasAxis(xlValue, xlSecondary) Then
Set A = chrt.Axes(xlValue, xlSecondary)
If A.HasTitle = True Then
Set oTxtRange2 = A.AxisTitle.Format.TextFrame2.TextRange
RefontTypoShapeRange oTxtRange2
End If
Set oTickLabels = A.TickLabels
RefontTypoTickLabels oTickLabels
End If
RefontTypoChartLabels chrt
If chrt.Shapes.Count > 0 Then
For Each oShp In chrt.Shapes
If oShp.HasTextFrame Then
If oShp.TextFrame.HasText Then
Set oTxtRange2 = oShp.TextFrame2.TextRange
RefontTypoShapeRange oTxtRange2
End If
End If
Next
End If
Exit Sub
Errhandler:
Debug.Print "Error: " & Err.Description
End Sub
Here is the sub that looks for most of the Strikethroughs:
Public Sub RefontTypoShapeRange(oTxtRange2 As TextRange2)
Dim i As Long
With oTxtRange2
For i = .Runs.Count To 1 Step -1
With .Runs(i).Font
If GlobalSettings.IsBoldPressed = False Then
If .Strikethrough = True Then
.Bold = False
.Name = FontsSettings.ActiveFonts.bodyFont
End If
Else
If .Strikethrough = True Then
.Bold = True
.Name = FontsSettings.ActiveFonts.headingFont
End If
End If
End With
Next
.Font.Strikethrough = False
End With
End Sub
You may notice that in the second sub posted, there are references to a few different subs that are specialized for certain chart elements. This is because TickLabels don't have a TextRange2 object and therefore need their own checker sub (one which passes along a TickLabels object). Also, there's a distinction made between chart elements that can have more than one formatting Run, and those that can't -- looking for Runs in the TextRange2 object of chart elements that don't support more than 1 run will cause a crash.
Public Sub RefontTypoChartShapeRange(oTxtRange2 As TextRange2)
Debug.Print "IN_RefontTypoChartShapeRange"
With oTxtRange2.Font
If GlobalSettings.IsBoldPressed = False Then
If .Strikethrough <> msoFalse Then
.Bold = False
.Name = FontsSettings.ActiveFonts.bodyFont
End If
Else
If .Strikethrough <> msoFalse Then
.Bold = True
.Name = FontsSettings.ActiveFonts.headingFont
End If
End If
.Strikethrough = False
End With
End Sub
Chart data labels are a small nightmare too, as they will become disconnected from the data if we don't massage the .Autotext property as seen below.
Sub RefontTypoChartLabels(oChrt As Chart)
Dim i As Integer
Dim j As Integer
Dim seriesVar As Series
Dim dataLabelsVar As DataLabels
Dim dataLabelVar As DataLabel
Dim pointVar As Point
Dim oTxtRange2 As TextRange2
Dim isAutoText As Boolean
For i = 1 To oChrt.SeriesCollection.Count
Set seriesVar = oChrt.SeriesCollection(i)
If seriesVar.HasDataLabels = True Then
Set dataLabelsVar = seriesVar.DataLabels
If dataLabelsVar.Format.TextFrame2.TextRange.Font.Strikethrough <> msoFalse Then
Set oTxtRange2 = dataLabelsVar.Format.TextFrame2.TextRange
RefontTypoChartShapeRange oTxtRange2
Else
For j = 1 To seriesVar.Points.Count
Set pointVar = seriesVar.Points(j)
If pointVar.HasDataLabel = True Then
Set dataLabelVar = seriesVar.DataLabels(j)
isAutoText = dataLabelVar.AutoText
Set oTxtRange2 = dataLabelVar.Format.TextFrame2.TextRange
RefontTypoChartShapeRange oTxtRange2
dataLabelVar.AutoText = isAutoText
End If
Next
End If
End If
Next
End Sub
Hopefully you're able to adapt some of this to your needs and avoid pulling out your hair. You can also use Shadow instead of Strikethrough if you think someone somewhere might need to use Strikethrough font inside a chart.
The PowerPoint object model doesn't provide any property or method for that.
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
I am trying to write a VBA macro in MS Word that creates a table with a Pie Chart insert inside a specific cell. The data for the Pie Chart would be requested by the macro. Below is what I have so far but I am having difficulty figuring out how to create the Pie Chart inside the table.
Sub InsertChart()
' Inserts a custom chart
Dim data1 As Variant
data1 = InputBox("What was the Moving Water damage value (enter as 0.0 - 1.0).")
Dim data2 As Variant
data2 = InputBox("What was the Settlement damage value (enter as 0.0 - 1.0).")
Dim data3 As Variant
data3 = InputBox("What was the Pre-Exisiting damage value (enter as 0.0 - 1.0).")
Dim i As Integer
i = ActiveDocument.Tables.Count
i = i + 1
' Create table if there is more than 1 table
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=5, NumColumns:=2
ActiveDocument.Tables(i).Cell(1, 2).Split NumColumns:=3
ActiveDocument.Tables(i).Cell(1, 3).Range.Text = "Quantity (Measurable Area):"
ActiveDocument.Tables(i).Cell(2, 1).Range.Text = "Description:"
ActiveDocument.Tables(i).Cell(3, 1).Range.Text = "Analysis:"
ActiveDocument.Tables(i).Cell(4, 1).Range.Text = "Cause(s) of Damage:"
ActiveDocument.Tables(i).Cell(5, 1).Range.Text = "Recommended Repairs:"
With ActiveDocument.Tables(i)
.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
.Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.Borders(wdBorderRight).LineStyle = wdLineStyleSingle
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
.Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
End With
Dim small As Boolean
small = False
Dim twoSeries As Boolean
twoSeries = False
Dim pieChart As Boolean
pieChart = True
Dim salesChart As Chart
Dim chartWorkSheet As Excel.Worksheet
With ActiveDocument.Tables(i)
.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
.Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.Borders(wdBorderRight).LineStyle = wdLineStyleSingle
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
.Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
End With
' Add in a new chart
Set salesChart = ActiveDocument.InlineShapes.AddChart.Chart
Set chartWorkSheet = salesChart.ChartData.Workbook.WorkSheets(1)
' Resize the chart area
chartWorkSheet.ListObjects("Table1").Resize chartWorkSheet.Range("A1:B4")
' Rename Series 1 as Sales
chartWorkSheet.Range("Table1[[#Headers],[Series 1]]").FormulaR1C1 = "Damage"
' Add data to the chart
chartWorkSheet.Range("A2").FormulaR1C1 = "Moving Water"
chartWorkSheet.Range("A3").FormulaR1C1 = "Settlement"
chartWorkSheet.Range("A4").FormulaR1C1 = "Pre-Exisiting"
chartWorkSheet.Range("B2").FormulaR1C1 = data1
chartWorkSheet.Range("B3").FormulaR1C1 = data2
chartWorkSheet.Range("B4").FormulaR1C1 = data3
' Quit Excel, since we no longer need it
salesChart.ChartData.Workbook.Application.Quit
' Put a box around the legend
salesChart.Legend.Format.Line.Visible = msoCTrue
' Fill the background with theme color accent 1
With salesChart.ChartArea.Format.Fill
.Visible = msoTrue
.Solid
.ForeColor.ObjectThemeColor = wdThemeColorAccent1
End With
' Add a title and format it
salesChart.HasTitle = True
With salesChart.ChartTitle
.Characters.Font.Italic = True
.Characters.Font.Size = 18
.Characters.Font.color = RGB(0, 0, 100)
.Text = "Damage"
End With
If small Then
' Size and move the chart
With salesChart.Parent
.Left = 100
.Width = 300
.Height = 150
End With
End If
If pieChart Then
' Set chart type
salesChart.ChartType = xl3DPie
End If
'Move chart to specific cell
ActiveDocument.Tables(i).Cell(1, 1).Select
Selection.Cut
ActiveDocument.Tables(i).Cell(4, 2).Select
Selection.Paste
ActiveDocument.Tables(i).Cell(1, 1).Range.Text = "Location:"
End Sub
Try this
salesChart.CopyPicture
salesChart.Delete
tbl.Cell(1, 1).Range.Select
Selection.PasteAndFormat (wdChartPicture)
Selection.Tables(1).AutoFitBehavior (wdAutoFitContent)
Add this after the last End If and before the End Sub
Screenshot
In my opinion it could be enough for you to put this single line before End Sub:
salesChart.Parent.ConvertToInlineShape
It convert chart from shape to inlineshape which will be located inside your table.
I did test it for empty document and it do what you want.
You could add this line later to autofit cell/column:
ActiveDocument.Tables(1).Columns(1).AutoFit
EDIT conversion to certain cell in table 1.
Do this conversion this way:
Dim InSHP As InlineShape
Set InSHP = salesChart.Parent.ConvertToInlineShape
InSHP.Range.Cut
ActiveDocument.Tables(1).Cell(4, 2).Range.Paste
In Excel VBA, I am able to access Each Point of RadarChart using
ActiveChart.FullSeriesCollection(1).Points(1).Select
and I am apply an image using
With Selection
.MarkerStyle = -4147
.MarkerSize = 5
End With
With Selection.Format.Fill
.Visible = msoTrue
.UserPicture FilePath + "Red.PNG"
End With
The Problem is this marker ends up with a Border
If I record a Macro to do the change and see code
Selection.Format.Line.Visible = msoFalse
is recorded, but if the same is run it causes the series line to disappear.
Can somebody help me with code to turn off the border.
You have to use .MarkerForegroundColorIndex = xlColorIndexNone
See this example
Option Explicit
Sub Sample()
Dim sc As Series, dp As Point
Dim FilePath As String
FilePath = "C:\"
Set sc = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
With sc
.MarkerStyle = -4147
.MarkerSize = 5
For Each dp In sc.Points
dp.MarkerForegroundColorIndex = xlColorIndexNone
Next
With .Format.Fill
.Visible = msoTrue
.UserPicture FilePath + "Red.PNG"
End With
End With
End Sub
BEFORE
AFTER