I have a shape in a Word document that I need to move to a bookmark location.
I tried to use the "left" and "top" properties, however, this does not work because to my knowledge, bookmark does not have "left" and "right properties.
I have tried to use cut and paste, but this does not work for shapes.
The following is the code to create the shape:
Set shp = ActiveDocument.Content.InlineShapes.AddOLEControl("Forms.CommandButton.1")
With ActiveDocument.InlineShapes(1).OLEFormat.Object
.Caption = "Test"
.Height = 30
.Width = 44
End With
With ActiveDocument.InlineShapes(1).ConvertToShape
.Name = "Test1"
.ZOrder (msoBringInFrontOfText)
End With
Instead of using a bookmark could you use an Absolute Position on the document somewhere?
Dim Test1 As Shape
Set Test1 = ActiveDocument.Shapes("Test1")
With Test1
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Left = InchesToPoints(6.889)
.Top = InchesToPoints(0.374)
End With
End Sub
This is a very old thread, but the basic premise is still valid, and it is possible to insert a control at a bookmarked location (here a bookmark named 'bmShape') using VBA as shown below.
Dim oRng As Range
Dim oShp As InlineShape
Set oRng = ActiveDocument.Bookmarks("bmShape").Range
oRng.Text = ""
Set oShp = oRng.InlineShapes.AddOLEControl("Forms.CommandButton.1")
oRng.End = oRng.End + 1
oRng.Bookmarks.Add "bmShape"
With oShp.OLEFormat.Object
.Caption = "Test"
.Height = 30
.Width = 44
End With
With oShp.ConvertToShape
.Name = "Test1"
.WrapFormat.Type = wdWrapSquare
.WrapFormat.Side = wdWrapBoth
End With
Related
I currently work for a recruiting firm and I'm trying to write a program that will post my company's Logo on the Top Left Corner of a resume.
Some resumes have content in the header, some don't. I made two if's statements to address both circumstances, but for some odd reason, it does not seem to work.
This is my code below:
Dim i As Long
Dim FooterText As String
Dim Logo As Shape
Dim HeaderExists As Section
'Header:
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Set HeaderExists = ActiveDocument.Sections(1)
Set Logo = Selection.InlineShapes.AddPicture(FileName:="My company logo", _
LinkToFile:=False, SaveWithDocument:=True).ConvertToShape
If HeaderExists.Headers(wdHeaderFooterFirstPage).Exists = False Then
With Logo
.WrapFormat.Type = wdWrapBehind
.Left = -67
.Top = -30
.Width = 107
.Height = 48
End With
End If
If HeaderExists.Headers(wdHeaderFooterFirstPage).Exists = True Then
With Logo
.WrapFormat.Type = wdWrapBehind
.Left = 5
.Top = 5
.Width = 107
.Height = 48
End With
End If
As of right, the code only works for resumes WITH content in the Header. For some reason, when I change wdHeaderFooterPrimary to wdFooterFirstPage, it flips, and only works for resumes WITHOUT content in the Header.
Unless you want to logo to appear on every page, you'll need to apply a 'different first page' layout to documents that don't already have it. Then you'll need to decide what to do with documents that didn't have that layout but had a header, since the existing header will now only appear on the 2nd & subsequent pages (if there is more than one page). In the following code, I've enforced a 'different first page' layout, which obviates any concerns about what happens in your problem scenario, and have assumed the header & logo are only to appear on the first page:
Sub Demo()
Application.ScreenUpdating = False
Dim Sctn As Section, Rng As Range, Shp As Shape
Set Sctn = ActiveDocument.Sections.First
With Sctn
If .PageSetup.DifferentFirstPageHeaderFooter = False Then
'Apply a Different First Page layout
.PageSetup.DifferentFirstPageHeaderFooter = True
Set Rng = .Headers(wdHeaderFooterFirstPage).Range
With Rng
'Replicate the original Primary header
If Sctn.Headers(wdHeaderFooterPrimary).Range.Text <> "" Then
.FormattedText = Sctn.Headers(wdHeaderFooterPrimary).Range.FormattedText
.Characters.Last.Delete
End If
End With
'Delete the original Primary header
Sctn.Headers(wdHeaderFooterPrimary).Range.Text = vbNullString
End If
With Rng
.Collapse wdCollapseStart
'Add the logo
Set Shp = .InlineShapes.AddPicture(FileName:="My company logo", _
LinkToFile:=False, SaveWithDocument:=True).ConvertToShape
'Adjust the logo's formatting
With Shp
.WrapFormat.Type = wdWrapBehind
.Left = 5
.Top = 5
.LockAspectRatio = True
.Width = 107
End With
End With
End With
Application.ScreenUpdating = True
End Sub
If the document has multiple Sections, you'll also need to consider what to do with their page layouts & headers.
I have basic Macro and VBA knowledge yet cannot get my head around where I am going wrong here. (Code inserted at the bottom) I want my macro to move a selected image into the top centre of the page. The issue I am facing is that it will not work for each image in the document, it works for the first one then no longer performs the task. I am using Microsoft Word 2016.
The main command does what I want it to, I feel my error is within these two lines
Set myDocument = ActiveDocument
With myDocument.Shapes(1)
Whole code;
Sub AlignToCentre()
'
' AlignToCentre
Dim shp As Shape
Set myDocument = ActiveDocument
With myDocument.Shapes(1)
.WrapFormat.Type = wdWrapSquare
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.Left = wdShapeCenter
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = InchesToPoints(1)
End With
End Sub
If you want this to work with the selected image, and only the selected image, then more like this, where you get the Shape from the current selection.
Note how you should first check to make sure a Shape is selected...
Sub PositionSelectedShape()
Dim sel As word.Selection
Dim shp As word.Shape
Set sel = Selection
If sel.Type = wdSelectionShape Then
Set shp = sel.ShapeRange(1)
With shp
.WrapFormat.Type = wdWrapSquare
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.Left = wdShapeCenter
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = InchesToPoints(1)
End With
End If
End Sub
Exactly like Kim Raaness has suggested, you need to loop through all shapes of you would like to centre them all.
Try something like this:
Sub AlignToCentre()
'
' AlignToCentre
Dim shp As Shape
Set myDocument = ActiveDocument
For Each shp in myDocument.Shapes
With shp
.WrapFormat.Type = wdWrapSquare
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.Left = wdShapeCenter
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = InchesToPoints(1)
End With
Next shp
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
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.
How do I select a picture inside an active cell? I am trying to make a macro that inserts a picture and resizes it to the size of the cell. With some help, I have made the following code to insert the picture:
ActiveCell.Select
Dim picname As String
picname = ActiveCell.Value
ActiveCell.Offset(-1, 0).Select
ActiveSheet.Pictures.Insert "C:\Users\Briet\Documents\PAJ\pic-presentation\Images\" & picname & ".jpg"
Once the picture is inserted, its container cell is selected, but not the actual picture. So the following code, which resizes the picture to the cell, does not work:
On Error GoTo NOT_SHAPE
Dim PicWtoHRatio As Single
Dim CellWtoHRatio As Single
With Selection
PicWtoHRatio = .Width / .Height
End With
With Selection.TopLeftCell
CellWtoHRatio = .Width / .RowHeight
End With
Select Case PicWtoHRatio / CellWtoHRatio
Case Is > 1
With Selection
.Width = .TopLeftCell.Width
.Height = .Width / PicWtoHRatio
End With
Case Else
With Selection
.Height = .TopLeftCell.RowHeight
.Width = .Height * PicWtoHRatio
End With
End Select
With Selection
.Top = .TopLeftCell.Top
.Left = .TopLeftCell.Left
End With
Exit Sub
NOT_SHAPE:
MsgBox "Select a picture before running this macro."
Insert() returns a reference to the inserted picture, so you can work directly with that.
Sub Tester()
Dim shp, rng As Range
Set rng = ActiveSheet.Range("C3")
Set shp = ActiveSheet.Pictures.Insert("C:\_Stuff\pic.jpg")
With shp
.Top = rng.Top
.Left = rng.Left
.ShapeRange.LockAspectRatio = msoTrue
.Width = .Width / Application.Max(.Width / rng.Width, _
.Height / rng.Height)
End With
End Sub
You aren't able to adjust the picture if you have the cell selected. You need to select the picture itself. According to this question on SO, the Pictures collection is undocumented. When I googled it, I couldn't find it either. I believe that once you have the cell selected you can get the picture object from the ShapeRange collection. It has a required argument of index, but if you only have one shape, that value should be 1. Hopefully this points you in the right direction.