#1
|
|||
|
|||
Custom Autoshapes
I researched this awhile ago and never really figured out if it is possible. Does anyone know if there is anyway to make a shape with the freeform tool and then save it somehow to be a future autoshape that you can use. I'm sure you would have to export the drawn autoshape as a metafile or something then convert it and place it into the office11 folder located in the programs folder. |
#2
|
|||
|
|||
I don't think that's possible.
We usually have such things in a library presentation and then have code to open it invisibly , copy and paste the correct shape into the current slide. If the shape is simple it MIGHT be possible to recreate the shape using the FreeformBuilder method but the math is not simple for anything more than a very simple shape |
#3
|
|||
|
|||
Quote:
|
#4
|
|||
|
|||
I was really suggesting you stored the actual shapes in a presentation and wrote code to open it invisibly (WithWindow:=false) and then copy in code and paste ito the presentation in code. The effect is much like the normal Insert Shape method.
You can read up on the FreeformBuilder method but it is pretty complex. |
#5
|
|||
|
|||
Quote:
In a presentation I would create the shapes then probably name them something unique. Then write code in my working presentation that would paste this created/named shape into my current presentation without the shape presentation being open. If that is right can you give me a basic code? for example I would call the shape CustomShape1 in a presentation called CustomShapesPresentation located in the my documents folder. Thanks |
#6
|
|||
|
|||
Code:
Sub copyShape() Dim mylibrary As Presentation Dim osld As Slide 'open library file with NO window Set mylibrary = Presentations.Open(Environ("USERPROFILE") & "\My Documents\CustomShapesPresentation.ppt", WithWindow:=False) 'copy shape mylibrary.Slides(1).Shapes("CustomShape1").Copy 'paste into current slide ActiveWindow.View.Slide.Shapes.Paste 'close library mylibrary.Close End Sub If it's for client use I would hide the library file somewhere other than My Docs Last edited by JohnWilson; 03-27-2012 at 02:54 AM. |
#7
|
|||
|
|||
Quote:
|
#8
|
|||
|
|||
Here is the final result. I love adding an inputbox to give the ability to choose different shapes. Thanks again John
Sub copyShape() Dim mylibrary As Presentation Dim osld As Slide Dim shapebox As String shapebox = InputBox("type in the shape name") 'open library file with NO window Set mylibrary = Presentations.Open(Environ("USERPROFILE") & "\My Documents\CustomShapesPresentation.ppt", WithWindow:=False) 'copy shape mylibrary.Slides(1).Shapes(shapebox).Copy 'paste into current slide ActiveWindow.View.Slide.Shapes.Paste 'close library mylibrary.Close End Sub |
#9
|
|||
|
|||
Sorry to reactivate this thread but is there a way to do this same thing but by using a drop box to select the shape I want (Drop box would need to just be text)?
|
#10
|
|||
|
|||
You can only do this if you save all the code as ppa addin. (Otherwise the auto_run won't work)
You need to build a menu and use it to send the shape name. You'll need to work on this but it would look like: Code:
Public Const ADDIN_NAME As String = "the name goes here" Sub Auto_Open() Dim myMainMenuBar As CommandBar Dim myCustomMenu As CommandBarControl Dim myTempMenu As CommandBarControl On Error Resume Next 'kill any old menu Application.CommandBars.ActiveMenuBar.Controls(ADDIN_NAME).Delete Set myMainMenuBar = Application.CommandBars.ActiveMenuBar Set myCustomMenu = myMainMenuBar.Controls.Add(Type:=msoControlPopup, _ before:=3) 'new menu before the third existing menu myCustomMenu.Caption = ADDIN_NAME '************************ Set myTempMenu = myCustomMenu.Controls.Add(Type:=msoControlButton) With myTempMenu .Caption = "Whatever" .OnAction = "name_of_macro" End With '************************* Set myTempMenu = myCustomMenu.Controls.Add(Type:=msoControlButton) With myTempMenu .Caption = "Whatever2" .OnAction = "name_of_macro2" End With '************************* 'Add more blocks for more menu items End Sub Sub name_of_macro() Call insertshape("circle") 'obviously use your names End Sub Sub name_of_macro2() Call insertshape("square") End Sub Sub copyShape(shapebox As String) Dim mylibrary As Presentation Dim osld As Slide 'open library file with NO window Set mylibrary = Presentations.Open(Environ("USERPROFILE") & "\My Documents\CustomShapesPresentation.ppt", WithWindow:=False) 'copy shape mylibrary.Slides(1).Shapes(shapebox).Copy 'paste into current slide ActiveWindow.View.Slide.Shapes.Paste 'close library mylibrary.Close End Sub |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Custom Header | mayurnk | Word | 1 | 12-29-2010 09:35 PM |
Autoshapes disappear | nsv | Word | 0 | 09-29-2010 12:09 AM |
Custom CD | rkovelman | PowerPoint | 1 | 07-15-2010 08:50 AM |
Dimension Autoshapes | karthikcoep | Word | 0 | 01-16-2009 07:42 AM |
Unable to insert AutoShapes | earthling | Word | 0 | 01-01-2006 10:16 AM |