How do I refactor the following sub-routine so it does not use the Variant data type?
Sub BreakAllLinks()
Dim Link As Variant
Dim myLinks As Variant
myLinks = Excel.ActiveWorkbook.LinkSources(Type:=Excel.xlLinkTypeExcelLinks)
For Each Link In myLinks
Excel.ActiveWorkbook.BreakLink Name:=Link, Type:=Excel.xlLinkTypeExcelLinks
Next Link
End Sub
Here's how you could do it with no Variants - but you shouldn't.
Sub BreakAllLinks()
Dim myLinks() As String
Dim LinkIdx As Long
Dim Link As String
ReDim myLinks(1 To UBound(ActiveWorkbook.LinkSources(xlLinkTypeExcelLinks)))
For LinkIdx = LBound(myLinks) To UBound(myLinks)
myLinks(LinkIdx) = ActiveWorkbook.LinkSources(xlLinkTypeExcelLinks)(LinkIdx)
Next LinkIdx
For LinkIdx = LBound(myLinks) To UBound(myLinks)
Link = myLinks(LinkIdx)
ActiveWorkbook.BreakLink Link, xlLinkTypeExcelLinks
Next LinkIdx
End Sub
That's a little over-the-top on purpose to demonstrate all the data types involved. You can only For..Each an array with a Variant - it's just how the language is written. The best practice isn't 'don't use Variants' but rather 'Use the most restrictively typed variable that you can'. In your case, the Variant is the most restrictively typed variable you can use.
There is a way to write that without Variants and not so obviously crazy
Sub BreakAllLinks()
Dim LinkIdx As Long
For LinkIdx = LBound(ActiveWorkbook.LinkSources(1)) To UBound(ActiveWorkbook.LinkSources(1))
ActiveWorkbook.BreakLink ActiveWorkbook.LinkSources(1)(1), xlLinkTypeExcelLinks
Next LinkIdx
End Sub
But even then, I'd opt for the Variant. It's worth the trade off.
A Linksource is a String.
But why bother ?
Sub M_snb()
For Each it In ActiveWorkbook.LinkSources(1)
MsgBox = TypeName(it)
ActiveWorkbook.BreakLink it, 1
Next
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
Below code is trying to convert words in lowercase in to uppercase. However I only need to run it only in a specific word style ("Normal"). I tried to set doc to ActiveDocument.Styles("Normal") but i keep on getting error. Any help would be most helpful. Thank you in advance.
Option Explicit
Public Sub TitleCaseDocument()
Dim doc As Document: Set doc = ActiveDocument.Styles("Normal")
Dim wrd As Range
For Each wrd In doc.Words
If wrd.Text <> UCase$(wrd.Text) Then wrd.Case = wdTitleWord
Next
End Sub
The solution provided by #eaazel falls into the default member trap.
The code
wrd.Style
is in reality using the default member of the style object, which is 'NameLocal'. Thus the code implied by the code above is in reality
wrd.Style.NameLocal
Normally this would not be a problem, however, the level of granularity that is being used to extract the style object means that, on occasion, words with no style will be encountered (e.g. a ToC field). In such a case the style object returned is nothing and this generates a surprising error because you cannot call the NameLocal method on an an object that is nothing.
Therefore a more correct approach is to use a word unit that is guaranteed to have a style object (e.g. paragraphs) and to test for the style on this object before testing each word.
Option Explicit
Public Sub TitleCaseDocument()
Dim myDoc As Document: Set myDoc = ActiveDocument
Dim myPara As Range
For Each myPara In myDoc.StoryRanges.Item(wdMainTextStory).Paragraphs
If myPara.Style.NameLocal = "Normal" Then
TitleParagraph myPara
End If
Next
End Sub
Public Sub TitleParagraph(ByVal ipRange As Word.Range)
Dim myText As Range
For Each myText In ipRange.Words
If Not UCase$(myText.Text) = myText.Text Then
myText.Words.Item(1).Case = wdTitleWord
End If
Next
End Sub
Update 2020-Apr-16 Revised code below which has been proved to work on a Word document.
Option Explicit
Public Sub TitleCaseDocument()
Dim myDoc As Document: Set myDoc = ActiveDocument
Dim myPara As Word.Paragraph
For Each myPara In myDoc.StoryRanges.Item(wdMainTextStory).Paragraphs
If myPara.Style.NameLocal = "Normal" Then
TitleParagraph myPara
End If
Next
End Sub
Public Sub TitleParagraph(ByVal ipPara As Word.Paragraph)
Dim myText As Range
For Each myText In ipPara.Range.Words
If Not UCase$(myText.Text) = myText.Text Then
myText.Words.Item(1).Case = wdTitleWord
End If
Next
End Sub
So Do You want to change lowercase in to uppercase if style is normal?
Yes?
I don't have big experience with word but maybe something like this help you (base on your code):
Public Sub TitleCaseDocument()
Dim doc As Document: Set doc = ActiveDocument
Dim wrd As Range
For Each wrd In doc.Words
If wrd.Text <> UCase$(wrd.Text) And wrd.Style = "Normal" Then
wrd.Text = UCase$(wrd.Text)
End If
Next
End Sub
I have this .dwg file that has hundreds of block references.
I am trying to create hyperlink to a pdf file from all of the block references. The pdf are on my D drive.
For example, names of the block refernece are: '2:test', '26:test', '234:test'. Essentially hyperlink for
each point would be: '2:test' would hyperlink to D:\Reports\File-002.pdf;
'26:test' would hyperlink to D:\Reports\File-026.pdf; '234:test' would hyperlink to D:\Reports\File-234.pdf.
From block
references i get the number before the ':', and its matching pdf would be 'File-' followed by the number before ':' in 3 digits.
There are lot of these to do by hands, and i think i can program for this.
I have enough basic programming knowledge to manipulate the string to get my number and convert it in 3 digits. The question i have
and/or need help is with how to cycle through each block reference(for loop) on the file and be able to write to its hyperlink property? Is this even possible?
Before coming here i kind of looked at these links but they did not prove helpful:
Link1; Link2; Link3
Thanks for the hints
UPDATE
Private Sub CommandButton1_Click()
Dim ReadData As String
Open "C:\Desktop\Files\DesignFile.DWG" For Input As #1
Do Until EOF(1)
Line Input #1, ReadData
MsgBox ReadData 'Adding Line to read the whole line, not only first 128 positions
Loop
Close #1
End Sub
You can try this:
Dim stringInput
stringInput = "2:test', '26:test', '234:test"
stringSplit = Split(stringInput, ",")
For i = 0 To UBound(stringSplit)
Debug.Print (stringSplit(i))
Next i
Outputs:
2:test'
'26:test'
'234:test
you can try this
Option Explicit
Sub test()
Dim acBlockRef As AcadBlockReference
Dim baseStrng As String
baseStrng = "D:\Reports\File-"
For Each acBlockRef In BlockRefsSSet("BlockRefs")
acBlockRef.Hyperlinks.Add("PDF").URL = baseStrng & Format(Left(acBlockRef.Name, InStr(acBlockRef.Name, "-") - 1), "000") & ".pdf"
Next acBlockRef
ThisDrawing.SelectionSets("BlockRefs").Delete
End Sub
'-----------------------------------------------------------------
'helper functions
'------------------
Function BlockRefsSSet(ssetName As String, Optional acDoc As Variant) As AcadSelectionSet
'returns a selection set of all block references in the passed drawing
Dim acSelSet As AcadSelectionSet
Dim Filtertype(0) As Integer
Dim Filterdata(0) As Variant
Set BlockRefsSSet = CreateSelectionSet(ssetName, acDoc)
Filtertype(0) = 0: Filterdata(0) = "INSERT"
BlockRefsSSet.Select acSelectionSetAll, , , Filtertype, Filterdata
End Function
Function CreateSelectionSet(selsetName As String, Optional acDoc As Variant) As AcadSelectionSet
'returns a selection set with the given name
'if a selectionset with the given name already exists, it'll be cleared
'if a selectionset with the given name doesn't exist, it'll be created
Dim acSelSet As AcadSelectionSet
If IsMissing(acDoc) Then Set acDoc = ThisDrawing
On Error Resume Next
Set acSelSet = acDoc.SelectionSets.Item(selsetName) 'try to get an exisisting selection set
On Error GoTo 0
If acSelSet Is Nothing Then Set acSelSet = acDoc.SelectionSets.Add(selsetName) 'if unsuccsessful, then create it
acSelSet.Clear 'cleare the selection set
Set CreateSelectionSet = acSelSet
End Function
'-----------------------------------------------------------------
with following notes:
you can't have a colon (":") in a block name
so I used a hypen ("-") as its substitute
every block reference object will be attached the URL ("D:\Reports\File-nnn.pdf") associated with the block name it's a reference of
I am trying to send a group message to more than one user over Lync/Microsoft Communicator from Excel using VBA.
The below code works for a single e-mail address/user but if a cell range of two e-mail addresses is provided, it gives "Method 'CreateGroup' of Object IMessengerAdvanced' failed" error. Any advice would be greatly appreciated.
Sub sendIM()
Dim msgr As CommunicatorAPI.IMessengerConversationWndAdvanced
Dim msgTo As Variant
msgTo = Sheets("Sheet1").Range("A1:A2").Value
msgr = Messenger.InstantMessage(msgTo)
msgr.SendText ("Test")
End Sub
The InstantMessage(Object) method supposedly works for >1 user according to this previous topic below, but in practice it doesn't seem to...
Lync notification of offline people using VBA
The interface expects an Array of email addresses when sending to a group.
instead of:
Sub sendIM()
Dim msgr As CommunicatorAPI.IMessengerConversationWndAdvanced
Dim msgTo As Variant
msgTo = Sheets("Sheet1").Range("A1:A2").Value
msgr = Messenger.InstantMessage(msgTo)
msgr.SendText ("Test")
End Sub
test this:
Sub sendIM()
Dim msgr As CommunicatorAPI.IMessengerConversationWndAdvanced
Dim msgTo() As Variant
ReDim msgTo(0 To 0) 'Allocate first element
For Each cell In Sheets("Sheet1").Range("A1:A2")'put your range here
msgTo(UBound(msgTo)) = cell.Value2 'Assign the array element
ReDim Preserve msgTo(UBound(msgTo) + 1) 'Allocate next element
Next
ReDim Preserve msgTo(LBound(msgTo) To UBound(msgTo) - 1) 'Deallocate the last, unused element
'sometimes you need to use Set, sometimes you dont, depending on environment you have, or maybe OPTION EXPLICIT
Set msgr = Messenger.InstantMessage(msgTo)
'msgr = Messenger.InstantMessage(msgTo)
msgr.SendText ("Test")
End Sub
I apologize if this is a total noob question. I'm in the process of writing an addin for Excel. I have a sub inside class1 that opens an excel file, in this sub I have a reference to sub2 which is below. All I am looking to do is hook into the active instance of Excel, change a named range value and exit. But I keep getting errors no matter which way that I try. Here is what I have. Tell me where I have gone wrong. Forgot to mention, this is in VB.NET.
Private Sub SetRangeValue(ByVal RangeName As String, ByVal RangeValue As String)
Dim ExcelApp As Excel.Application
Dim TheRange As Excel.Range
Dim TheRangeName As String = ""
'Hook into running excel instance
ExcelApp = CType(Marshal.GetActiveObject("Excel.Application"), Excel.Application)
'First Attempt Here
TheRange = ExcelApp.ActiveWorkbook.Names.Item(RangeName)
TheRange.Value = RangeValue
'Second Attempt
TheRange = ExcelApp.Range(RangeName)
TheRange.Value = RangeValue
End Sub
I can't get either one to work. Any help is appreciated.
Finally I got this to work properly. This is how it needed to work. Thanks for all the help.
Private Sub SetRangeValue(ByVal RangeName As String, ByVal RangeValue As String)
Dim ExcelApp As Excel.Application
'Dim TheRangeObj As Excel.Range
Dim TheRange As Microsoft.Office.Interop.Excel.Name
Dim TheRangeName As String = ""
'Hook into running excel instance
ExcelApp = CType(Marshal.GetActiveObject("Excel.Application"), Excel.Application)
TheRange = ExcelApp.ActiveWorkbook.Names.Item(RangeName)
TheRange.RefersToRange.Value = RangeValue
End Sub
'First Attempt Here
TheRange = ExcelApp.ActiveWorkbook.Names.Item(RangeName)
TheRange.Value = RangeValue
According to Names.Item Method (Excel), this function returns a single Name object from a Names collection. In this case TheRange is not valid name for this variable, it should be TheName. Then
TheName.Value = RangeValue
is not right assignment; According to Name.Value Property (Excel) this property - Returns or sets a String value that represents the formula that the name is defined to refer to.
Error 0x800A03EC, there are a number of reasons this error is returned from Excel - the most common is when attempts to write data larger than Excel can handle. For example, you try to write a string longer than 1024 characters to a cell in Excel
I just made a sub that would make it easier me to find & replace using my named ranges:
Private Sub XlFindReplace(ByRef xSheet As Excel.Worksheet, ByVal cellName As String, ByVal NewText As String)
xSheet.Range(cellName).Value = NewText
End Sub
then T'd call it like this in order to replace stuff:
XlFindReplace(xlC1Sheet, "client1Co1Tax", client1Co1Tax)
where the xlC1Sheet is the sheet I'm currently
the "client1Co1Tax"is the name of the range in excel
and client1Co1Tax is the string variable I'm replacing it
Thanks to everyone for their input.