I need assistance to adapt my code.
Column E has 30 images of varying sizes that I want to centre in the cells starting with E5.
The code below only centres the images in cell E5. How do I adapt it centre all the images in each individual cell?
Sub aTest()
CenterMe ActiveSheet.Shapes(1), Range("E5")
End Sub
Sub CenterMe(Shp As Shape, OverCells As Range)
With OverCells
Shp.Left = .Left + ((.Width - Shp.Width) / 2)
Shp.Top = .Top + ((.Height - Shp.Height) / 2)
End With
End Sub
Sub CENTER_SHAPES()
Application.ScreenUpdating = False
Dim MyShape As Shape
For Each MyShape In ActiveSheet.Shapes
If MyShape.Type = msoPicture Then CenterMe MyShape, Range(MyShape.TopLeftCell.Address(False, False))
Next MyShape
Set MyShape = Nothing
Application.ScreenUpdating = True
End Sub
This code will loop every shape (image type) on active worksheet, and it will initiate your sub for centering. Hope it helps!
UPDATED ANSWER: Added ScreenUpdating=False because OP said it takes around 7 minutes.
Related
I am interested in applying the following VBA code to all slides in my powerpoint presentation. The code below resizes my table to the exact specifications I need. Do you have any advice on how to make this apply throughout my presentation? Thanks in advance.
Sub ResizeAlign()
With ActiveWindow.Selection.ShapeRange
.Height = 216
.Width = 864
.Left = 48
.Top = 198
ActiveWindow.Selection.ShapeRange.ZOrder msoSendToBack
End With
End Sub
The following macro will loop through each slide within the active presentation. Then, for each slide, it will loop through each shape within the slide until it finds a table, and then it formats the table.
Option Explicit
Public Sub ResizeAlignPresentation()
Dim currentSlide As Slide
For Each currentSlide In ActivePresentation.Slides
ResizeAlignSlide currentSlide
Next
End Sub
Private Sub ResizeAlignSlide(ByVal target As Slide)
Dim currentShape As Shape
For Each currentShape In target.Shapes
If currentShape.Type = msoTable Then
ResizeAlignTable currentShape
Exit For
End If
Next
End Sub
Private Sub ResizeAlignTable(ByVal table As Shape)
With table
Debug.Assert .Type = msoTable 'if code breaks here, we have a bug!
.Height = 216
.Width = 864
.Left = 48
.Top = 198
.ZOrder msoSendToBack
End With
End Sub
I have upped the last answer with this code I created (in need). I needed to run through all SlideMasters, all slides, all textboxes and put them on top. So they will always be in front of pictures etc.
Sub SetInFront()
Dim m, s, t, ma, sl, te
Set ma = ActivePresentation.Designs
For Each m In ma
Set sl = m.SlideMaster.CustomLayouts
For Each s In sl
Set te = s.Shapes
For Each t In te
If t.HasTextFrame Then
t.ZOrder 0
End If
Next t
Next s
Next m
End Sub
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've written a code to set pictures next to it's link in an excel sheet after it's done downloading. It is working smoothly but the problem is that every time i run the code it gets downloaded again and settled there. So if i delete one picture i see another one in that place. I hope there is a solution in if statement so that, if applied, it will omit downloading and go for the next loop if the cell is already filled in. I can't make it. If anybody helps me accomplish this, i would be very grateful. Thanks in advance.
Note: Links are in B column and pictures to get settled in C column.
Sub SetPics()
Dim pics As String
Dim myPic As Picture
Dim rng As Range
Dim cel As Range
Set rng = Range("C2", Range("B2").End(xlDown).Offset(0, 1))
For Each cel In rng
pics = cel.Offset(0, -1)
Set myPic = ActiveSheet.Pictures.Insert(pics)
With myPic
.ShapeRange.LockAspectRatio = msoFalse
.Width = cel.Width
.Height = cel.Height
.Top = Rows(cel.Row).Top
.Left = Columns(cel.Column).Left
End With
Next cel
End Sub
You need to scan the ActiveSheet (try not to use this, and replace it with Worksheets("YourSheetName")) for all Shapes.
For each Shape found, check it's TopLeftCell.Row property, if it equals the
cel.Row then the current picture already exists (from previous runs of this code), and you don't "re-insert" the picture.
Code
Sub SetPics()
Dim pics As String
Dim myPics As Shape
Dim PicExists As Boolean
Dim myPic As Picture
Dim rng As Range
Dim cel As Range
Set rng = Range("C2", Range("B2").End(xlDown).Offset(0, 1))
For Each cel In rng
PicExists = False ' reset flag
pics = cel.Offset(0, -1)
' loop through all shapes in ActiveSheet
For Each myPics In ActiveSheet.Shapes
If myPics.TopLeftCell.Row = cel.Row Then ' check if current shape's row equale the current cell's row
PicExists = True ' raise flag >> picture exists
Exit For
End If
Next myPics
If Not PicExists Then '<-- add new picture only if doesn't exist
Set myPic = ActiveSheet.Pictures.Insert(pics)
With myPic
.ShapeRange.LockAspectRatio = msoFalse
.WIDTH = cel.WIDTH
.HEIGHT = cel.HEIGHT
.Top = Rows(cel.Row).Top
.Left = Columns(cel.Column).Left
End With
End If
Next cel
End Sub
I'm looking at making a timeline within Excel that moves a 'window' (the white oval) along the timeline based on the date.
What I'm looking at doing is in VBA:
Setting a scale (where the whole arrow is a year)
Setting the oval's initial position
Setting the oval's new position (based on how far down the timeline the date is)
I'm completely new to VBA and was wondering if someone could please point me in the right direction?
Thanks!
Try...
Sub Macro1()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.Type = 1 Then
shp.Delete
End If
Next shp
ActiveSheet.Shapes.AddShape Type:=msoShapeOvalCallout, Left:=100, Top:=100, Width:=200, Height:=150
ActiveSheet.Shapes(1).TextFrame2.TextRange.Characters.Text = "Hello people!"
Application.ScreenUpdating = True
Application.Wait (Now + TimeValue("00:00:03"))
For i = 1 To 25 Step 1
ActiveSheet.Shapes(1).IncrementLeft -4
ActiveSheet.Shapes(1).IncrementTop i
Application.Wait (Now + 0.000009)
Next i
End Sub
How about?
Sub Macro1()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.Type = 1 Then
shp.Delete
End If
Next shp
If ActiveSheet.Range("A1").Value = 1 Then
ActiveSheet.Shapes.AddShape Type:=msoShapeOvalCallout, Left:=100, Top:=0, Width:=200, Height:=150
End If
If ActiveSheet.Range("A1").Value = 2 Then
ActiveSheet.Shapes.AddShape Type:=msoShapeOvalCallout, Left:=100, Top:=50, Width:=200, Height:=150
End If
'and so on...
End Sub
I've just inherited an Excel app that draws an org chart. Each shape is connected by a Line
However, I need to remove the shadow that is drawn when each line is added. How do I get a collection of Lines so that I can do something like
Line.Shadow.Transparency = 1.0
I'm a bit of a vba newbie :-)
This should do the trick - it loops through all shapes, checks if they're a line, then removes the shadow.
Sub test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim shapeObj
For Each shapeObj In ActiveSheet.Shapes
If shapeObj.Type = 9 Then
Dim objName$
objName = shapeObj.Name
ws.Shapes.Range(Array(objName)).Shadow.Visible = msoFalse
End If
Next shapeObj
End Sub
Edit: Turns out, per OP, the shapes are grouped, so he used this to get it:
Sub RemoveLineShadows()
For Each Shp In ORG.Shapes
If Shp.Type = msoGroup Then
For X = 1 To Shp.GroupItems.Count
If Shp.GroupItems(X).Type = msoLine Then
Shp.GroupItems(X).Shadow.Transparency = 1
End If
Next X
End If
Next Shp
End Sub
Sub qqq()
Dim x As Shape
For Each x In ActiveSheet.Shapes
x.Shadow.Visible = msoFalse
Next
End Sub