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
Related
I'm a new stackoverflow user so I'm not sure if I'm doing this right, but I'm trying to post a question on a previously given solution by Steve Rindsberg. I don't have enough reputation to comment, and there doesn't appear to be a way to message another user directly, so I'm posting a new question here.
I can't seem to get the code below to work. I'm using PowerPoint O365 Version 1901 and I have two type of shapes I'm trying to convert, msoChart and msoLinkedOLEObject (some Excel worksheets). I originally changed ppPasteEnhancedMetafile to ppPastePNG because I want PNG's, but it fails with either.
Here is the code:
Sub ConvertAllShapesToPic()
Dim oSl As Slide
Dim oSh As Shape
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
' modify the following depending on what you want to
' convert
Select Case oSh.Type
Case msoChart, msoEmbeddedOLEObject, msoLinkedOLEObject
ConvertShapeToPic oSh
Case msoPlaceholder
If oSh.PlaceholderFormat.ContainedType = msoEmbeddedOLEObject _
Or oSh.PlaceholderFormat.ContainedType = msoLinkedOLEObject _
Or oSh.PlaceholderFormat.ContainedType = msoChart _
Then
ConvertShapeToPic oSh
End If
Case Else
End Select
Next
Next
End Sub
Sub ConvertShapeToPic(ByRef oSh As Shape)
Dim oNewSh As Shape
Dim oSl As Slide
Set oSl = oSh.Parent
oSh.Copy
Set oNewSh = oSl.Shapes.PasteSpecial(ppPastePNG)(1)
With oNewSh
.Left = oSh.Left
.Top = oSh.Top
Do
.ZOrder (msoSendBackward)
Loop Until .ZOrderPosition < oSh.ZOrderPosition
End With
oSh.Delete
End Sub
I noticed if I run ConvertAllShapesToPic from an link/action in Slide Show mode, it doesn't complete and fails silently. If I add a Command Button (ActiveX control) and run it from there I get the following:
Run-time error '-2147188160 (80048240)':
Shapes (unknown member): Invalid request. The specified data type is unavailable.
It's failing on Set oNewSh = sld.Shapes.PasteSpecial(ppPastePNG)(1). After the error, if I go back to the slide and Ctrl-V I get the image, so I know it's working up to that point.
I've tried various solutions I found online for this such as adding DoEvents or ActiveWindow.Panes(1).Activate after the copy, but it doesn't seem to make a difference. Any suggestions?
Thanks
I found some other code to convert the charts and then I break links on the worksheets which automatically turns them in to images.
One thing I figured out was you must be out of slide show mode to break msoLinkedOLEObject links. I'm not 100% sure why... but this is the code that works for me:
Sub DoStuff()
Call LinkedGraphsToPictures
ActivePresentation.SlideShowWindow.View.Exit
Call BreakAllLinks
End Sub
Sub LinkedGraphsToPictures()
Dim shp As Shape
Dim sld As Slide
Dim pic As Shape
Dim shp_left As Double
Dim shp_top As Double
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoChart Then
'Retrieve current positioning
shp_left = shp.Left
shp_top = shp.Top
'Copy/Paste as Picture
shp.Copy
DoEvents
sld.Shapes.PasteSpecial DataType:=ppPastePNG
Set pic = sld.Shapes(sld.Shapes.Count)
'Delete Linked Shape
shp.Delete
'Reposition newly pasted picture
pic.Left = shp_left
pic.Top = shp_top
End If
Next shp
Next sld
End Sub
Sub BreakAllLinks()
Dim shp As Shape
Dim sld As Slide
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.Type = msoLinkedOLEObject Then
shp.LinkFormat.BreakLink
End If
Next shp
Next sld
End Sub
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.
I need to delete all shapes except command buttons. Or to delete just ovals, straight lines and drawn lines.
Sub deleteShapes()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp
End Sub
In this answer Jamie Bull deletes the shapes:
If Not (Shp.Type = msoOLEControlObject Or Shp.Type = msoFormControl) Then Shp.Delete
But how can I get my command buttons types? Or other objects types? I tried
Sub testShapes()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
MsgBox (shp.Type)
Next shp
End Sub
but it gives only numbers: 9, 5, 1, 12. I don't know which number is which shape. Is there any way to get an inner name like msoOLEControlObject or at least to make sure number 1 is really Command button?
A list of types is here: https://msdn.microsoft.com/en-us/VBA/Office-Shared-VBA/articles/msoshapetype-enumeration-office
All values are defined as constants in VBA, so you can write
if not shp.Type = msoOLEControlObject then
shp.Delete
end if
To get more infos about what kind of control you have:
Dim sh As Shape
For Each sh In Activesheet.Shapes
Debug.Print sh.Name, sh.Type
If sh.Type = msoFormControl Then
Debug.Print " msoFormControl:" & sh.FormControlType
End If
If sh.Type = msoOLEControlObject Then
Debug.Print " msoOLEControlObject: " & TypeName(sh.OLEFormat.Object.Object)
End If
Next sh
The FormControlType are shows here: https://msdn.microsoft.com/en-us/vba/excel-vba/articles/xlformcontrol-enumeration-excel - all are also defined as VBA constants
If you are using the default Names for the Shapes, then for Forms buttons:
Sub poiuyt()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If Left(shp.Name, 6) = "Button" Then
Else
shp.Delete
End If
Next shp
End Sub
and if the button are activex then:
Sub trewq()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If Left(shp.Name, 13) = "CommandButton" Then
Else
shp.Delete
End If
Next shp
End Sub
This approach is valid only if the Names are of the default type.
Alright, so for a PHP script, i need all non-image objects to be converted to images (excluding text) from a .pptx file. As i have quite a lot .pptx files, i tought that i might as well use VBA.
For some reason however, my Else If is acting weird.
Sub nieuwemacro()
Dim oSl As Slide
Dim oSh As Shape
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
' MsgBox (oSh.Type)
' modify the following depending on what you want to
' convert
If oSh.Type = 1 Then
ConvertShapeToPic oSh
Else
End If
Next
Next
End Sub
Sub ConvertShapeToPic(ByRef oSh As Shape)
Dim oNewSh As Shape
Dim oSl As Slide
oSh.Fill.ForeColor.RGB = RGB(0, 0, 0)
Set oSl = oSh.Parent
oSh.Copy
Set oNewSh = oSl.Shapes.PasteSpecial(ppPastePNG)(1)
With oNewSh
.Left = oSh.Left
.Top = oSh.Top
Do
.ZOrder (msoSendBackward)
Loop Until .ZOrderPosition = .ZOrderPosition
End With
oSh.Delete
End Sub
The oSh.Fill.ForeColor.RGB = RGB(0, 0, 0) part is just there to see what happens. And this is the result:
Alright.. So everything is converted properly, except for the big pink ball. So i thought i'd try some other Else ifs. My new Else If statement:
If oSh.Type = 1 Then
ConvertShapeToPic oSh
ElseIf oSh.Type = 14 Then
ConvertShapeToPic oSh
Else
End If
Resulting in this:
Notice how the code now doesnt convert the green bar at the top? It does that when i add or remove IfElse parts...
I don't know why it does this, could someone tell me what i'm doing wrong?
try this
Option Explicit
Sub nieuwemacro()
Dim oSl As Slide
Dim oSh As Shape
Dim oShs() As Shape
Dim nShps As Long, iShp As Long
For Each oSl In ActivePresentation.Slides
ReDim oShs(1 To oSl.Shapes.Count) As Shape
For Each oSh In oSl.Shapes
' MsgBox (oSh.Type)
' modify the following depending on what you want to
' convert
If oSh.Type = 1 Then
nShps = nShps + 1
Set oShs(nShps) = oSh
End If
Next
If nShps > 0 Then
For iShp = 1 To nShps
ConvertShapeToPic oShs(iShp)
Next iShp
End If
Next
End Sub
Sub ConvertShapeToPic(ByRef oSh As Shape)
Dim oNewSh As Shape
Dim oSl As Slide
oSh.Fill.ForeColor.RGB = RGB(0, 0, 0)
Set oSl = oSh.Parent
oSh.Copy
Set oNewSh = oSl.Shapes.PasteSpecial(ppPastePNG)(1)
With oNewSh
.Left = oSh.Left
.Top = oSh.Top
Do
.ZOrder (msoSendBackward)
Loop Until .ZOrderPosition = .ZOrderPosition
End With
oSh.Delete
End Sub
You may also want to consider the following refactoring:
Option Explicit
Sub nieuwemacro()
Dim oSl As Slide
Dim oShs() As Shape
For Each oSl In ActivePresentation.Slides
oShs = GetShapes(oSl, msoAutoShape) '<--| gather shapes of given type and...
ConvertShapesToPics oShs '<--| ...convert them
Next
End Sub
Function GetShapes(oSl As Slide, shType As MsoShapeType) As Shape()
Dim oSh As Shape
Dim nShps As Long
With oSl.Shapes '<--| reference passed slide Shapes collection
ReDim oShs(1 To .Count) As Shape '<--| resize shapes array to referenced slide shapes number (i.e. to maximum possible)
For Each oSh In .Range '<--| loop through referenced slide shapes
If oSh.Type = shType Then '<--| if its type matches the passed one
nShps = nShps + 1 '<--| update gathered shapes counter
Set oShs(nShps) = oSh '<--| fill gathered shapes array
End If
Next
End With
If nShps > 0 Then '<--| if any shape has been gathered
ReDim Preserve oShs(1 To nShps) As Shape '<--| resize array properly ...
GetShapes = oShs '<--| ... and return it
End If
End Function
Sub ConvertShapesToPics(oShs() As Shape)
Dim iShp As Long
If IsArray(oShs) Then '<--| if array has been initialized ...
For iShp = 1 To UBound(oShs) '<--|... then loop through its elements (shapes)
ConvertShapeToPic oShs(iShp) '<--| convert current shape
Next iShp
End If
End Sub
Sub ConvertShapeToPic(ByRef oSh As Shape)
With oSh '<--| reference passed shape
.Fill.ForeColor.RGB = RGB(0, 0, 0) '<--| change its forecolor
.Copy '<--| copy it
With .Parent.Shapes.PasteSpecial(ppPastePNG)(1) '<--| reference pasted shape
.Left = oSh.Left '<--| adjust its Left position
.Top = oSh.Top '<--| adjust its Top position
Do
.ZOrder (msoSendBackward)
Loop Until .ZOrderPosition = .ZOrderPosition
End With
.Delete '<--| delete referenced passed shape
End With
End Sub
Finally, you may want to shorten down "main" sub by two lines more like follwos
Sub nieuwemacro()
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
ConvertShapesToPics GetShapes(oSl, msoAutoShape) '<--| convert shapes of given type
Next
End Sub
where GetShapes(), ConvertShapesToPics() and ConvertShapeToPic() stays the same.
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