hexagon logo
Register Sign in
  • Replies 13 replies
  • Subscribers 30 subscribers
  • Views 413 views
  • Users 0 members are here
Options
Related

Ballooning script / Problem with "SetLine"

Lorenzo_be
Hi everyone,

I wanted to write a script, that loops through all comments in PCDMIS and changes them accordingly...

We use Ballooned drawings and sometimes have 5 times the same dimension so we'd name them (for example dimension number 80) (80.1) / (80.2) / (80.3) ...
The script should correct multiple occurences automatically. So I would just have to put (80) each time in my comment and the script will keep track of every occurence and change them...

Allmost everything works fine; Unluckily i still have problems with the "SetLine" Command... Says "missing Argument(s)" but in the documentation i dont see any clue on what's going wrong. 

Sub Main()
Dim PCDApp As Object
Dim PCDPartPrograms As Object
Dim PCDPartProgram As Object
Dim PCDCommands As Object
Dim PCDCommand As Object
Dim PCDComment As Object

Dim sContents As String
Dim iCnt As Integer
Dim j As Integer
Dim iCount As Integer
Dim num as Integer
Dim arr() as Integer


Set PCDApp = CreateObject("PCDLRN.Application")
Set PCDPartPrograms = PCDApp.PartPrograms
Set PCDPartProgram = PCDApp.ActivePartProgram
Set PCDCommands = PCDPartProgram.Commands

For iCnt = 1 To PCDCommands.Count
Set PCDCommand = PCDCommands.Item(iCnt)
If (PCDCommand.IsComment) Then
Set PCDComment = PCDCommand.CommentCommand
If (PCDComment.CommentType = 1) And (inStr(1,PCDComment.Comment,"Aln")<1)Then
For j = 1 To 10
If (PCDComment.GetLine(j)="") Then Exit For
sContents = PCDComment.GetLine(j)
MsgBox sContents 'Bulle mit Klammern
sContents = Replace(sContents, "(", "")
sContents = Replace(sContents, ")", "")
MsgBox sContents 'Bulle ohne Klammern
If IsNumeric(sContents) Then
num = sContents
ReDim Preserve arr(num)
arr(num) = arr(num) + 1
sContents = "(" & num & "." & arr(num) & ")"
MsgBox sContents 'Angepasste Bulle mit Klammern
PCDComment.SetLine(j,sContents) 'funktioniert nicht...
End If
Next
End If
End If
Next iCnt
End Sub
​

Any Ideas?
  • Hi everyone,i found the misstake...
    I wanted to keep the array as small as possible and didnt fix ot to a specific number...
    When i ReDim the array from 40 down to 30 my value gets lost.

    I just fixed it to 500 (ballooning rarely goes higher then 500) in my initial Dim statement and now it does what it's supposed to :-)

    If someone has the need to use / adapt this for his/her own purposes, here is the complete and working script: 

    Sub Main()
   Dim PCDApp As Object
   Dim PCDPartPrograms As Object
   Dim PCDPartProgram As Object
   Dim PCDCommands As Object
   Dim PCDCommand As Object
   Dim PCDComment As Object

   Dim sContents As String
   Dim iCnt As Integer
   Dim j As Integer
   Dim iCount As Integer
   Dim count As Integer
   Dim num As Integer
   Dim arr(500) As Integer
   Dim retVal As Long


   Set PCDApp = CreateObject("PCDLRN.Application")
   Set PCDPartPrograms = PCDApp.PartPrograms
   Set PCDPartProgram = PCDApp.ActivePartProgram
   Set PCDCommands = PCDPartProgram.Commands

   For iCnt = 1 To PCDCommands.Count
   Set PCDCommand = PCDCommands.Item(iCnt)
   If (PCDCommand.IsComment) Then
      Set PCDComment = PCDCommand.CommentCommand
      If (PCDComment.CommentType = 1) And (inStr(1,PCDComment.Comment,"Aln")<1)Then
         For j = 1 To 10
            If (PCDComment.GetLine(j)="") Then Exit For
            sContents = PCDComment.GetLine(j)

            count = Len(PCDComment.GetLine(j))-2
            sContents = mid(PCDComment.GetLine(j),2,count) 'Bullage ohne Klammern

            If IsNumeric(sContents) Then
               num = Cint(sContents)
               arr(num) = arr(num) + 1
               sContents = "(" & num & "." & arr(num) & ")"
               retVal = PCDComment.SetLine(j, sContents)
            End If
         Next
         End If
      End If
   Next iCnt
End Sub


    Thank you all for your contribution :-)​
  • You should post the code in its own thread.

    Well done!
  • I'll post it in another threat after final clean -up!
    Good idea!
© 2024 Hexagon AB and/or its subsidiaries. Privacy Policy | Cloud Services Agreement