I noticed my worksheet was slowing right down, and found a few objects had been created for some reason. I ran the following macro to remove them all:
Dim Shp as Shape
For Each Shp In Worksheets("Sheet1").Shapes
Shp.Delete
Next Shp
However I keep getting The index into the specified collection is out of bounds error. So I did the following to see how many objects had been created:
Dim i As Long
i = ActiveSheet.Shapes.Count
MsgBox CLng(i)
And received the number 41152. I have tried Go To Special and selected objects, but if this number is correct my computer is crashing trying to select over 41K objects at once.
Any suggestions how to remove them all?
You can step backward through the Shapes collection to delete them from the last value in the collection Index to the first.
Like this:
i = Worksheets("Sheet1").Shapes.Count
For x = i To 1 Step -1: Worksheets("Sheet1").Shapes(x).Delete: Next
Related
I created this function to go through my current sheet and delete all shapes starting with "Stn_".
It deletes a few at a time. I end up running it multiple times to delete them all.
Private Sub btnReset_click()
'Reset Shapes needs work
For Each shp In ActivePage.Shapes
Debug.Print shp.Name
If shp.Name Like "Stn_*" Then
ActiveWindow.Select shp, visSelect
ActiveWindow.Selection.Delete
End If
Next
End Sub
You need to count backwards when deleting shapes. If you, say, delete shape 1, then shape 2 then becomes the new shape 1 but the loop counter moves on to 2, bypassing that shape. So you can't use For Each, you have to use a plain old For but count by -1.
I have an MS Word document (Office 365 version 1803) with a large number of images. I need to select all images in the document, but there are far too many to do this by hand. Looking online, it seems the only way to do this is using a macro, which I have no experience with. I wrote the following very simple macro:
Sub SelectAllImages()
ActiveDocument.Shapes.SelectAll
End Sub
When I saved the document, I was forced to change it to a macro-enabled Word document (.docm), which I did. However, whenever I try to run the macro I get the following error:
Run-time error '70': Permission denied
I have Googled this error, but nothing has helped me fix it. Anyone have any idea what I'm doing wrong?
Edit: As additional data, what I'm trying to do is delete most but not all of the images. I have a document that is 200+ pages long with an average of about 1 image per page. I need to publish 2 versions of this document: 1 with all images, the second with all but about 12 of the images removed. The document is updated regularly, and I don't want to have to keep updating 2 separate versions and ensure they are identical except for the inclusion of the images. Thus I'd like to be able to maintain only one version, which includes all the images. Then after each update I'd like to be able to select all the images, manually unselect the 12 I want to keep, and delete the others.
If there is a way to somehow "tag" the images I want to keep and have a macro delete all but the tagged ones that would be an even better solution.
You will get that error if there are any InlineShapes in the document. There only has to be one and that command will error out. You will have to select InlineShapes separately from Shapes with wrapping text. See code below.
Concerning your question about tagging. To "Tag" the images put a unique phrase like "Do Not Delete" in the Alt Text of the images. Then you can use code like the below to remove all images, except those that have been tagged.
For Inline Images this code will potentially leave a blank paragraph in the document and I will leave that to you to figure out how you want the final document to look.
Sub RemoveAllImagesWithExceptions()
Dim doc As Word.Document, iShp As Word.InlineShape
Dim shp As Word.Shape, i As Long, rng As Word.Range
Set doc = ActiveDocument
Set rng = doc.Content
For i = rng.InlineShapes.Count To 1 Step -1
Set iShp = rng.InlineShapes(i)
Select Case iShp.Type
Case wdInlineShapeLinkedPicture, wdInlineShapePicture
If InStr(1, iShp.AlternativeText, "Do Not Delete") = 0 Then
iShp.Delete
End If
End Select
Next
For i = rng.ShapeRange.Count To 1 Step -1
Set shp = rng.ShapeRange(i)
Select Case shp.Type
Case msoLinkedPicture, msoPicture
If InStr(1, shp.AlternativeText, "Do Not Delete") = 0 Then
shp.Delete
End If
End Select
Next
End Sub
I want to model something similar to a (hyper-)graph in MS Visio 2016 Professional and then export the data of the shapes to csv to further work with it.
I am trying to make a VBA Script that goes through all the shapes on the sheet and writes the (manually inserted) data from the shapes to one csv file (and in the future maybe different csv files depending on the type of the shape).
To get a feeling for VBA I tried to start with a script that counts all the shapes on the sheet but I already failed on that. Please consider this is my first time working with VBA:
Sub countShapes()
Dim shp As Shape
Dim count As Integer
count = 0
Debug.Print count
For Each shp In ActiveSheet.Shapes
count = count + 1
Debug.Print count
Next
End Sub
This returns runtime error 424, object not found.
What am I missing?
As a second step, I want the script to check that shapes that have for example the same number in the data field "id" are identical in all other data fields as well and show an error if not (before exporting to the csv files). Can I realize this using vba in visio?
Thanks a lot for any help!
ActiveSheet is an Excel property. I think you're looking for ActivePage, which is a Visio equivilent. So to fix your code above you could use this:
For Each shp In ActivePage.Shapes
count = count + 1
Debug.Print count
Next
However, if you're simply after the shape count for a page then you could write this instead:
Debug.Print ActivePage.Shapes.Count
Can I recommend some links that might also help:
http://visualsignals.typepad.co.uk/vislog/2007/10/just-for-starte.html
http://visualsignals.typepad.co.uk/vislog/2007/11/looping-through.html
vba programming for visio
As an alternative approach you might also be interested in Visio's built-in reporting tool:
Create a report of shape data (support docs)
Getting Started with Visio 16 - Build and Apply Reports from Share Data (Video)
Re the second part of your question (check data fields) I'm assuming you're talking about reading Shape Data. If that's the case you first want to check if a row named "ID" exists and, if it does, read that value. So something like this might get you going:
Public Sub TestGetCellValues()
GetShapesCellValues ActivePage, "Prop.ID"
End Sub
Public Sub GetShapesCellValues(targetPage As Visio.Page, targetCellName As String)
Dim shp As Visio.Shape
If Not targetPage Is Nothing Then
For Each shp In targetPage.Shapes
If shp.CellExistsU(targetCellName, 0) = True Then
Debug.Print shp.NameID & "!" _
& targetCellName & " = " _
& shp.CellsU(targetCellName).ResultIU
End If
Next shp
End If
End Sub
...which might output something like this (given the associated shapes):
Sheet.2!Prop.ID = 3
I am working on a file that creates up to 120 charts based on data, variables, and format selections from the user. To do this I create a variant array to hold the charts which allows me to easily reference them for adding data, formatting, etc. This method has worked well for me so far.
Now I would like to let users make small tweaks to formatting (adjust the min and max on the axis, add or remove legend entries, etc.). To do this I would like to continue referencing the charts from an array, but I can't seem to add the existing charts to the variant array.
When I initially create the charts I use this line to add the chart to the array when it is created. I fill in appropriate parameters to place and size the chart and this seems to work fine.
Set charts(graphIndex) = activeSheet.ChartObjects.Add(...)
After creating all the charts, I think the non Global variables used are cleared from the cache (at least that is my current understanding). This means that in order to make these tweaks I need to reinitialize and redefine the variant array that I use to reference the charts. This is what I am struggling with. This is my current attempt to add the existing chart to the variant array.
charts(graphIndex) = Worksheets(activeSheetName).ChartObjects("chart name").Chart
When I run the code I am getting a "Run-time error '438': Object doesn't support property or method."
Hopefully I provided enough context, but any help on this would be greatly appreciated. This feels like it should be fairly easy, but I couldn't find any information online.
I am just guessing that in your code if you had the Set word it would have worked (However, I am not seeing the whole code, thus not sure).
This works, if you make sure to have 3 charts named "Diagramm 1", "Diagramm 2" and "Diagramm 3" on the first worksheet:
Option Explicit
Sub TestMe()
Dim cht2 As Chart
Dim varArray As Variant
With Worksheets(1)
Set cht2 = .ChartObjects("Diagramm 2").Chart
varArray = Array(.ChartObjects("Diagramm 1").Chart, cht2)
ReDim Preserve varArray(2)
Set varArray(2) = .ChartObjects("Diagramm 3").Chart
Dim cnt As Long
For cnt = LBound(varArray) To UBound(varArray)
Debug.Print varArray(cnt).Name
Next cnt
End With
End Sub
The Reedim Preserve increases the array units with one additional, while it keeps what it already has. Thus, at the end this is what we have in the locals:
Related to my question in determining how to see if a shape has overflowed a page boundary (Determining if a powerpoint text box is over the page size)
I need to move rows of a table on one page to the prior page.
Fairly straightforward to determine the rows I need to cut (I've left that part of the code out for brevity). Where I am having a problem is the method of how to paste it back into the table on the prior page (table has same column dimensions).
In the UI, it is as simple as placing the cursor in the first cell of the target row and hitting paste. This completely replicates the column structure of the cut row. In VB, best I can do is paste the entire text of the cut row (all columns) gets into the one cell. I cant seem to get VB code that can replicate what is happening in the UI. What command am I missing?
For y = 2 To c
Set oSh = ActivePresentation.Slides(k + 1).Shapes("ProgTable")
With oSh.Table
.Rows(y).Select
End With
Windows(1).Selection.Cut
Set oSh = ActivePresentation.Slides(k).Shapes("ProgTable")
With oSh.Table
.Rows.Add (-1)
.Cell(oSh.Table.Rows.Count,1)textFrame.TextRange.Paste 'pastes all columns into the one cell
End With
Next y
Alternate line of code to paste clipboard that I can't get to work
.Rows(oSh.Table.Rows.Count).Cells.Item.Shape.TextFrame.TextRange.PasteSpecial (PpPasteDataType.ppPasteHTML)
'does not work, gives compile error on ITEM argument not optional
You're pasting in to a TextRange, not the table/row itself. There are some funky things in PPT's object model for sure, and some actions which seem like they should be intuitive (copy/paste) often are not. In these cases, the Application.CommandBars.ExecuteMSO method is usually where I start (also very useful if you're copying from/between different applications like Excel>PowerPoint, Word>PowerPoint, etc.)
I did this to test, and it is working as expected, so it should set you on the right track:
Sub CopyRowToAnotherTable()
Dim tbl1 As Table
Dim tbl2 As Table
Dim sld1 As Slide
Dim sld2 As Slide
Dim pres As Presentation
Dim shp As Shape
Set pres = ActivePresentation
Set sld1 = pres.Slides(1)
Set sld2 = pres.Slides(2)
Set tbl1 = sld1.Shapes(1).Table
Set tbl2 = sld2.Shapes(1).Table
'Cut the last row from tbl2:
sld2.Select '## Powerpoint requires the slide to be active/view in order to select shapes on the slide
With tbl2
.Rows(.Rows.Count).Select
pres.Windows(1).Selection.Cut
End With
'Insert in tbl1
With tbl1
.Rows.Add -1
sld1.Select
.Rows(.Rows.Count).Select
pres.Application.CommandBars.ExecuteMso "Paste"
End With
End Sub
So in your code, I think this should work:
With oSh.Table
'## select the slide:
.Parent.Parent.Select
.Rows.Add (-1)
.Rows(.Rows.Count).Select
Application.CommandBars.ExecuteMso "Paste"
End With
The tricky part about the ExecuteMso method is mainly that it's not well-documented, or it is, but it's hard to find the dox, so here is reference from a previous answer:
Documentation on the ExecuteMso method:
http://msdn.microsoft.com/en-us/library/office/ff862419.aspx
Downloadable document containing the idMSO parameters for each Office
Application:
http://www.microsoft.com/en-us/download/details.aspx?displaylang=en&id=6627