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
Related
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 have typed some image locations in some cells and hyperlinked them. when i click this cells, a macro will be executed and fills a rectangle shape with pictures specified in those cells. this is the macro:
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Row = ActiveCell.Row
col = ActiveCell.Column
ActiveSheet.Shapes.Range(Array("Rectangle 38")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.UserPicture ActiveSheet.Cells(Row, col).Value
End With
End Sub
it works but the picture is stretched. i want the picture to be fitted inside my shape. in excel , as you might know , after filling a shape with picture,there is a fit button under crop option. when you click it, it fits the image inside the picture box and maintains the size of shape. i want to do the exact thing only in VBA.
Use the shape properties of .PictureWidth , .PictureHeight , .PictureOffsetX = .PictureOffsetY.
Code example:
Option Explicit
Public Sub AddPicAndAdjust()
Dim shp As ShapeRange
Set shp = ActiveSheet.Shapes.Range(Array("Rectangle 1"))
With shp.Fill
.Visible = msoTrue
.UserPicture "C:\Users\User\Pictures\MyNicePic.png" '<== Add pic
.TextureTile = msoFalse
.RotateWithObject = msoTrue
End With
'Positioning within fill
With shp.PictureFormat.Crop
.PictureWidth = 231
.PictureHeight = 134
.PictureOffsetX = 50
.PictureOffsetY = 28
End With
With shp
.LockAspectRatio = msoFalse
.IncrementLeft 2
End With
End Sub
I'm adding ".jpg" files to my Excel sheet with the code below :
'Add picture to excel
xlApp.Cells(i, 20).Select
xlApp.ActiveSheet.Pictures.Insert(picPath).Select
'Calgulate new picture size
With xlApp.Selection.ShapeRange
.LockAspectRatio = msoTrue
.Width = 75
.Height = 100
End With
'Resize and make printable
With xlApp.Selection
.Placement = 1 'xlMoveAndSize
'.Placement = 2 'xlMove
'.Placement = 3 'xlFreeFloating
.PrintObject = True
End With
I don't know what I am doing wrong but it doesn't get inserted into the right cell, so what should I do to put this picture into a specified cell in Excel?
Try this:
With xlApp.ActiveSheet.Pictures.Insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 75
.Height = 100
End With
.Left = xlApp.ActiveSheet.Cells(i, 20).Left
.Top = xlApp.ActiveSheet.Cells(i, 20).Top
.Placement = 1
.PrintObject = True
End With
It's better not to .select anything in Excel, it is usually never necessary and slows down your code.
Looking at posted answers I think this code would be also an alternative for someone. Nobody above used .Shapes.AddPicture in their code, only .Pictures.Insert()
Dim myPic As Object
Dim picpath As String
picpath = "C:\Users\photo.jpg" 'example photo path
Set myPic = ws.Shapes.AddPicture(picpath, False, True, 20, 20, -1, -1)
With myPic
.Width = 25
.Height = 25
.Top = xlApp.Cells(i, 20).Top 'according to variables from correct answer
.Left = xlApp.Cells(i, 20).Left
.LockAspectRatio = msoFalse
End With
I'm working in Excel 2013. Also realized that You need to fill all the parameters in .AddPicture, because of error "Argument not optional". Looking at this You may ask why I set Height and Width as -1, but that doesn't matter cause of those parameters are set underneath between With brackets.
Hope it may be also useful for someone :)
If it's simply about inserting and resizing a picture, try the code below.
For the specific question you asked, the property TopLeftCell returns the range object related to the cell where the top left corner is parked. To place a new image at a specific place, I recommend creating an image at the "right" place and registering its top and left properties values of the dummy onto double variables.
Insert your Pic assigned to a variable to easily change its name. The Shape Object will have that same name as the Picture Object.
Sub Insert_Pic_From_File(PicPath as string, wsDestination as worksheet)
Dim Pic As Picture, Shp as Shape
Set Pic = wsDestination.Pictures.Insert(FilePath)
Pic.Name = "myPicture"
'Strongly recommend using a FileSystemObject.FileExists method to check if the path is good before executing the previous command
Set Shp = wsDestination.Shapes("myPicture")
With Shp
.Height = 100
.Width = 75
.LockAspectRatio = msoTrue 'Put this later so that changing height doesn't change width and vice-versa)
.Placement = 1
.Top = 100
.Left = 100
End with
End Sub
Good luck!
I have been working on a system that ran on a PC and Mac and was battling to find code that worked for inserting pictures on both PC and Mac. This worked for me so hopefully someone else can make use of it!
Note: the strPictureFilePath and strPictureFileName variables need to be set to valid PC and Mac paths Eg
For PC: strPictureFilePath = "E:\Dropbox\" and strPictureFileName = "TestImage.jpg" and with Mac: strPictureFilePath = "Macintosh HD:Dropbox:" and strPictureFileName = "TestImage.jpg"
Code as Follows:
On Error GoTo ErrorOccured
shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Select
ActiveSheet.Pictures.Insert(Trim(strPictureFilePath & strPictureFileName)).Select
Selection.ShapeRange.Left = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Left
Selection.ShapeRange.Top = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Top + 10
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 130
Firstly, of all I recommend that the pictures are in the same folder as the workbook.
You need to enter some codes in the Worksheet_Change procedure of the worksheet. For example, we can enter the following codes to add the image that with the same name as the value of cell in column A to the cell in column D:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim pic As Picture
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
On Error GoTo son
For Each pic In ActiveSheet.Pictures
If Not Application.Intersect(pic.TopLeftCell, Range(Target.Offset(0, 3).Address)) Is Nothing Then
pic.Delete
End If
Next pic
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 2).Top
Selection.Left = Target.Offset(0, 3).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Target.Offset(0, 2).Height
Selection.ShapeRange.Width = Target.Offset(0, 3).Width
son:
End Sub
With the codes above, the picture is sized according to the cell it is added to.
Details and sample file here : Vba Insert image to cell
I tested both #SWa and #Teamothy solution. I did not find the Pictures.Insert Method in the Microsoft Documentations and feared some compatibility issues. So I guess, the older Shapes.AddPicture Method should work on all versions. But it is slow!
On Error Resume Next
'
' first and faster method (in Office 2016)
'
With ws.Pictures.Insert(Filename:=imageFileName, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = destRange.Width
.height = destRange.height '222
End With
.Left = destRange.Left
.Top = destRange.Top
.Placement = 1
.PrintObject = True
.Name = imageName
End With
'
' second but slower method (in Office 2016)
'
If Err.Number <> 0 Then
Err.Clear
Dim myPic As Shape
Set myPic = ws.Shapes.AddPicture(Filename:=imageFileName, _
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=destRange.Left, Top:=destRange.Top, Width:=-1, height:=destRange.height)
With myPic.OLEFormat.Object.ShapeRange
.LockAspectRatio = msoTrue
.Width = destRange.Width
.height = destRange.height '222
End With
End If
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
I have to create almost 200 charts of time series. So I tried to write a macro that finishes most of the work I need to do.
I generated names for the time series like this as an example:
Name:= AKB_ExampleA
The name refers to a dynamic range which I declared with this formula:
=OFFSET('sheet1'!$C$7:$C$137;0;0;COUNT('sheet1'!$C$7:$C$206))
So now to the macro I coded so far:
Sub graphik_erstellen()
Call graphik1("AKB")
End Sub
Sub graphik(Name As String)
'
Dim Ch As Chart
Dim RngToCover As Range
Set Ch = charts.Add
Set Ch = Ch.Location(Where:=xlLocationAsObject, Name:="Charts")
With Ch
.ChartType = xlLine
.SetSourceData Source:=Range(Name & "_ExampleA")
.SeriesCollection(1).XValues = Range("Datum_Volumen")
.SeriesCollection(1).Name = "SERIES1"
.FullSeriesCollection(1).Select
With Selection.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(192, 0, 0)
.Transparency = 0
End With
.HasTitle = True
.ChartTitle.Text = Name & ", Volumen (nach Korrektur)"
.HasLegend = True
.Legend.Position = xlLegendPositionBottom
.Legend.Select
Selection.Format.TextFrame2.TextRange.Font.Size = 11
Selection.Format.TextFrame2.TextRange.Font.Bold = msoTrue
With .Parent
.top = 100
.left = 100
.height = 287.149606299
.width = 543.685039370078
.Name = Name & "_chart"
End With
End With
End Sub
My problem is, that if I do that, the dynamic range is not really considered. It takes the range of the name (which is $C$7:$C$137) but it should refer to the name itself (in order to be dynamic).
So if I click on the chart to see the series, the series values are declared as: ='sheet1'!$C$7:$C$137 instead of ='sheet1'!ExampleA.
I would be really, really grateful if somebody could help me out.
Best
Elio
I have rearranged a few lines of code and tried to place comments refering to them as well.
Let me know what works. Youjust might need to change SeriesCollection to FullSeriesCollection. Other than that the code works in my Excel 2010.
The first Sub I just get the Range size according to the data available in Column "C" from Row 7.
Let me know.
Option Explicit
Sub graphik_erstellen()
'You always want to use direct reference to a sheet/range chart
'Refering to the WorkBook they are in and the worksheet as well.
'especially if you are opening multiple WorkBooks / Sheets
Dim CurrentWorkSheet As Worksheet
Set CurrentWorkSheet = Workbooks("Book1").Worksheets("Sheet1")
'Dynamically finding the end of the data in Column C
Dim LastRow As Long
LastRow = CurrentWorkSheet.Cells(CurrentWorkSheet.Rows.Count, "C").End(xlUp).Row
'Setting the range using the document reference aswell
Dim AKB As Range
Set AKB = Workbooks("Book1").Worksheets("Sheet1").Range(Cells(7, "C"), Cells(LastRow, "C"))
Call graphik(AKB)
End Sub
Sub graphik(Name As Range)
Dim DataChart As Chart
Dim RngToCover As Range
Set DataChart = Workbooks("Book1").Charts.Add
'With Excel 2010 the line above will automatically add the chart as a sheet and not aobject in a sheet
'Set DataChart = DataChart.Location(Where:=xlLocationAsObject, Name:="Charts")
With DataChart
.Name = "Charts" ' This will be the Name of the CHart Tab
.ChartType = xlLine
.SetSourceData Source:=Name
'You can see below I avoided the Select and Selection
With .SeriesCollection(1)
'Using Offset I just used the data one cell to the left of the range
.XValues = Name.Offset(0, -1)
.Name = "SERIES1"
With .Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(192, 0, 0)
.Transparency = 0
End With
End With
.HasTitle = True
.ChartTitle.Text = "MIDDEL TOP TEXT" 'Name & ", Volumen (nach Korrektur)"
.HasLegend = True
With .Legend
.Position = xlLegendPositionBottom
.Format.TextFrame2.TextRange.Font.Size = 11
.Format.TextFrame2.TextRange.Font.Bold = msoTrue
End With
'Not sure about this, it doesnt work in my Excel 2010
'
With .Parent
.Top = 100
.Left = 100
.Height = 287.149606299
.Width = 543.685039370078
.Name = Name & "_chart"
End With
End With
End Sub
Let me know what your intention is for the Sheet and Chart names and then I can help with getting that to what you need as well.