I can't seem to figure out how to drop a shape using VBA.
What I want to do is: The user opens a UserForm and enters something in the TextBoxes. When clicking on the commandbutton I want to load a Shape (i.e. ressource) from a custom stencil (i.e. shapes.vssx) write the User-Entries into the ShapeData (i.e. write a Name string in Props.Name) and then Drop it somewhere on the sheet. I know I have to use the Shape.Drop method but how do I reference the specific Master-Shape I want to use for creating the new shape?
So far I am trying with this
Private Sub CommandButton1_Click()
Dim shp As Visio.Shape
Dim page As Visio.page
Set page = Application.ActiveWindow.page
Set shp = Application.Documents.Item("shapes.vssx").Masters.ItemU("ressource")
page.Drop shp, 1, 1
End Sub
Which returns a type mismatch. What am I missing?
You're looking to drop a Master rather than a Shape so try this modification of your code (untested):
Private Sub CommandButton1_Click()
Dim mst as Visio.Master
Dim shp As Visio.Shape
Dim pag As Visio.page
Set pag = Application.ActiveWindow.Page
Set mst = Application.Documents.Item("shapes.vssx").Masters.ItemU("ressource")
'You might also want to add some checks that the target document and then master exist
Set shp = pag.Drop(mst, 1, 1)
End Sub
Related
I have this task where i need to find some type of hybridshapes and collect them in a listbox
i have done that part, but i need to create it in such a way that when user selects a item from the list box respective hybridshape or object should get selected in catia
here is the image
here is the code
Option Explicit
Dim ODoc As Document
Dim opartdoc As PartDocument
Dim oPart As Part
Dim ohybs As HybridBodies
Dim ohyb As HybridBody
Dim ohybshps As HybridShapes
Dim ohybshp As HybridShape
Dim i As Integer
Dim j As Integer
Private Sub UserForm_Initialize()
Set ODoc = CATIA.ActiveDocument
Set opartdoc = CATIA.ActiveDocument
Set oPart = opartdoc.Part
End Sub
Private Sub ListBtn_Click()
Set ohybs = oPart.HybridBodies
Set ohyb = ohybs.Item("Shapes")
Set ohybshps = ohyb.HybridShapes
For i = 1 To ohybshps.Count
Set ohybshp = ohybshps.Item(i)
ShapeBox.AddItem ohybshp.Name
ShapeBox.Font.Bold = True
ShapeBox.Font.Size = 25
Next
End Sub
Private Sub SelectBtn_Click()
End Sub
i dont know much about listbox handling
how do i create link between items in listbox and objects in catia
thanks
Hi you could add this to your code and try it. Beware your solution is pretty fragile one. You should consider more robust checks for objects validation
The trick lies in ShapeBox.Value in Shapebox click event. The rest is just catia stuff. But this solution is not foolproof because if you have more shapes with same names it might not select the right one. I would prefer creating a collection where you store real object from sets and the passing these objects to selection
Private Sub ShapeBox_Click()
Call opartdoc.Selection.Clear
Call opartdoc.Selection.Add(opartdoc.Part.FindObjectByName(ShapeBox.Value))
End Sub
I want to remove read-only using a PowerPoint macro.
I'm writing a macro that fires when a file is opened.
In that macro, there is a process to delete a specific shape.
The PowerPoint file has a write lock.
Given the above assumptions, when you open the file read-only
The macro will be executed, but an error will occur because it is read-only and the shape cannot be deleted.
So I unlock the read-only lock when the macro is executed
When I'm done deleting a particular shape, I want to lock it again for read-only.
Is there such a way?
I know the write lock password.
Public Sub Ribbon_onLoad(ribbon As IRibbonUI)
Const EXP_DATE As Date = "2021/09/30"
Dim NOW_DATE As Date: NOW_DATE = Format(Date, "yyyy/mm/dd")
Dim pp As PowerPoint.Presentation: Set pp = ActivePresentation
If NOW_DATE <= EXP_DATE Then
MsgBox "OK!"
Call DeleteShapesWithName("expShape")
Else
MsgBox "No!Exp!：" + Format(EXP_DATE, "yyyy/mm/dd")
'ActivePresentation.Close
End If
End Sub
Sub DeleteShapesWithName(ByVal targetName As String)
Dim sld As Slide
Dim shp As Shape
Dim i As Long
i = 1
For Each sld In Application.ActivePresentation.Slides
Do Until i > sld.Shapes.Count
If sld.Shapes(i).Name = targetName Then
sld.Shapes(i).Delete
Else
i = i + 1
End If
Loop
Next
End Sub
------add
I added the modified source after receiving the reply.
Public Sub Ribbon_onLoad(ribbon As IRibbonUI)
Call UnlockPresentation
End Sub
Sub UnlockPresentation()
Dim oPVW As ProtectedViewWindow
Dim oPres As Presentation
Set oPVW = ProtectedViewWindows.Open("C:\test\example_exp.pptm")
oPVW.Edit ModifyPassword:="test"
Call DeleteShapesWithName("expShape")
'Do stuff here
End Sub
Sub DeleteShapesWithName(ByVal targetName As String)
Dim sld As Slide
Dim shp As Shape
Dim i As Long
i = 1
For Each sld In Application.ActivePresentation.Slides
Do Until i > sld.Shapes.Count
If sld.Shapes(i).Name = targetName Then
sld.Shapes(i).Delete
Else
i = i + 1
End If
Loop
Next
End Sub
Here's code to open a read-only presentation so you can modify it. No need to reset the password, just replace "Test" with the actual password. Where the Do stuff here comment is, you can use the ActivePresentation keyword to modify the file:
Sub UnlockPresentation()
Dim oPVW As ProtectedViewWindow
Dim oPres As Presentation
Set oPVW = ProtectedViewWindows.Open("C:\HasModPW.pptx")
oPVW.Edit ModifyPassword:="ExistingModificationPassword"
'Do stuff here
End Sub
Please note: Microsoft's help page on ProtectViewWindow.Edit is wrong. The page currently states this method changes the password, but it actually provides the PW to make editing possible,
I need to use the Snipping Tool to capture a few screenshots, then copy & paste it into my Outlook Email template.
After I paste the pictures into the Email template, I want the images to change to a width of 9cm (255 ps) in a click of a button. The codes behind the button will run on the current item open.
That is, the code will have to run through the current item that is open and identify the image object, and run the codes to change the width of the image (with aspect ratio turned on).
I have done a little coding as shown below but I can't make it run. Can anyone help me on this?
p.s. I did a search and figured that ShapeRange only apply for Word, Powerpoint, Excel, Project, etc.
Option Explicit
Sub ChangeWidth()
Dim objApp As Outlook.Application
Dim objItem As Outlook.MailItem
Dim OrigShape As ShapeRange
Dim image As Object
Set objApp = Application
Set objItem = objApp.ActiveInspector.CurrentItem
objItem.ShapeRange.LockAspectRatio = msoTrue
objItem.ShapeRange.Width = 255.1181103
End Sub
You need to use InlineShapes :
Option Explicit
Sub ChangeWidth()
Dim objApp As Outlook.Application
Dim objItem As Outlook.MailItem
Dim iShape As InlineShape
Dim image As Object
Set objApp = Application
Set objItem = objApp.ActiveInspector.CurrentItem
For Each shp In objItem.InlineShapes
If shp.HasPicture Then
shp.LockAspectRatio = msoTrue
'shp.ScaleHeight = 150
'shp.ScaleWidth = 150
'or
shp.Width = 255.1181103
End If
Next
End Sub
I'm pretty rusty with VBA and I was hoping someone could point me in the right direction, or help me out. What I'm trying to do is run a macro that will cycle through each active container on my sheet, and then count the number of shapes within that container. Then I'd like to update a field in the shape data for the container with the number of shapes.
This is what I have so far:
Public Sub countContainers()
Dim vsoPage As Visio.Page
Dim vsoDocument As Visio.Document
Dim vsoDocuments As Visio.Documents
Dim vsoPages As Visio.Pages
Dim vsoContainerShape As Visio.Shape
Dim containerId As Variant
For Each containerId In vsoPage.GetContainers(visContainerIncludeNested)
Set vsoContainerShape = vsoPage.Shapes.ItemFromID(containerId)
Debug.Print vsoContainerShape.NameU
Next
End Sub
The error I get is Object Variable or With Block variable not set
Any ideas?
The error is because you have declared the vsoPage but you never assigned it to any page in your document.
Add a line such as this to initialize it and the error goes away:
Set vsoPage = ActivePage
I am attempting to store xml metadata within chart shapes in a PowerPoint presentation.
I need to ensure that the shape only contains the current xml data, so I have a function to delete existing data (if any) and add the current data.
Sub Test()
Dim cht as Chart
Dim xml as String
Set cht = ActivePresentation.Slides(1).Shapes(1)
xml = "<Chart property1='true' property2='false'>blah blah blah</Chart>"
EmbedChartXML xml, cht
End Sub
Sub EmbedChartXML(xml As String, cht As Shape)
Dim x As Variant
'Get rid of any previous data
For Each x In cht.CustomerData
x.Delete
Next
Set xmlPart = cht.CustomerData.Add
xmlPart.LoadXML xml
End Sub
The For Each loop is failing with the indicated error message. I can see that the cht.CustomerData.Count = 2 (for example), but if I try to view this in the Locals window, I get the same error.
UPDATE
Here is another test routine that is failing, even though there is nothing inside the For/Next loop.
Sub TestIteration()
Dim sld As Slide
Dim pres As Presentation
Dim shp As Shape
Dim x As CustomXMLPart
Set pres = ActivePresentation
Set sld = pres.Slides(2)
For Each shp In sld.Shapes
Set pptCustomerData = shp.CustomerData
For Each x In shp.CustomerData
' For Each pptCustomXMLPart In pptCustomerData
' Debug.Print pptCustomXMLPart.Id
' Next
Next
Next
End Sub
Others here cannot replicate this error in Excel 2013 (I am using Excel 2010) where the collection object itself becomes inaccessible. Perhaps there is a bug or something, but I could not find much on Google about similar errors...
I ultimately arrive at this solution. I am not sure why the CustomXMLPart's .Delete method doesn't actually delete the item from the collection (instead it makes it to Nothing, and then failure on successive iteration attempts).
Instead, I use the CustomerData.Delete method. This seems to be working as expected.
Sub EmbedChartXML(xml As String, cht As Shape)
Dim x As Variant
Dim cData As CustomerData
Dim xID As String
Set cData = cht.CustomerData
Debug.Print cht.CustomerData.Count
'Get rid of any previous data
For Each x In cData
xID = x.Id
cData.Delete xID
Next
With cData.Add
.LoadXML xml
End With
Debug.Print cht.CustomerData.Count
End Sub