I want to move image from one location in excel to another using VBA.
How can we do that?
If you need to change the position of the image within a given worksheet, you can use something like this:
ActiveSheet.Shapes.Range(Array("Picture 1")).Select
Selection.ShapeRange.IncrementLeft 100
You can adjust the direction and amount of motion by changing the parameters of the .Increment... command, to animate an image for example.
Another example : move a picture vertically to line up with a specific row
Sheets(1).Shapes("Picture 1").Top = Sheets(1).Rows(24).Top
If we are going quick and dirty and need to move between sheets the following works
Sub CutAndPasteAPicture(shapeName As String, fromSheet As String, toSheet As String, toRange As String)
'Cut and Paste
Sheets(fromSheet).Shapes(shapeName).Cut
Sheets(toSheet).Paste Sheets(toSheet).Range(toRange)
End Sub
Sub Example()
CutAndPasteAPicture "Picture 1", "Sheet1", "Sheet2", "D2"
End Sub
Here is the code to first insert picture to Excel and then adjust or resize the Picture. Later move the Picture towards down or right
'Insert the Picture from the path if its not present already
Set myPict = Thisworkbook.sheets(1).Range("A1:B5").Parent.Pictures.Insert(ThisWorkbook.Path & "\" & "mypic.jpg")
'Adjust the Picture location
myPict.Top = .Top
myPict.Width = .Width
myPict.Height = .Height
myPict.Left = .Left
myPict.Placement = xlMoveAndSize
'myPict.LockAspectRatio = msoTriStateMixed
'Change the width of the Picture
myPict.Width = 85
'change the Height of the Picutre
myPict.Height = 85
End With
'Select the Picutre
myPict.Select
'Move down the picture to 3 points. Negative value move up
Selection.ShapeRange.IncrementTop 3
'Move towards right upto 5 points. Negative value moves towards right
Selection.ShapeRange.IncrementLeft 5
Related
I would like to create a macro which will change the "Vertical Alignment" to "Middle" of the selected rows/cells in a PowerPoint table. Can anyone pls help me with this.
Below example snapshot attached.
Below is the code. My code is perfectly working with the shape but could't work for the tables. pls assist.
ActiveWindow.Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
To approach a table you can not use the Shape Object, but need to use Tables.
You can also format only Cell by Cell so you need to run a loop through all Rows and Columns
-----edited-----
To use the selected cells you have to iterate through all cells and see if they are selected
Sub SelectedCells()
Dim oTbl As table
Dim iIdx As Integer
Dim iIdy As Integer
Set oTbl = ActiveWindow.Selection.ShapeRange(1).table
For iIdx = 1 To oTbl.Rows.Count
For iIdy = 1 To oTbl.Columns.Count
If oTbl.Cell(iIdx, iIdy).Selected Then
With oTbl.Cell(iIdx, iIdy).Shape
.TextFrame.VerticalAnchor = msoAnchorTop
End With
End If
Next
Next
End Sub
Win10x64 Office 365 PPT v 16.0.12325.202080 64-bits
I need to show a character with a yellow font color but a black outline, for readability purposes. This character goes inside a Powerpoint table Cell.
The following link has a method that I'm currently using that consists of creating a dummy shape, adding text to it, modify the shape's textframe2 textrange font line properties and then copying it and pasting it back to the table cell.
http://www.vbaexpress.com/forum/archive/index.php/t-43787.html
This was asked 8 years ago, but I'm currently seeing the same behaviour where we can't directly manipulate the textframe2 wordart format of text inside a cell. The program doesn't show an error but doesn't work.
I have given up on trying to modify the textrame2 textrange font line properties directly from VBA.
I have managed to get it to activate the font outline color using
Application.CommandBars.ExecuteMso ("TextOutlineColorPicker")
After it's activated I thought I could modify the textframe2 textrange font line properties, but it still doesn't work.
Is there an Application.CommandBars idMso for changing the font outline color and font outline line width inside a table cell?
Or another other than pasting the formatted text inside a table cell.
Edit:
Adding an image to illustrate what I mean by text color and text outline color and the menu used to show them in red circle:
Edit2
Added another snapshot to exemplify a character inside a cell with black outline and a character inside a cell without an outline
Thanks
Here's an example to access a Table on a given slide and change one cell's attributes. The example slide I'm using looks like this
The code itself creates a function that allows you to select a table from a particular slide, and a single cell within the table and highlight it.
Option Explicit
Sub test()
HighlightTableCell 1, 2, 3
End Sub
Sub HighlightTableCell(ByVal slideNumber As Long, _
ByVal thisRow As Long, _
ByVal thisCol As Long)
Dim theSlide As Slide
Set theSlide = ActivePresentation.Slides(slideNumber)
Dim shp As Shape
For Each shp In theSlide.Shapes
If shp.Type = msoTable Then
Dim theTable As Table
Set theTable = shp.Table
With theTable.Cell(thisRow, thisCol)
With .Shape.TextFrame2.TextRange.Characters.Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 0)
.Transparency = 0
.Solid
End With
With .Shape.TextFrame2.TextRange.Characters.Font.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
End With
End With
End If
Next shp
End Sub
This question should be answered by Microsoft Office developers.
Currently, to overcome this bug-some situation, I think, copying the formatted text outside the table and pasting it into a table cell is the only work-around for this trouble.
As you mentioned, according to John Wilson, one of the most brilliant PowerPoint MVPs(http://www.vbaexpress.com/forum/archive/index.php/t-43787.html), if we copy the text from a textbox or shape that is located outside of the table, the format of the text can be preserved even for the text in a table cell.
Option Explicit
Sub test()
Dim shp As Shape, tshp As Shape
Dim sld As Slide
Dim tbl As Table
Dim r%, c%
If ActiveWindow.Selection.Type = ppSelectionNone Then MsgBox "Select a table first.": Exit Sub
Set shp = ActiveWindow.Selection.ShapeRange(1)
Set sld = shp.Parent
'add a temporary textbox for copying the formatted text into a cell
Set tshp = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 541, 960, 540)
tshp.Visible = False
Set tbl = shp.Table
For r = 1 To tbl.Rows.Count
For c = 1 To tbl.Columns.Count
'1) cell -> 'tshp'
tbl.Cell(r, c).Shape.TextFrame2.TextRange.Copy
tshp.TextFrame2.TextRange.Paste
'2) outline the text in 'tshp'
With tshp.TextFrame2.TextRange.Font.Line
.Visible = msoTrue
.Weight = 0.2
.ForeColor.RGB = RGB(255, 127, 127)
End With
'3) 'tshp' -> cell
tshp.TextFrame2.TextRange.Copy
tbl.Cell(r, c).Shape.TextFrame2.TextRange.Paste
'// the code below doesn't work
'With tbl.Cell(r, c).shape.TextFrame2.TextRange.Characters.Font.Line
'With tbl.Cell(r, c).shape.TextFrame2.TextRange.Font.Line
' .Visible = msoTrue
' .Weight = 0.5
' .ForeColor.RGB = RGB(255, 127, 127)
'End With
Next c
Next r
'remove the tempoarary textbox
tshp.Delete
End Sub
The above snippet creates a temporary textbox on left-top area of the slide and applies the outlined text format. Then, it copies the content of each cell to the temporary textbox and copy/paste the formatted text back to the cell. By using this method, we can apply the outlined text format to the text in a cell.
I have many powerpoint files which have a picture at the top-right corner on every single slide. It is neither a master slide, NOT a custom layout shape.
They were pasted one by one to all slides.
I have some codes as below to remove all shapes(pictures) from slides, but how to locate the shapes(pictures) at a specific location of a slide?
For Each Slide In SlideList
Set sldTemp = ActivePresentation.Slides(Slide)
For lngCount = sldTemp.Shapes.Count To 1 Step -1
With sldTemp.Shapes(lngCount)
'----------Delete All shapes = picture----------
If .Type = msoPicture Then
.Delete
End If
End With
Next
Next
'-----------------------------------------
I am not very good at VBA for powerpoint coding, any suggestion is appreciated.
thank you.
You can check the position by looking at the Top and Left properties. You could also check the size if they're all the same size.
Eg:
If .Type = msoPicture Then
If .Top > x and .Top < y and .Left > a and .Left < b Then
.Delete
Exit For
End If
End If
Where x,y, a and b are variables or hard-coded values.
thanks to Tim Williams very much.
The pilot codes run correctly on 3 Win10 x86 computers.
by the way, according to this saying
By default, the size of the new presentation in PowerPoint, is currently a widescreen type presentation, 13.333 inch by 7.5 inch. Mostly you will have 96 dots per inch (dpi) on your screen settings, so this means that a default PowerPoint presentation has a resolution of 1280 by 720 pixels.
though the top-left values set below can match exactly the top-right small logo(shape) in my powerpoint slide, and the same results from 3 different display ,and one of which is in low definition mode.
Sub DeleteAllTopRightShapes()
Dim sldTemp As Slide
Dim lngTemp As Long
Dim lngCount As Long
For Each sldTemp In ActivePresentation.Slides
For lngCount = sldTemp.Shapes.Count To 1 Step -1
With sldTemp.Shapes(lngCount)
If .Type = msoPicture Then
If .Top >= 0 And .Top < 60 And .Left >= 400 Then
.Delete
End If
End If
End With
Next
Next
MsgBox "Process complete!"
End Sub
I have a folder which contains a spreadsheet. Alongside this spreadsheet (within the same folder which the spreadsheet is contained in), is a folder named "images". This folder may have anywhere between 0 and 10,000 images contained within it as separate png files.
The files are named like this:
00001.png
...
00010.png
...
00100.png
...
01000.png
...
10000.png
(where "..." symbolised a gap between multiple files, keep in mind that the files increase in increments of 1, e.g: 00001.png is directly followed by 00002.png).
I require that the aforementioned spreadsheet (contained within the same folder as the "images" folder, but not within the "images" folder itself) is able to pull through however many of these images happen to be present to the 10,000 long cell range of 'C3:C10002' (C3 to C10002).
The images should only be pulled through if present and if not present, the spreadsheet / VBA macro/script should not crash to the detriment of the user.
This is extremely likely to require an Excel VBA macro of some sort that can be run at the press of a button (I know how to insert macro buttons).
The script should not alter the size/dimensions of the image(s). Containing cells should have their width and height adjusted to fit the images perfectly.
I understand that Excel cells have a maximum height / width and that the images will have to be pre-optimised to fit the cells. I'd like the images to display as thumbnails of roughly 3 inches wide by 1.6 inches tall (unsure what that is in pixels!)
I'd greatly appreciate any help... Even if you can't suggest something which accomplishes all of this, "best shots" will be warmly welcome.
I have this code that helps add an image to the sheet, you could modify it to loop within multiple files and add the image file based on the file name:
Sub AddPictures()
DirForImages = "S:\TCarnevale\Overdrive Images\"
Dim counter As Integer
Dim vsn As Boolean
Dim myrange As Range
ActiveSheet.Pictures.Delete
Range("Y15").Select
For I = 0 To 400
DoEvents
'Set picture range depending on count, *modify below set of code to add/remove styles*
Set Rng = Range("A8")
'get the style number to pull the image from the directory
styleinfo = ActiveCell.Value
If Dir(DirForImages & styleinfo & ".jpg") <> "" Then
Set pic = ActiveSheet.Shapes.AddPicture(DirForImages & styleinfo & ".jpg", False, True, 1, 1, 1, 1)
'resize the image
With pic
.Height = 100
.Width = 75
.Left = Rng.Left
.Top = Rng.Top
End With
counter = counter + 1
ElseIf Dir(DirForImages & styleinfo & ".png") <> "" Then
Set pic = ActiveSheet.Shapes.AddPicture(DirForImages & styleinfo & ".png", False, True, 1, 1, 1, 1)
'resize the image
With pic
.Height = 100
.Width = 75
.Left = Rng.Left
.Top = Rng.Top
'
End With
counter = counter + 1
Else
counter = counter + 1
End If
ActiveCell.Offset(1, 0).Select
Next
Range("Y17").Select
Range("A1").Select
End Sub
This code is checking for PNG files as well as JPG files and re sizing them in pixels. You can use this calculator to convert inches to pixels.
I don't see this working out the way you expect.
First of all, trying to display 10,000 PNG files in a spreadsheet strikes me as a seriously bad idea. The memory requirements could easily lock up your computer or crash Excel.
Secondly, settings cell sizes in VBA can be confusing. Cell height is specified in points by default, while width is measured based on the default font.
https://support.office.com/en-ca/article/Change-the-column-width-and-row-height-72f5e3cc-994d-43e8-ae58-9774a0905f46
Third, you'll need to have images with the correct dimensions and ppi/dpi resolution. Excel respects printing dimensions, so a 300 pixel image at 96ppi will display differently than a 300 pixel image at 150ppi.
Fourth, displays aren't measured in inches like paper sizes. Modern displays have a variety of resolutions, from 72dpi on the low end to over 300dpi for some mobile devices and Retina/HiDPI screens. This will affect how large on-screen a picture will look.
Having said all that:
I would batch process images in a program like Photoshop to set them (for your needs) at 300 pixels wide, 96ppi.
I would NOT try to show 10,000 images in a spreadsheet. Divide it up into several files.
Finally, some quickly cobbled-together code that might be a starting point:
Dim InsertLoc As Range
Dim i As Integer
Dim PName As String
Sub Macro1()
i = 2
PName = ""
Columns("A:A").ColumnWidth = 43
Application.ScreenUpdating = False
For i = 1 To 10
Set InsertLoc = Range("A" & CStr(i))
InsertLoc.Select
PName = "C:\Users\user\Desktop\" & i & ".jpg"
Rows(i).RowHeight = 150
On Error Resume Next
ActiveSheet.Pictures.Insert PName
Next i
Application.ScreenUpdating = True
End Sub
I am working on a Excel Spreadsheet that when a dropdown box value is selected an image will pop up, and if another value is selected it will hide the current image and pop up the image related to the selection. I have found a few methods that are just too time consuming using just the sheet and positioning of the image using coordinates; that's not exactly the route I would like to go.I have done a quite a bit of research before using StackOverflow, and nothing seemed to work thus far. Below is what I am trying to achieve. I am trying to keep all the images within the spreadsheet which adds another level of challenge, but I believe there is a way to do this because excel assigns the image a number when inserted EX. Picture 9.
Sub Main()
If Range(G11).Value = "anything" Then
Picture1 show
Picture2 hide
End If
End Sub
Any Help is greatly appreciated. Thanks
Rather than hiding/moving/reducing the size of the unwanted pic, why not simply delete it?
Logic:
Save all your images in a temp sheet. When ever a relevant picture is supposed to be shown, get it from the temp sheet and delete the previous.
Here is an example.
Sub Sample()
Select Case Range("G11").Value
Case "Picture 1": ShowPicture ("Picture 1")
Case "Picture 2": ShowPicture ("Picture 2")
Case "Picture 3": ShowPicture ("Picture 3")
Case "Picture 4": ShowPicture ("Picture 4")
End Select
End Sub
Sub ShowPicture(picname As String)
'~~> The reason why I am using OERN is because it is much simpler
'~~> than looping all shapes and then deleting them. There could be
'~~> charts, command buttons and other shapes. I will have to write
'~~> extra validation code so that those shapes are not deleted.
On Error Resume Next
Sheets("Sheet1").Shapes("Picture 1").Delete
Sheets("Sheet1").Shapes("Picture 2").Delete
Sheets("Sheet1").Shapes("Picture 3").Delete
Sheets("Sheet1").Shapes("Picture 4").Delete
On Error GoTo 0
Sheets("Temp").Shapes(picname).Copy
'<~~ Alternative to the below line. You may re-position the image
'<~~ after you paste as per your requirement
Sheets("Sheet1").Range("G15").Select
Sheets("Sheet1").Paste
End Sub
Snapshot of temp sheet
Here is a solution using the Visible property of the object.
I used this to show a picture based on a value in a field.
The field had a formula that resulted in either "good" or "bad".
If its value was "good", I wanted to show one picture; for "bad", another picture should show; and they should never show at the same time.
The field needed to update its value whenever a user refreshed a pivot table, so I put the code in that method of the worksheet where the pivot table and picture were to appear.
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
'hide both pictures by loopng through all the shapes on the sheet
Dim s As Shape
For Each s In ActiveSheet.Shapes
'hide the shape if it is a picture, leave other shapes on the page visible.
If s.Type = msoPicture Then s.Visible = msoFalse
Next
Dim judgement As String
'The field whose value tells what picture to use is a one-cell named range called "judgement"
judgement = Range("judgement")
'you need to know which picture is which.
If judgement = "Good" Then ActiveSheet.Shapes("Picture 8").Visible = True
If judgement = "Bad" Then ActiveSheet.Shapes("Picture 1").Visible = True
End Sub
Sub hidePicture(myImage)
ActiveSheet.Shapes.Range(Array(myImage)).Select
Selection.ShapeRange.Height = 0
Selection.ShapeRange.Width = 0
End Sub
Sub showPicture(myImage)
ActiveSheet.Shapes.Range(Array(myImage)).Select
Selection.ShapeRange.Height = 200
Selection.ShapeRange.Width = 300
End Sub
Handy tip: record macro and look at the code it generates!
Might be better just to move your pictures "off screen", particularly if they're of different sizes.
Sub Tester()
ShowPicture "Picture 3"
End Sub
Sub ShowPicture(PicName As String)
Dim s As Shape
For Each s In ActiveSheet.Shapes
With s
.Top = IIf(.Name = PicName, 100, 100)
.Left = IIf(.Name = PicName, 100, 1000)
End With
Next s
End Sub