So I have a macro to search all texts on a document and convert them all to curves. This macro also would look through powerclip which is out of range of CQL.
Below is my code:
Public Sub convertText()
Dim pg As Page
Dim shRange As ShapeRange
Dim sh As Shape
For Each pg In ActiveDocument.Pages
pg.Activate
Set shRange = FindAllPCShapes.Shapes.FindShapes(Query:="#type='text:artistic' or #type='text:paragraph'")
For Each sh In shRange
sh.ConvertToCurves
Next sh
Next pg
End Sub
Function FindAllPCShapes(Optional LngLevel As Long) As ShapeRange ' Shelby's function
Dim s As Shape
Dim srPowerClipped As New ShapeRange, srJustClipped As New ShapeRange
Dim sr As ShapeRange, srAll As New ShapeRange
Dim bFound As Boolean, i&
bFound = False
If ActiveSelection.Shapes.count > 0 Then
Set sr = ActiveSelection.Shapes.FindShapes()
Else
Set sr = ActivePage.Shapes.FindShapes()
End If
i = 0
Do
For Each s In sr.Shapes.FindShapes(Query:="!#com.powerclip.IsNull")
srPowerClipped.AddRange s.PowerClip.Shapes.FindShapes()
Next s
If srPowerClipped.count > 0 Then bFound = True: i = i + 1
If i = LngLevel And bFound Then Set FindAllPCShapes = srPowerClipped: Exit Function
bFound = False
srAll.AddRange sr
sr.RemoveAll
sr.AddRange srPowerClipped
If LngLevel = -1 Then srJustClipped.AddRange srPowerClipped
srPowerClipped.RemoveAll
Loop Until sr.count = 0
If LngLevel = -1 Then
Set FindAllPCShapes = srJustClipped
Else
Set FindAllPCShapes = srAll
End If
End Function
It works fine on some cases, but I caught an error on some document where For Each sh In shRange will generate an error "The Referenced Object no longer exists". Apparently this is because of a nested group inside a powerclip.
I tried to ignore the error by adding On Error Resume Next and the macro will runs fine. But of course I want to know what's the error with my code so I can avoid future troubles, I rather not to ignore all the errors on my macro.
Here's a sample document to demonstrate the error.
https://www.dropbox.com/s/lpi568eoltc8cxy/ReferenceError.cdr?dl=0
Thank you
The error I think encountered is due to Nothing is returned by the FindShapes method.
Before the For loop, you should check if it's Nothing:
For Each pg In ActiveDocument.Pages
pg.Activate
Set shRange = FindAllPCShapes.Shapes.FindShapes(Query:="#type='text:artistic' or #type='text:paragraph'")
If Not shRange Is Nothing Then
For Each sh In shRange
sh.ConvertToCurves
Next sh
End If
Next pg
Related
I'm trying to delete tables from the active slide in a ppt presentation, but I can only get it to work if I specify the number for the slide. I want this to work for whatever slide is active, not a specific slide. The below code is set to delete tables from slide 3.
Sub CopytoPPT()
Dim rng As Excel.Range
Dim sl As PowerPoint.Slide, sl_cnt As Long, pr As Object, pr_name As String, ppt As Object
Dim i As Long, j As Long
Set ppt = GetObject(, "PowerPoint.Application")
Set pr = ppt.Presentations(1)
Set sl = pr.Slides(3)
For i = sl.Shapes.Count To 1 Step -1
' ADD THIS TEST
If IsTable(sl.Shapes(i)) Then
sl.Shapes(i).Delete
End If
Next i
End Sub
Function IsTable(oSh As Variant) As Boolean
If oSh.Type = msoPlaceholder Then
If oSh.PlaceholderFormat.ContainedType = msoTable Then
IsTable = True
End If
Else
If oSh.HasTable Then
IsTable = True
End If
End If
End Function
Change:
Set sl = pr.Slides(3)
To:
Set sl = ppt.ActiveWindow.View.Slide
I have been working on this code that takes misspelled words from a document and then turns them into a table with all the misspelled words on one column. Then the words are spellchecked and the corrections appear on the other column. My code does everything that I want it to, however only the first word appears on each cell. What am I doing wrong?
Sub SuperSpellCheck()
Dim doc1 As Document
Dim doc2 As Document
Dim tb As Table
Set doc1 = ActiveDocument
Set doc2 = Documents.Add
doc1.Activate
Dim badw As Range
Dim rng As Range
Dim sugg As SpellingSuggestions
Dim sug As Variant
err = doc1.SpellingErrors.Count
For Each badw In doc1.SpellingErrors
doc2.Range.InsertAfter badw & vbCr
Next
doc2.Activate
Set tb = ActiveDocument.Content.ConvertToTable(Separator:=wdSeparateByParagraphs, NumColumns:=1,
NumRows:=ActiveDocument.SpellingErrors.Count, AutoFitBehavior:=wdAutoFitFixed)
With tb
.Style = "Table Grid"
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.Columns.Add
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
End With
err2 = ActiveDocument.SpellingErrors.Count
i = 1
Set sugg = doc2.Range.GetSpellingSuggestions
For Each rng In doc2.Range.SpellingErrors
With rng
If sugg.Count > 0 Then
Set sug = .GetSpellingSuggestions
tb.Cell(i, 2).Range.InsertAfter sug(1)
End If
End With
Next
End Sub
Not connected to your problem but you need to change these lines
Err = doc1.SpellingErrors.Count
err2 = ActiveDocument.SpellingErrors.Count
To:
Dim errors1 as Long, dim errors2 as Long
errors1 = doc1.SpellingErrors.Count
errors2 = doc2.SpellingErrors.Count
Err is an object in VBA that holds the errors generated by your code. You also haven't declared those variables. Add Option Explicit at the very top of your code module and you will be alerted to any undeclared variables. To turn this on automatically in future go to Tools | Options | Editor and ensure that Require Variable Declaration is checked.
I would change
Dim sugg As SpellingSuggestions
Dim sug As Variant
to
Dim docSugg As SpellingSuggestions
Dim rngSugg As SpellingSuggestions
Dim sug As SpellingSuggestion
This will make it clearer what each of these represents.
SpellingSuggestions is a collection of SpellingSuggestion objects so you can use sug to loop through the collection.
i = 1
Set sugg = doc2.Range.GetSpellingSuggestions
For Each rng In doc2.Range.SpellingErrors
With rng
If sugg.Count > 0 Then
Set sug = .GetSpellingSuggestions
tb.Cell(i, 2).Range.InsertAfter sug(1)
End If
End With
Next
In this block of code you start off by setting the undeclared variable i to a value of 1, but you don't then increase that value. This will result in all your spelling suggestions being inserted in the same cell. Also, when you insert the spelling suggestion you only ever insert the first one as you don't have a means of looping through them. So I would rewrite this as:
i = 1
Set docSugg = doc2.Range.GetSpellingSuggestions
For Each rng In doc2.Range.SpellingErrors
With rng
If docSugg.Count > 0 Then
Set rngSugg = .GetSpellingSuggestions
For Each sug In rngSugg
tb.Cell(i, 2).Range.InsertAfter sug
Next
End If
End With
i = i + 1
Next
EDIT: If you only want the first suggested spelling then use:
i = 1
Set docSugg = doc2.Range.GetSpellingSuggestions
For Each rng In doc2.Range.SpellingErrors
With rng
If docSugg.Count > 0 Then
Set rngSugg = .GetSpellingSuggestions
tb.Cell(i, 2).Range.InsertAfter rngSugg(1)
End If
End With
i = i + 1
Next
I dont do much word work, but I need to amend the address in the headers of a batch of letters. The address is held in tables in the headers. I also need to retain the formatting.
Below is the code I have ended up with - am I getting close?
Dim doc As Word.Document
Dim hf As Word.HeaderFooter
Dim lr As ListRow
Dim updated As Boolean
Dim tableCount As Integer
Dim t As Integer
Dim c As Cell
Set doc = wd.Documents.Open(Filename:=fi.Path, ReadOnly:=False)
For Each hf In doc.Sections(1).Headers()
tableCount = hf.Range.Tables.Count
For t = 1 To tableCount
For Each c In hf.Range.Tables(t).Range.Cells
If InStr(1, c.Range.Text, AddLOneOld) > 0 Then
updated = True
c.Range.Text = Replace(c.Range.Text, AddLOneOld, AddLOneNew)
End If
If InStr(1, c.Range.Text, AddLTwoOld) > 0 Then
updated = True
c.Range.Text = Replace(c.Range.Text, AddLTwoOld, AddLTwoNew)
End If
If InStr(1, c.Range.Text, AddLThreeOld) > 0 Then
updated = True
c.Range.Text = Replace(c.Range.Text, AddLThreeOld, AddLThreeNew)
End If
Next c
Next t
Next hf
If updated Then
Set lr = filesUpdated.ListRows.Add
lr.Range(1, 1) = fi.Path
doc.Save
End If
doc.Close False
This is the nearest I have got it to go as far as running, but all it does now is produce the error
"Microsoft Excel is waiting for another application to complete an OLE action"
Thanks
I have developed the following two subs which create and remove a collection of checkboxes next to a listobject. Each distinct ID in the listobject gets a checkbox. Like this I can approve the listobject entries.
The code is the follwing:
Public CBcollection As Collection
Public CTRLcollection As Collection
Sub create_chbx()
If Approval.CBcollection Is Nothing Then
Dim i As Integer
Dim tbl As ListObject
Dim CTRL As Excel.OLEObject
Dim CB As MSForms.CheckBox
Dim sht As Worksheet
Dim L As Double, T As Double, H As Double, W As Double
Dim rng As Range
Dim ID As Long, oldID As Long
Set CBcollection = New Collection
Set CTRLcollection = New Collection
Set sht = ActiveSheet
Set tbl = sht.ListObjects("ApprovalTBL")
Set rng = tbl.Range(2, 1).Offset(0, -1)
W = 10
H = 10
L = rng.Left + rng.Width / 2 - W / 2
T = rng.Top + rng.Height / 2 - H / 2
For i = 1 To tbl.ListRows.count
ID = tbl.Range(i + 1, 1).Value
If Not (ID = oldID) Then
Set CTRL = sht.OLEObjects.Add(ClassType:="Forms.CheckBox.1", Link:=False, DisplayAsIcon:=False, Left:=L, Top:=T, Width:=W, Height:=H)
Set CB = CTRL.Object
CBcollection.Add Item:=CB
CTRLcollection.Add Item:=CTRL
End If
Set rng = rng.Offset(1, 0)
T = rng.Top + rng.Height / 2 - H / 2
oldID = ID
Next i
End If
End Sub
Sub remove_chbx()
If Not Approval.CBcollection Is Nothing Then
With Approval.CBcollection ' Approval is the module name
While .count > 0
.Remove (.count)
Wend
End With
With Approval.CTRLcollection
While .count > 0
.Item(.count).Delete
.Remove (.count)
Wend
End With
Set Approval.CBcollection = Nothing
Set Approval.CTRLcollection = Nothing
End If
End Sub
This all works pretty well. No double checkboxes and no errors if there are no checkboxes. I am developing an approval scheme were I need to develop and test other modules. If I now run this sub:
Sub IdoStupidStuff()
Dim i As Integer
Dim Im As Image
i = 1
Set Im = i
End Sub
It will give me an error. If I then try to run one of my checkbox subs they will not work properly anymore. The collection is deleted by the error and I am no longer able to access the collections. Why does this happen and am I able to counter act this other then just not causing errors? Is there a better way to implement such a system were loss of collections is not an issue?
You could wrap the Collection object in a Property and let it handle the object creation:
Private mCollection As Collection
Public Property Get TheCollection() As Collection
If mCollection Is Nothing Then Set mCollection = New Collection
Set TheCollection = mCollection
End Property
To call it:
TheCollection.Count
Try On Error Resume Next before the line that causes the error. It will skip the problem and your vairables will still be available.
However this will not solve your error. Try to make a seperate hidden sheet in your workbook to store your global variables so they won't go missing.
f.ex.:
Private Sub CreateSheet()
Dim ws As Worksheet
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "Global"
.Worksheets("Global").Visible = False
End With
End Sub
Basically I want to transform the text in between the tags into bold. This text will always be in the comments. The current code doesnt do anything.
I am not really sure if this code makes any sense at all, but I usually use VBA for Excel and word seems to be a bit trickier.
Sub Bold()
Dim eCom As Comment
Dim iFound As Integer
Dim rbold As Range
Dim iDot As Integer
Dim flag As Boolean
Dim aDoc As Document
Set aDoc = ActiveDocument
flag = True
Application.ScreenUpdating = False
For Each eCom In ActiveDocument.Comments
iFound = InStr(eCom.Range.Text, "<strong>")
iDot = 0
If iFound > 0 Then
iDot = InStrRev(eCom.Range, "</") - iFound + 1
Set rbold = aDoc.Range(Start:=eCom.Range.Start + iFound, End:=eCom.Range.Start + InStrRev(eCom.Range, "<"))
rbold.Select
Selection.Font.Bold = wdToggle
End If
Next eCom
Application.ScreenUpdating = True
End Sub
There are a few problems here. First, it appears that the Comment Ranges do not use the same numbering as the document ranges. So
Set rbold = aDoc.Range(Start:=eCom.Range.Start + iFound, End:=eCom.Range.Start + InStrRev(eCom.Range, "<"))
is not actually the range in the comments, it is instead a range in the document starting with the place in the comment that has the strong html tag.
Second, even if this was working, it would start the bolding in the wrong place, starting with "strong>"
Third, there's no reason to select the range, just set it to bold.
This code will do what you want (I commented out a line as I couldn't figure out what it was supposed to do):
Sub Bold()
Dim eCom As Comment
Dim iFound As Integer
Dim rbold As Range
Dim iDot As Integer
Dim flag As Boolean
Dim aDoc As Document
Dim newCom As Comment
Set aDoc = ActiveDocument
flag = True
Application.ScreenUpdating = False
For Each eCom In ActiveDocument.Comments
iFound = InStr(eCom.Range.Text, "<strong>")
iDot = 0
If iFound > 0 Then
'iDot = InStrRev(eCom.Range, "</") - iFound + 1
Set rbold = eCom.Range
rbold.MoveEnd Unit:=wdCharacter, Count:=-(Len(rbold) - InStrRev(rbold, "</") + 1)
rbold.MoveStart Unit:=wdCharacter, Count:=iFound + Len("<strong>") - 1
rbold.Bold = True
End If
Next eCom
Application.ScreenUpdating = True
End Sub