GetCrossReferenceItems with custom captions - vba

In my Word file, I want to distinguish between figures in the text and figures in the Appendix by calling the second type of figure "Figure A". To refer to them properly by their ID, I want to create an array with all of my custom captions. Yet, GetCrossReferenceItems doesn't seem to work here. How can I correctly make my array?
Sub Caption_Example()
CaptionLabels.Add Name:="Figure"
CaptionLabels.Add Name:="Figure A"
' Insert new figure caption
With Selection
.InsertCaption _
Label:="Figure", _
Title:=": A fancy title", _
Position:=wdCaptionPositionBelow, _
ExcludeLabel:=0
End With
' Insert a line break
Selection = vbCrLf
' Insert new figure A caption
With Selection
.InsertCaption _
Label:="Figure A", _
Title:=": Another fancy title", _
Position:=wdCaptionPositionBelow, _
ExcludeLabel:=0
End With
' Usually to get a list of Figures I would type:
x = (ActiveDocument.GetCrossReferenceItems(ReferenceType:="Figure"))
Debug.Print "First figure: "; x(1)
' But it doesn't work with figure A
'y = (ActiveDocument.GetCrossReferenceItems(ReferenceType:="Figure A")) ' Doesnt work at all
y = (ActiveDocument.GetCrossReferenceItems(ReferenceType = "Figure A")) ' Work, shows everything, not only Figure A
' Insert a line break (doesn't work anymore)
Selection.Text = vbCrLf
' Yet, referring to it works
Selection.InsertCrossReference _
ReferenceType:="Figure A", _
ReferenceKind:=wdOnlyLabelAndNumber, _
ReferenceItem:="1", _
InsertAsHyperlink:=True, _
IncludePosition:=False, _
SeparateNumbers:=False, _
SeparatorString:=" "
End Sub
Edit: GetCrossReferenceItems seems to work if I call the new CaptionLabel "FigureA", hence, get rid of the space in its name. But then all figures are called FigureA.1 etc.

Okay, I found the solution. First of all, you have to set heading 7 to look like "Appendix A". (I use heading 7 because I do not use such headings for my normal text. Attention: "Heading" is written in German "Überschrift"). Then, the following code works:
Sub solution()
' Make a level 7 heading
Selection.TypeText Text:="Some heading"
Selection.Style = ActiveDocument.Styles("Überschrift 7")
Selection.TypeParagraph
' Create captionlabel
CaptionLabels.Add Name:="FigureA"
With CaptionLabels("FigureA")
.NumberStyle = wdCaptionNumberStyleArabic
.IncludeChapterNumber = True ' Include Chapter Nr., like A, B, ...
.ChapterStyleLevel = 7 ' Because my chapter level 7 are the Appendix headings.
.Separator = wdSeparatorPeriod
End With
' Insert new figureA caption
With Selection
.InsertCaption _
Label:="FigureA", _
Title:=": Another fancy title", _
Position:=wdCaptionPositionBelow, _
ExcludeLabel:=True ' Should be true
End With
' Name it "Figure"
With Selection.Paragraphs(1).Range
.InsertBefore "Figure "
End With
' Refer to that figure
Selection.TypeParagraph
Selection.TypeText Text:="Refer to that by writing "
With Selection
.InsertCrossReference _
ReferenceType:="FigureA", _
ReferenceKind:=wdOnlyLabelAndNumber, _
ReferenceItem:=1, _
InsertAsHyperlink:=True, _
IncludePosition:=False, _
SeparateNumbers:=False, _
SeparatorString:=" "
End With
End Sub
Edit: The problem seems to be the space between "Figure" and "A" in the caption label.

Related

MS Word - link to header of current section / relative referencing

I'm working on a largeish document with multi-level headings, for a long set of test procedures. At the end of each procedure, there is a sign-off box. I want to add the section number and name to each sign-off box.
I researched (here, of course!) and wrote a macro to insert a reference to the heading of the current section, it appears to work fine:
Sub InsertCrossRefToSectionHeading()
Dim RefList As Variant
Dim LookUp As String
Dim Ref As String
Dim i As Integer
LookUp = ActiveDocument.Bookmarks("\HeadingLevel").Range.Paragraphs(1).Range.ListFormat.ListString
With ActiveDocument
RefList = .GetCrossReferenceItems(wdRefTypeHeading)
For i = UBound(RefList) To 1 Step -1
Ref = Trim(RefList(i))
If Left(Ref, Len(LookUp)) = LookUp Then Exit For
Next i
If i Then
Selection.InsertCrossReference ReferenceType:=wdRefTypeHeading, _
ReferenceKind:=wdNumberFullContext, _
ReferenceItem:=CStr(i), _
InsertAsHyperlink:=True, _
IncludePosition:=False, _
SeparateNumbers:=False, _
SeparatorString:=" "
Selection.TypeText Text:=vbTab
Selection.InsertCrossReference ReferenceType:=wdRefTypeHeading, _
ReferenceKind:=wdContentText, _
ReferenceItem:=CStr(i), _
InsertAsHyperlink:=True, _
IncludePosition:=False, _
SeparateNumbers:=False, _
SeparatorString:=" "
'Copy the formatting from the previous cell in the template table and apply to refrence text.
Selection.MoveLeft Unit:=wdCell
Selection.CopyFormat
Selection.MoveRight Unit:=wdCell
Selection.PasteFormat
Else
MsgBox "A cross reference to """ & LookUp & """ couldn't be set" & vbCr & _
"because a paragraph with that number couldn't" & vbCr & _
"be found in the document.", _
vbInformation, "Invalid cross reference"
End If
End With
End Sub
However, it is a hard-linked reference to the heading that was the heading for this section at the time of running the macro. If I add a section, all references in the sign-off boxes after that section are pointing at the previous section, and it defeats the purpose of it.
Yes, my macro will make it much quicker to fix, but there will be a lot of rework every time I add a section to this evolving document. And yes, I could possibly even programmatically search the document for tables with "Test Record" in the top row, then delete Row 2 Cell 2 and insert the reference... but that's a lot of extra programming!... I've done a ton of VBA in Excel, but am new to it in Word. I guess I could leave the references until the very end... of this edit - but then I'll have to do it all again if the doc evolves in the future (which is very likely).
Is there any way to reference the heading of the current section?
Thanks for your help!
Thanks to #CharlesKenyon, here's the solution (much simpler than my first attempt too!).
Sub InsertCrossRefToSectionHeading()
' Adds ref to the heading of the current section.
'https://stackoverflow.com/questions/67200486/ms-word-link-to-header-of-current-section-relative-referencing
'http://www.addbalance.com/usersguide/fields.htm#STYLEREF
CurrentHeadingLevel = ActiveDocument.Bookmarks("\HeadingLevel").Range.Paragraphs(1).Range.ListFormat.ListLevelNumber
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"STYLEREF ""Heading " & CurrentHeadingLevel & """ \w ", PreserveFormatting:=True
Selection.TypeText Text:=" "
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:= _
"STYLEREF ""Heading " & CurrentHeadingLevel & """ ", PreserveFormatting:=True
'Copy the formatting from the previous cell in the template table and apply to refrence text.
Selection.MoveLeft Unit:=wdCell
Selection.CopyFormat
Selection.MoveRight Unit:=wdCell
Selection.PasteFormat
End Sub

Why do I get a ByRef argument type mismatch error even though my input is the correct variable type?

I am working on a code that, in certain situations, creates a new sheet that contains two buttons. One button makes a UserForm appear and asks the user a few questions to format the newly created sheet. The user then inputs data into the tables that have now appeared and finally clicks the second button called "Execute."
The "Execute" button simply takes all of the input data and does some calculations using a Sub called MathCode(ws As Worksheet) but when I refer to the Sub elsewhere as Call Mathcode (Sec_Delay) I get a ByRef argument type mismatch compile error:
The sheet Sec_Delay is initialized before it is called later in an OLEObject:
ElseIf Range("B1") = 3 And Range("S1") = 0 And Range("R1") = 1 Then
Set Sec_Delay = ThisWorkbook.Sheets.Add(, Pri_Delay)
Sec_Delay.Name = "Secondary Drive Timing Delay2"
With Sec_Delay.Range("A2:S35")
Pri_Delay.Range("A2:S35").Copy
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
End With
Dim obj2 As Object
Dim Code2 As String
With Sec_Delay
Set obj = .OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Link:=False, DisplayAsIcon:=False, Left:=279, _
Top:=210.75, Width:=109.5, Height:=24)
obj.Name = "ButtonTest"
obj.Object.Caption = "USER INPUT"
Code = "Sub ButtonTest_Click()" & vbCrLf & _
"UF_input.Show" & vbCrLf & _
"End Sub"
Set obj2 = .OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Link:=False, DisplayAsIcon:=False, Left:=277.5, _
Top:=236.25, Width:=111, Height:=24)
obj2.Name = "ExecuteTest"
obj2.Object.Caption = "Execute"
Code2 = "Sub ExecuteTest_Click()" & vbCrLf & _
"Call MathCode (Sec_Delay)" & vbCrLf & _
"End Sub"
With .Parent.VBProject.VBComponents(.CodeName).CodeModule
.insertlines .countoflines + 1, Code
.insertlines .countoflines + 1, Code2
End With
End With
Any idea why I am getting the ByRef error?
EDIT:
I adjusted the code a little bit to be:
Code2 = "Sub ExecuteTest_Click()" & vbCrLf & _
"Dim Sec_Delay as Worksheet" & vbCrLf & _
"Set Sec_Delay = ActiveSheet" & vbCrLf & _
"MathCode Sec_Delay" & vbCrLf & _
"End Sub"
I no longer get the ByRef error, but the the MathCode returns a bunch of zeros and even copies some data from the sheet Pri_Delay instead of using the data from Sec_Delay. If anyone might know why, I'd appreciate it.

The requested member of the collection does not exist error in word 2007

I am trying to use a macro to generate an invoice number, then insert it in a specific place, then save the document as the newly generated number. I have the code below but when I try to run it, it comes back with an error that says "The requested member of the collection does not exist."
Sub CreateInvoiceNumber()
Invoice = System.PrivateProfileString("C:\Users\Chad\Documents\BOLTemplate\" & _
"invoice-number.txt", "InvoiceNumber", "Invoice")
If Invoice = "" Then
Invoice = 1
Else
Invoice = Invoice + 1
End If
System.PrivateProfileString("C:\Users\Chad\Documents\BOLTemplate\" & _
"invoice-number.txt", "InvoiceNumber", "Invoice") = Invoice
'Insert the number in the document
ActiveDocument.Bookmarks(“Invoicenan”).Range.InsertBefore Format(Invoice, "")
ActiveDocument.SaveAs2 FileName:= _
"C:\Users\Chad\Documents\BOLTemplate\inv" & Format(Invoice, "") & ".docx" _
, FileFormat:=wdFormatXMLDocument, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False, CompatibilityMode:=14
End Sub
I believe the error is in this line because it will generate the number, but won't insert it.
ActiveDocument.Bookmarks(“Invoicenan”).Range.InsertBefore Format(Invoice, "")
Any thoughts as to what the issue could be?
Your code looks correct to me, so this is more of a debugging approach than an answer. To isolate the problem I would try breaking things down into tiny steps to isolate the failure. Something like:
Debug.Print "The active document is" " & ActiveDocument.Name
Dim wd as Word.Document
Set wd = ActiveDocument
Debug.Print "The document being created is" " & wd.Name
Dim bk as Word.Bookmark
Debug.Print "This document has these bookmarks"
For Each bk in wd.Bookmarks
Debug.Print bk.Name
If bk.Name = "Invoicenan" Then
Debug.Print "It's a match!"
Dim r as Word.Range
Set r = bk.Range
r.InsertBefore Format(Invoice, "")
End If
Next bk
If no matches are found, then drill down into that. Compare the lengths of "Invoicenan" and the bookmark that is supposed to match. If they match, do a char by char comparison, Etc.
Hope this helps

VBA - How do I send new line command (\n) or tab command (\t) to a textbox.textrange.text of a PowerPointS Shape

SlideNumber = 1
Set oPPTSlide = oPPTFile.Slides(SlideNumber)
For y = 1 To oPPTSlide.Shapes.Count
MsgBox oPPTSlide.Shapes(y).Name
Next
With oPPTSlide.Shapes("Title 1")
.TextFrame.TextRange.Text = _
"Operations Monthly Report\n" & _
"April " & _
"2014"
End With
This is the code I have now. The "\n" does cause the text-box I am editing to start a new line. Is it possible? The code, in its context, is working perfectly. The exact text is sent to the text-box though, not two lines of text.
There is no "\n" in Vba instead you should use VbNewLine or VbCrLf or Vblf
Replace this
SlideNumber = 1
Set oPPTSlide = oPPTFile.Slides(SlideNumber)
For y = 1 To oPPTSlide.Shapes.Count
MsgBox oPPTSlide.Shapes(y).Name
Next
With oPPTSlide.Shapes("Title 1")
.TextFrame.TextRange.Text = _
"Operations Monthly Report" & VbCrLf & _
"April " & _
"2014"
End With
I had the problem where the vbNewLine didn't work in the UserForm, but I fixed it by checking the textBox properties and making sure multi-line is true. Give that a try.

How do I add to the formula to separate into columns

How do augment this formula
=IF(ISERROR(FIND(" ",TRIM(A1),1)),TRIM(A1),MID(TRIM(A1),FIND(" ",TRIM(A1),1),LEN(A1)))
to separate the data below into columns by symptom cause resolution
L=Cannot print in UNIX
Symptom: Cannot print or plot in UNIX Cause: Configuration issue
Resolution: Escalate to the appropriate team Escalation Path: OEMM GIT Desktop References: Keywords: ZEH Created:
I like to get messy and complicated, but this can be done very easy Old fashion style.
hit Ctrl H
replace your multiple line break chars (i.e. "1234") with a single wild char "~" or "}" are usually good
use Excel's feature "text to columns" to break the line based on your wild char separator. (ctrl +A, +E)
If you only have a single space " " to delimit your columns simply use text to column, check Delimited, and hit " " under Other separator, then Finish.
And of course, before doing this, you should copy the column (paste/special values on column C, and then breake it to keep the initial values on column B) :)
Hope this help.
EDIT
Here is a piece of code that I wrote up (in a bit of a hurry). This follows the example from above with user input for column select and the string of chars used to break the text. If you only need to use space as "text breaker" then enter " " in the second promt.
Usually I take time to "clean" the code but this is what 10 minutes produced:
Sub SplitColumns()
DestinationColumn = InputBox("Please enter the name of the column you on which you want to perform the split", _
"Column Selection", "A", 100, 100)
Dim ReplaceRange As Range: Set ReplaceRange = ActiveSheet.Range(DestinationColumn & ":" & DestinationColumn)
SeparatorString = InputBox("Please enter the string of charatesrs used to define the split", _
"String Definition", "anything goes", 100, 100)
' Please be carefull and check for anythinkg like "~" as it will produce errors if found within the cell text
Dim Response As Integer
Response = MsgBox(prompt:= _
"Are you sure you want to split the text from column [" & DestinationColumn & "] based on [" & SeparatorString & "] ?" & vbNewLine & _
"Once the macro is run, there is no Undo Option available(Ctrl+Z)", _
Buttons:=vbYesNo)
If Response = vbYes Then
ReplaceRange.Replace _
What:=SeparatorString, _
Replacement:="~", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
ReplaceRange.TextToColumns _
Destination:=Range(DestinationColumn & "1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
OtherChar:="~", _
FieldInfo:=Array(Array(1, 1), Array(2, 1)), _
TrailingMinusNumbers:=True
End If
End Sub
Maybe I'll give this code another shot for a facelift (some other time).
Hope there's no debuging to be done. I've tested it on Excel 2007. Cheers!