Macro help needed

[AArunkumar]

Hi all,

Hope you all doing great!!

I am new to this forum! However, I am a regular follower of Chandoo.org!

I need you help with macro! I am also new to vba I created one. However, I am unable to provide a link to my tasks.

So here is my requirement.

I require three macros.

1. Get height, width, position of a shape (let's say "shape 1") selected in a powerpoint slide. Copy it to clipboard.

2. Macro to paste height and width of a "shape 1" to the selected shape (let's say "shape 2").

3. Macro to paste position of "shape 1" to the selected shape (let's say "shape 3").

The reason why i require in split is because in some places i require only height and width and in some places in require all three or height alone.

Your help is greatly appreciated!!

Thanks much,
Arun

 

[Hui]

Arun

Firstly, Welcome to the Chandoo.org Forums

Have you considered that this is an Excel based forum/website

Have you looked for a Powerpoint website/Forum ?

 

[AArunkumar]

Ah! Sorry about it.. i checked some forums. however still i am unable to get the required answer. is it still feasible to help me with the query?


Thanks,
Arun

 

[Hui]

Try these 2 codes in a code module in VBA

Sub Copy_Properties_to_Clipboard()

Dim myTxt As String

' Get properties
With Windows(1).Selection.ShapeRange(1)
  myTxt = "Left: " + CStr(.Left) + Chr(10)
  myTxt = myTxt + "Width: " + CStr(.Width) + Chr(10)
  myTxt = myTxt + "Top: " + CStr(.Top) + Chr(10)
  myTxt = myTxt + "Height: " + CStr(.Height)
End With

'Make object's text equal above string variable
 
  CopyText myTxt

End Sub

Sub CopyText(Text As String)
  'VBA Macro using late binding to copy text to clipboard.
  'By Justin Kay, 8/15/2014
  Dim MSForms_DataObject As Object
  Set MSForms_DataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  MSForms_DataObject.SetText Text
  MSForms_DataObject.PutInClipboard
  Set MSForms_DataObject = Nothing
End Sub


Sub Copy_Properties_to_Shape2()
'Shape 1 is the Second shape you select
'Shape 2 is the First shape you select

' Get properties and assign to shape 2
With Windows(1).Selection.ShapeRange(2)
  Windows(1).Selection.ShapeRange(1).Left = .Left
  Windows(1).Selection.ShapeRange(1).Width = .Width
  Windows(1).Selection.ShapeRange(1).Top = .Top
  Windows(1).Selection.ShapeRange(1).Height = .Height
End With

End Sub

to use

Select a Shape
Run Copy_Properties_to_Clipboard

Select two Shapes
Run Copy_Properties_to_Shape2

Note comments in the Copy_Properties_to_Shape2 code

 

[AArunkumar]

Hey!!! Awesome!!! Million Thanks!! That works for me.

 

[AArunkumar]

Hi Hui,

Thanks a lot for your help!!

I have a query on this code which i would like to have your advice.

The first code copies the properties to clipboard. However, I just want to know why in second code we select two shapes. The code works perfectly. However, my problem is shapes which i am applying properties might also be in differnt slides.

Please let me know your thoughts.

Thanks much!

Regards,
arun

 

[Hui]

Because I have to interpret your request

Macro to paste position of "shape 1" to the selected shape (let's say "shape 3").

So I interpreted as exactly that

If you want to explain what you want please be more specific.

Have you looked at using the Format Painter icon?


But I don't think it pastes sizes

 

[Hui]

You can use the following two subs to assist you here

Dim sngL As Single
Dim sngT As Single
Dim sngH As Single
Dim sngW As Single

Sub Pick_Up_Format()
'picks up format of selected shape
Dim oshp As Shape
On Error Resume Next
Err.Clear
Set oshp = ActiveWindow.Selection.ShapeRange(1)
If Err <> 0 Then
  MsgBox "Select a shape!"
Else
  sngL = oshp.Left
  sngT = oshp.Top
  sngW = oshp.Width
  sngH = oshp.Height
  oshp.PickUp
End If
End Sub

Sub Apply_Format()
' Apply to all selected shapes
Dim oshp As Shape
On Error Resume Next
Err.Clear
If sngH = 0 And sngW = 0 Then
  MsgBox "Pick up format first."
  Exit Sub
End If
For Each oshp In ActiveWindow.Selection.ShapeRange
  If Err <> 0 Then
      MsgBox "Select a shape!"
  Else
      oshp.Left = sngL
      oshp.Top = sngT
      oshp.Width = sngW
      oshp.Height = sngH
      End If
Next oshp
End Sub

To use this:
Select the first shape
Alt+F8 Run the Pick_Up_Format macro
Goto the second slide
Pick a shape
Alt+F8 Run the Apply_Format code

You could assign these to Buttons if you are going to use them regularly

 

[AArunkumar]

Hey,

That works!!! Sorry for the confusion.. This is theone i am looking for. You are a life saver.

Thanks much,
Arun