I want to insert an image on every page.
I know that the command is Next in a For loop.
Sub InsertImage()
Dim oILS As InlineShape, oShp As Shape
Set oILS = Selection.InlineShapes.AddPicture(FileName:= _
"C:\Users\" & LCase(Environ("UserName")) & "\Desktop\SubEscritorio3\Ejercicios Matemáticas\Barra.png", LinkToFile:=False, _
SaveWithDocument:=True)
Set oShp = oILS.ConvertToShape
With oShp
.WrapFormat.Type = wdWrapBehind
.Left = -55
.Top = 471.1
.Height = 21.5
.Width = 522
End With
End Sub
Well, I found the way to do it on all pages. If it helps anyone, here it is:
Sub Demo()
Dim Rng As Range, i As Long, Shp As Shape, ImageName As String
ImageName = "C:\Users\" & LCase(Environ("UserName")) & "\Desktop\SubEscritorio3\Ejercicios Matemáticas\Barra.png"
With ActiveDocument
Set Rng = .Range(0, 0)
For i = 1 To .ComputeStatistics(wdStatisticPages)
Set Rng = Rng.GoTo(What:=wdGoToPage, Name:=i)
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
Rng.Collapse wdCollapseStart
Set Shp = .InlineShapes.AddPicture(FileName:=ImageName, SaveWithDocument:=True, Range:=Rng).ConvertToShape
With Shp
.Left = -55
.Top = 471.1
.Width = 522
.Height = 21.5
.WrapFormat.Type = wdWrapBehind
End With
Next
End With
End Sub
Related
I have a macro for VBA PPT to fit contents of a slide to a specific predefined workarea, now I select the required shapes to be fit into workarea and run this tool slide by slide. can anybody suggest how can I select multiple slides and get all the shapes (except placeholders) in those slides fit to the same work area
Sub FitContents()
Dim shp, grid, ZenSmartGroup, ZenWorkGrid As Shape
Dim SelectShapes As Variant
Dim targetSlides As SlideRange
Dim thisSlide, oSld As Slide
Dim theseShapes As ShapeRange
Set thisSlide = ActivePresentation.Slides(1)
Dim GridTop, GridLeft, GridHeight, GridWidth As Single
If ActiveWindow.Selection.Type = ppSelectionSlides Then
Set targetSlides = ActiveWindow.Selection.SlideRange
End If
For Each oSld In targetSlides
For Each shp In oSld.Shapes
If Not ActivePresentation.Slides(1).Tags("Font Size") = "" Then
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Font.Size = ActivePresentation.Slides(1).Tags("Font Size")
End If
End If
End If
Next
If ActivePresentation.Slides(1).Tags("Grid Height") = "" Then
MsgBox "Please set grid size in Prezent Admin > Settings", vbInformation, "Set Grid Size"
End
End If
GridTop = ActivePresentation.Slides(1).Tags("Grid Top")
GridLeft = ActivePresentation.Slides(1).Tags("Grid Left")
GridHeight = ActivePresentation.Slides(1).Tags("Grid Height")
GridWidth = ActivePresentation.Slides(1).Tags("Grid Width")
oSld.Select
ActiveWindow.ViewType = ppViewSlide
ActiveWindow.Selection.ShapeRange.Group.Select
With ActiveWindow.Selection.ShapeRange(1)
.Top = GridTop
.Left = GridLeft
.LockAspectRatio = frmFitToGrid.chkAspectRatio
.Width = GridWidth
.Height = GridHeight
If frmFitToGrid.optHeight = True Then
.Height = GridHeight
End If
'If .Width > GridWidth Then
If frmFitToGrid.optWidth = True Then
.Width = GridWidth
End If
.Tags.Add "Type", "ZenSmartGroup"
.Name = "ZenSmartGroup"
End With
Set grid = oSld.Shapes.AddShape(msoShapeRectangle, GridLeft, GridTop, GridWidth, GridHeight)
grid.Fill.Visible = msoFalse
grid.Line.Visible = msoTrue
grid.Line.ForeColor.RGB = RGB(0, 255, 0)
grid.Line.Weight = 2.25
'grid.Select
grid.Name = "ZenWorkGrid"
SelectShapes = Array("ZenSmartGroup", "ZenWorkGrid")
'Set theseShapes = thisSlide.Shapes.Range(SelectShapes)
'theseShapes.Align msoAlignMiddles, msoFalse
'theseShapes.Align msoAlignCenters, msoFalse
Set ZenSmartGroup = oSld.Shapes("ZenSmartGroup")
Set ZenWorkGrid = oSld.Shapes("ZenWorkGrid")
'Align Middle (Horizontal Center)
If Not (frmFitToGrid.chkAlignLeft) Then
ZenSmartGroup.Top = ZenWorkGrid.Top + ((ZenWorkGrid.Height - ZenSmartGroup.Height) / 2)
End If
'Align Center (Vertical Center)
If Not (frmFitToGrid.chkAlignTop) Then
ZenSmartGroup.Left = ZenWorkGrid.Left + ((ZenWorkGrid.Width - ZenSmartGroup.Width) / 2)
End If
grid.Delete
'ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, msoFalse
'ActiveWindow.Selection.ShapeRange(1).Delete
'ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue
oSld.Shapes.Range.Ungroup
Next
End Sub
NOTE: code below serves as an example, as it cannot be tested given the information in your post. Please adapt it to your situation as needed.
I've included several (hopefully) helpful additions to your code in order to improve readability and maintainability. These include:
Error Checking - make sure the user has provided all the values required for the macro to effectively execute, and...
... declare your variables as close as possible to their first use.
Note the use of targetSlides as the focus object for all the selected slides. This way you avoid to continually reference ActivePresentation.Slides(1). (Note this was an assumption on my part, adjust the code as necessary)
'--- make sure the user has selected at least two slides
Dim targetSlides As SlideRange
If ActiveWindow.Selection.Type = ppSelectionSlides Then
Set targetSlides = ActiveWindow.Selection.SlideRange
Else
MsgBox "Please select two or more slides in the left-hand slide overview panel.", _
vbCritical + vbInformation + vbOKOnly, "Select Slides for Grids"
Exit Sub
End If
'--- make sure the grid values are set
If targetSlides(1).Tags("Grid Height") = vbNullString Then
MsgBox "Please set grid size in Prezent Admin > Settings", _
vbCritical + vbInformation + vbOKOnly, "Set Grid Size"
End
End If
'--- assumes ONLY the first slide in the target slides has the Grid tags
Dim gridTop As Long
Dim gridLeft As Long
Dim gridHeight As Long
Dim gridWidth As Long
Dim fontSize As Double
With targetSlides(1)
gridTop = .Tags("GRID TOP")
gridLeft = .Tags("GRID LEFT")
gridHeight = .Tags("GRID HEIGHT")
gridWidth = .Tags("GRID WIDTH")
fontSize = IIf(.Tags("FONT SIZE") <> vbNullString, .Tags("FONT SIZE"), 0#)
End With
Break code into separate subs or functions to increase the readability of the logic.
It's easy to get lose the overall point of the solution when you have to mentally summarize large blocks of code. In my example, the main logic loop is:
Dim sld As Slide
For Each sld In targetSlides
ResetTextSize fontSize, sld
Dim slideShapes As ShapeRange
Set slideShapes = SelectAllShapes(sld)
CreateShapeGrid sld, slideShapes, _
gridTop, gridLeft, gridHeight, gridWidth
Next
Before looking at the full solution below, look at some of the supporting subs and functions. Most especially, note the function IsPlaceholder which checks a Shape on any slide to see if it's part of the layout (and shouldn't be selected) or not.
Full code module:
Option Explicit
Sub FitContents()
'--- make sure the user has selected at least two slides
Dim targetSlides As SlideRange
If ActiveWindow.Selection.Type = ppSelectionSlides Then
Set targetSlides = ActiveWindow.Selection.SlideRange
Else
MsgBox "Please select two or more slides in the left-hand slide overview panel.", _
vbCritical + vbInformation + vbOKOnly, "Select Slides for Grids"
Exit Sub
End If
'--- make sure the grid values are set
If targetSlides(1).Tags("Grid Height") = vbNullString Then
MsgBox "Please set grid size in Prezent Admin > Settings", _
vbCritical + vbInformation + vbOKOnly, "Set Grid Size"
End
End If
'--- assumes ONLY the first slide in the target slides has the Grid tags
Dim gridTop As Long
Dim gridLeft As Long
Dim gridHeight As Long
Dim gridWidth As Long
Dim fontSize As Double
With targetSlides(1)
gridTop = .Tags("GRID TOP")
gridLeft = .Tags("GRID LEFT")
gridHeight = .Tags("GRID HEIGHT")
gridWidth = .Tags("GRID WIDTH")
fontSize = IIf(.Tags("FONT SIZE") <> vbNullString, .Tags("FONT SIZE"), 0#)
End With
Dim sld As Slide
For Each sld In targetSlides
ResetTextSize fontSize, sld
Dim slideShapes As ShapeRange
Set slideShapes = SelectAllShapes(sld)
CreateShapeGrid sld, slideShapes, _
gridTop, gridLeft, gridHeight, gridWidth
Next
End Sub
Sub ResetTextSize(ByVal fontSize As Double, ByRef sld As Slide)
'--- (re)set the font sizes in all shapes with text, as long
' as it's not a placeholder shape on the current slide
If fontSize > 0 Then
Dim shp As Shape
For Each shp In sld.Shapes
If Not IsPlaceholder(sld, shp) Then
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Font.Size = fontSize
End If
End If
End If
Next
End If
End Sub
Function IsPlaceholder(ByRef sld As Slide, ByRef shp As Shape) As Boolean
With sld.Shapes.Placeholders
IsPlaceholder = False
If .Count > 0 Then
Dim i As Long
For i = 1 To .Count
If .Item(i).Name = shp.Name Then
IsPlaceholder = True
Exit Function
End If
Next i
End If
End With
End Function
Function CollectionToArray(ByRef c As Collection) As Variant()
Dim a() As Variant: ReDim a(0 To c.Count - 1)
Dim i As Integer
For i = 1 To c.Count
a(i - 1) = c.Item(i)
Next
CollectionToArray = a
End Function
Function SelectAllShapes(ByRef sld As Slide) As ShapeRange
'--- creates a Collection of all the non-placeholder shape names, then
' convert the names to an array to create a ShapeRange object
Dim shp As Shape
Dim shps As Collection
Set shps = New Collection
For Each shp In sld.Shapes
If Not IsPlaceholder(sld, shp) Then
shps.Add shp.Name
End If
Next shp
If shps.Count > 0 Then
Dim shpsArray() As Variant
shpsArray = CollectionToArray(shps)
Set SelectAllShapes = sld.Shapes.Range(shpsArray)
Else
Set SelectAllShapes = Nothing
End If
End Function
Sub CreateShapeGrid(ByRef sld As Slide, ByRef slideShapes As ShapeRange, _
ByVal gridTop As Long, ByVal gridLeft As Long, _
ByVal gridHeight As Long, ByVal gridWidth As Long)
'--- position the group of shapes
With slideShapes.Group
.top = gridTop
.left = gridLeft
.LockAspectRatio = frmFitToGrid.chkAspectRatio
.width = gridWidth
.height = gridHeight
If frmFitToGrid.optHeight = True Then
.height = gridHeight
End If
'If .Width > GridWidth Then
If frmFitToGrid.optWidth = True Then
.width = gridWidth
End If
.Tags.Add "Type", "ZenSmartGroup"
.Name = "ZenSmartGroup"
End With
'--- now create a grid over the shapes
Dim grid As Shape
Set grid = sld.Shapes.AddShape(msoShapeRectangle, gridLeft, gridTop, gridWidth, gridHeight)
grid.Fill.Visible = msoFalse
grid.Line.Visible = msoTrue
grid.Line.ForeColor.RGB = RGB(0, 255, 0)
grid.Line.Weight = 2.25
'grid.Select
grid.Name = "ZenWorkGrid"
SelectShapes = Array("ZenSmartGroup", "ZenWorkGrid")
'Set theseShapes = thisSlide.Shapes.Range(SelectShapes)
'theseShapes.Align msoAlignMiddles, msoFalse
'theseShapes.Align msoAlignCenters, msoFalse
Set ZenSmartGroup = sld.Shapes("ZenSmartGroup")
Set ZenWorkGrid = sld.Shapes("ZenWorkGrid")
'Align Middle (Horizontal Center)
' If Not (frmFitToGrid.chkAlignLeft) Then
' ZenSmartGroup.Top = ZenWorkGrid.Top + ((ZenWorkGrid.Height - ZenSmartGroup.Height) / 2)
' End If
'
' 'Align Center (Vertical Center)
' If Not (frmFitToGrid.chkAlignTop) Then
' ZenSmartGroup.Left = ZenWorkGrid.Left + ((ZenWorkGrid.Width - ZenSmartGroup.Width) / 2)
' End If
grid.Delete
'ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, msoFalse
'ActiveWindow.Selection.ShapeRange(1).Delete
'ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue
slideShapes.Ungroup
End Sub
To get around the fact that the manual way to insert a pdf in a word don't give really good quality result.
I'm trying to insert pictures that have been nicely converted from a pdf to png with Imagemagick in a word with a macro.
The moment where i struggle is when i want the picture to get in a middle of each page and don't overlap each over.
I come up with this but i don't understand why it seems that AllowOverlap and wdShapeCenter do nothing while wdWrapTopBottom work properly. The picture get stuck to the top-left corner'
Sub Test()
Dim objShape As Shape
strPath = "Some.png"
'insert the image
Set objShape = ActiveDocument.Shapes.AddPicture( _
FileName:=strPath, LinkToFile:=False, _
SaveWithDocument:=True)
objShape.WrapFormat.AllowOverlap = False
objShape.Top = WdShapePosition.wdShapeCenter
objShape.WrapFormat.Type = wdWrapTopBottom
End Sub
I tried to use Selection.InlineShapes.AddPicture to resolve the overlap problem but i can't get the picture move from the top-left corner neither.
Thanks for your help
For example:
Sub Demo()
Application.ScreenUpdating = False
Dim Shp As Shape
With Dialogs(wdDialogInsertPicture)
.Display
If .Name <> "" Then
Set Shp = ActiveDocument.Shapes.AddPicture(FileName:=.Name, _
LinkToFile:=False, SaveWithDocument:=True, Anchor:=Selection.Range)
With Shp
.LockAspectRatio = True
.Height = InchesToPoints(2)
.RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
.Left = wdShapeCenter
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.Top = wdShapeCenter
.WrapFormat.AllowOverlap = False
End With
End If
End With
Application.ScreenUpdating = True
End Sub
With the above code, the inserted pic will be positioned in the center of the page. If there's already one centered there, the existing pic will be pushed down.
In light of your additional information, you should use something like:
Sub Demo()
Application.ScreenUpdating = False
Dim iShp As InlineShape, sWdth As Single, sHght As Single
With Dialogs(wdDialogInsertPicture)
.Display
If .Name <> "" Then
Set Shp = .InlineShapes.AddPicture(FileName:=.Name, _
LinkToFile:=False, SaveWithDocument:=True, Range:=Selection.Range)
With ActiveDocument.PageSetup
sWdth = .PageWidth - .LeftMargin - .RightMargin
sHght = .PageHeight - .TopMargin - .LeftMargin
End With
With iShp
.LockAspectRatio = True
.Width = sWdth
If .Height > sHght Then .Height = sHght
End With
End If
End With
Application.ScreenUpdating = True
End Sub
Finaly with your help I come up with this.
It center and place on it's own page pictures from a Folder.
Sub Folder_Picture_To_Word()
Dim shp As Shape
Dim intResult As Integer
Dim strPath As String
Dim strFolderPath As String
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
'the dialog is displayed to the user
intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
'checks if user has cancled the dialog
If intResult <> 0 Then
'dispaly message box
strFolderPath = Application.FileDialog(msoFileDialogFolderPicker _
).SelectedItems(1)
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(strFolderPath)
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'get file path
strPath = objFile.Path
Selection.InsertAfter ChrW(12)
'insert the image
Set shp = ActiveDocument.Shapes.AddPicture(FileName:=strPath, _
LinkToFile:=False, SaveWithDocument:=True, Anchor:=Selection.Range)
With shp
'.LockAspectRatio = True
'.Height = InchesToPoints(8)
.RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
.Left = wdShapeCenter
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.Top = wdShapeCenter
.WrapFormat.Type = wdWrapTopBottom
.WrapFormat.AllowOverlap = False
End With
'Go to next Page to get ready for a new picture
Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext
Next objFile
Selection.GoTo What:=wdGoToPage, Which:=wdGoToPrevious 'Go to second last page
'To delete the extra jump page made in the loop
Selection.Delete
End If
End Sub
I am trying to write a macro to insert a custom watermark in my Word document.
The code works perfectly for the first two pages of the document but thereafter the the Textbox does not rotate to -45 as mentioned in the code
What am I doing wrong?
Sub CustomWatermark()
Dim activeDoc As Document
Dim rngDoc As Range
Dim shpTextBox As Shape
Dim lngPages As Long
Dim i As Long
Dim strWatermark As String
Set activeDoc = ActiveDocument
lngPages = activeDoc.Range.Information(wdNumberOfPagesInDocument)
strWatermark = InputBox("Enter Watermark")
With activeDoc
For i = 1 To lngPages
Set rngDoc = .GoTo(What:=wdGoToPage, Name:=i)
rngDoc.Collapse wdCollapseStart
Set shpTextBox = .Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=InchesToPoints(1), _
Top:=InchesToPoints(4), _
Width:=InchesToPoints(6), _
Height:=InchesToPoints(2), _
Anchor:=rngDoc)
With shpTextBox
.Line.Visible = msoFalse
.Rotation = -45
.WrapFormat.Type = wdWrapBehind
.TextFrame.HorizontalAnchor = msoAnchorCenter
.TextFrame.VerticalAnchor = msoAnchorMiddle
With .TextFrame.TextRange
.Font.AllCaps = True
.Font.Size = "60"
.Font.ColorIndex = wdGray25
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Text = strWatermark
End With
End With
Next
End With
End Sub
It looks that, selecting all their range and doing rotation at once, works...
Sub CustomWatermarkBis()
Dim activeDoc As Document, rngDoc As Range, shpTextBox As Shape
Dim lngPages As Long, i As Long, strWatermark As String, shR As ShapeRange
Dim arrRot As Variant, k As Long
Set activeDoc = ActiveDocument
lngPages = activeDoc.Range.Information(wdNumberOfPagesInDocument)
ReDim arrRot(0 To lngPages - 1)
strWatermark = InputBox("Enter Watermark Text")
With activeDoc
For i = 1 To lngPages
Set rngDoc = .GoTo(What:=wdGoToPage, Name:=i)
rngDoc.Collapse wdCollapseStart
Set shpTextBox = .Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=InchesToPoints(1), _
Top:=InchesToPoints(4), _
Width:=InchesToPoints(6), _
Height:=InchesToPoints(2), _
Anchor:=rngDoc)
With shpTextBox.TextFrame.TextRange
.Font.AllCaps = True
.Font.Size = "60"
.Font.ColorIndex = wdGray25
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Text = strWatermark
End With
shpTextBox.Name = "T" & i
arrRot(k) = shpTextBox.Name: k = k + 1
Next
Set shR = .Shapes.Range(arrRot)
End With
With shR
.Select
.Line.Visible = msoFalse
.Rotation = -45
.WrapFormat.Type = wdWrapBehind
.TextFrame.HorizontalAnchor = msoAnchorCenter
.TextFrame.VerticalAnchor = msoAnchorMiddle
End With
Selection.Collapse
End Sub
Re-ordering your code to add the text before changing the rotation should solve the issue. It certainly does for me in Word 365.
EDIT: That approach worked for me exactly twice and now I can't repeat it. Adding the text box to the header does work reliably though, and results in a much tidier document.
Sub CustomWatermarkInHeader()
Dim activeDoc As Document
Dim rngDoc As Range
Dim strWatermark As String
Dim docSection As Section
Dim shpTextBox As Shape
Set activeDoc = ActiveDocument
strWatermark = InputBox("Enter Watermark")
With activeDoc
For Each docSection In .Sections
Set rngDoc = docSection.Headers(wdHeaderFooterPrimary).Range
rngDoc.Collapse wdCollapseStart
Set shpTextBox = .Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=InchesToPoints(1), _
Top:=InchesToPoints(4), _
Width:=InchesToPoints(6), _
Height:=InchesToPoints(2), _
Anchor:=rngDoc)
With shpTextBox
With .TextFrame
.HorizontalAnchor = msoAnchorCenter
.VerticalAnchor = msoAnchorMiddle
With .TextRange
.Font.AllCaps = True
.Font.Size = "60"
.Font.ColorIndex = wdGray25
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Text = strWatermark
End With
End With
.Line.Visible = msoFalse
.Rotation = -45
.WrapFormat.Type = wdWrapBehind
End With
Next
End With
End Sub
However, you may want to consider:
adding the text box to the header instead of cluttering your document with a text box on every page. You will achieve the same result with fewer text boxes.
Using the built-in functionality to add a custom watermark. You can find this on the Design tab of the ribbon.
Instead of:
.Rotation = -45
Try:
.ThreeD.IncrementRotationZ -45
https://learn.microsoft.com/en-us/office/vba/api/word.threedformat
I want to loop though only a specific set of charts in one sheet and then apply to those a set of formating (title font size, title position, axis size, grid lines formating etc.)
The problem ist that there are already 66 charts on that sheet that were manually created (1 to 66). I will now add more charts but automatically generated, and only for those ones I would like to apply the formating needed.
For now I managed to create the charts and apply the formating separately. But in order to make it more fluid I would require a loop that I have not figured out yet. My idea was/is to count all Charts on the sheet and then do something like "If cnt > 66 Then "put here the code starting from the cht.Activate line".
My problem is counting all the charts. I am guessing using something like
with For -> For i to .CharObjects(i). But maybe you can suggest a different way.
Public Sub TEST()
Dim rng As Range, rng1 As Range, rng2 As Range, rng3 As Range
Dim cht As ChartObject, cht1 As ChartObject, cht2 As ChartObject, cht3 As ChartObject
Dim LastRow As Long
Dim wsG As Worksheet: Set wsG = ThisWorkbook.Worksheets("Charts")
Dim wsS As Worksheet: Set wsS = ThisWorkbook.Worksheets("Scatter Raw")
LastRow = wsS.Cells(wsS.Rows.count, "A").End(xlUp).Row
Set rng1 = wsS.Range("A4:B" & LastRow)
Set rng2 = wsS.Range("H4:I" & LastRow)
Set rng3 = wsS.Range("O4:P" & LastRow)
Set cht1 = wsG.ChartObjects.Add(Range("A595").Left, Range("A595").Top, Width:=518.5, Height:=296.7)
Set cht2 = wsG.ChartObjects.Add(Range("M595").Left, Range("M595").Top, Width:=518.5, Height:=296.7)
Set cht3 = wsG.ChartObjects.Add(Range("Y595").Left, Range("Y595").Top, Width:=518.5, Height:=296.7)
cht1.Chart.SetSourceData Source:=rng1
cht1.Chart.ChartType = xlXYScatter
cht1.ShapeRange.LockAspectRatio = msoTrue
cht1.Activate
With ActiveChart
.FullSeriesCollection(1).Name = "=""NAME 1"""
.ChartTitle.Text = "TITLE 1"
End With
cht2.Chart.SetSourceData Source:=rng2
cht2.Chart.ChartType = xlXYScatter
cht2.ShapeRange.LockAspectRatio = msoTrue
cht2.Activate
With ActiveChart
.FullSeriesCollection(1).Name = "=""NAME 2"""
.ChartTitle.Text = "TITLE 2"
End With
cht3.Chart.SetSourceData Source:=rng3
cht3.Chart.ChartType = xlXYScatter
cht3.ShapeRange.LockAspectRatio = msoTrue
cht3.Activate
With ActiveChart
.FullSeriesCollection(1).Name = "=""NAME 3"""
.ChartTitle.Text = "TITLE 3"
End With
For Each cht In wsG.ChartObjects
cht.Activate
With ActiveChart
.Legend.Delete
.ChartTitle.Font.Size = 14
.ChartTitle.Select
With Selection.Format.TextFrame2.TextRange.Font.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.150000006
.Transparency = 0
.Solid
End With
Selection.Left = 27.536
Selection.Top = 5
.ChartArea.Select
With Selection.Format.Line
.Visible = msoFalse
End With
With .Axes(xlValue).TickLabels.Font
.Size = 11
End With
.Axes(xlValue).Select
Selection.Format.Line.Visible = msoFalse
.Axes(xlValue).MajorGridlines.Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorBackground1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = -0.25
.Transparency = 0
.Visible = msoTrue
.DashStyle = msoLineDash
End With
End With
Next cht
End Sub
If you want to ignore Chart 3 and Chart 2, add these two names to an array. Then check whether the chart object has name from this array and act accordingly:
Public Sub TestMe()
Dim myChart As ChartObject
Dim chartCount As Long
Dim cnt As Long
Dim chartNamesToExclude As Variant
chartNamesToExclude = Array("Chart 3", "Chart 2")
For Each myChart In Worksheets(1).ChartObjects
If Not valueInArray(myChart.Name, chartNamesToExclude) Then
cnt = cnt + 1
myChart.Chart.ChartTitle.Text = "Title" & cnt
End If
Next myChart
End Sub
Public Function valueInArray(myValue As Variant, myArray As Variant) As Boolean
Dim cnt As Long
For cnt = LBound(myArray) To UBound(myArray)
If CStr(myValue) = CStr(myArray(cnt)) Then
valueInArray = True
Exit Function
End If
Next cnt
End Function
The code above loops through all the charts in Worksheets(1) and changes their titles accordingly to Title N. It ignores the charts with names Chart 3 and Chart 2, by seeing that these are in chartNamesToExclude array.
Thanks Vityata. You solution worked but I think I have found what I was looking for in the beginning. I am not sure if it is better, but it does the job also. Here it is. Cheers, Daniel
Private Sub newtest()
Dim rng As Range, rng1 As Range, rng2 As Range, rng3 As Range
Dim cht As ChartObject, cht1 As ChartObject, cht2 As ChartObject, cht3 As ChartObject
Dim LastRow As Long
Dim wsG As Worksheet: Set wsG = ThisWorkbook.Worksheets("Charts Radio")
Dim wsS As Worksheet: Set wsS = ThisWorkbook.Worksheets("Scatter Raw")
Dim i As Long
For i = 67 To wsG.ChartObjects.count
wsG.ChartObjects(i).Activate
With ActiveChart
.Legend.Delete
.ChartTitle.Font.Size = 14
.ChartTitle.Select
With Selection.Format.TextFrame2.TextRange.Font.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0.150000006
.Transparency = 0
.Solid
End With
Selection.Left = 27.536
Selection.Top = 5
'Added more formating / code here
End With
Next
End Sub
Sub InsertLogo1()
ActiveCell.Select
ActiveSheet.Pictures.Insert("Path").Select
End Sub
Dim Pic As Object
Set Pic = ActiveSheet.Pictures.Insert(Directory & "\" & filename)
With Pic
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.LockAspectRatio = msoTrue
.Width = 225#
End With