Przerobiłem skrypt z netu i nareszcie numerowanie działa mi jak należy. Odinstalować/wyłączyć Balloon Renumber bo kaszani numery
Public Sub PrzenumerujBalony()
' To jest przerobiona wersja skryptu z
http://www.mcadforums.com/forums/viewto ... =15&t=2895
' Skrypt działa w Inventor 2010 pewnie z innymi wersjami też.
' Odinstaluj/wyłącz wszelkie Balloon Renumber bo wyskaują błędy lub źle numeruje części, gryzą się
' Wada skryptu za każdym razem trzeba włączać skrypt aby przenumerować części po zmienach w "Zestawieniu komponentów"
' Moze kiedys usunę te wady.
' Należy zmienić "5" oRow.Item(5).Value na numer kolumny z pozycją licząć od lewej od "1"
' Jakieś pytania
miroslaw.dyduch@gmail.com
Dim oDrawDoc As DrawingDocument
Dim oSheet As Sheet
Dim oPL As PartsList
Dim oRow As PartsListRow
Dim oBalloon As Balloon ' Zmienna balon
Dim bBalloonFound As Boolean ' Jest balon nie ma balona
Dim sPathPart As String ' Sciezka pojedynczej czesci/zespołu
Dim sPathPartsList As String ' Pelna sciezka "Listy części", całego złożenia
Set oDrawDoc = ThisApplication.ActiveDocument ' Aktywny dokument
Set oSheet = oDrawDoc.ActiveSheet ' Aktywny arkusz
If (oSheet.PartsLists.Count = 1) Then ' Jedna lista części w arkuszu, aby skrypt zmienil pozycje wg. wykazu
sPathPartsList = oSheet.PartsLists.Item(1).ReferencedDocumentDescriptor.FullDocumentName
For Each oBalloon In oSheet.Balloons
sPathPart = oBalloon.ParentView.ReferencedDocumentDescriptor.FullDocumentName
bBalloonFound = False
If (sPathPartsList <> sPathPart) Then
For Each oPL In oSheet.PartsLists
If bBalloonFound Then
Exit For
End If
For Each oRow In oPL.PartsListRows
If bBalloonFound Then
Exit For
End If
' Włączona opcja "Ustawienie łączenie wierszy z numerami części"
' Wiele roznych plikow w jednym wierszu np. "Generator ram",
' lewa-prawa część, lustro itp "Frame generator", left-right part, mirror etc
For i = 1 To oRow.ReferencedFiles.Count
If (sPathPart = oRow.ReferencedFiles.Item(i).FullFileName) Then
' Numer kolumny z pozycją części z "Listy części". Liczy sie od lewej od "1" do "n"
' Mozna pokombinować by było co innego w balonie np.:
' oBalloon.BalloonValueSets.Item(1).Value = "Tu był Mirek " & oRow.Item(2).Value & " poz. " & oRow.Item(5).Value
oBalloon.BalloonValueSets.Item(1).Value = oRow.Item(5).Value
bBalloonFound = True
Exit For
End If
Next
Next oRow
Next oPL
End If
Next oBalloon
MsgBox "Done!", vbInformation
Else ' Brak lub wiecej niz 1 lista czści
MsgBox ("W arkuszu MUSI byc jedna ''Lista części'', może być poza ''Ramką rysunkową''!!! " & Chr(13) & _
vbCrLf & "Program odczytuje z ''Listy części '' (''Pozycję'') części i nadpisuje " & _
vbCrLf & "wartość (domyślnie ''1'') w ''Numerze pozycji'' (balonie)." & Chr(13) & _
vbCrLf & "Po zmianach w ''Liście części'' musisz jeszcze raz uruchomić " & _
vbCrLf & "skrypt aby uaktualnić ''Numer pozycji''"), vbInformation
End If
End Sub