VBA-Script vs. Advance Steel

[Anonymous]

Hello,

I've got a strange problem with a script I wrote.

While scripting, I normally use the way "Run VBA Macro", select the macro and test it.

When I'm ready with writing and it works, I add it to the Advance Steel Toolpalette.

But my actual script doesn't work if I run it from there?!

Inserted in the Toolpalette is it in the following way:

<Command>-vbaload;F:\ASteel\0000_cog.dvb;-vbarun;cog_to_dwg;vbaunload;F:\ASteel\0000_cog.dvb</Command>

When I enter the commands (vbaload ...vbarun…) manually it works, as it should.

After a research I found the source of the error, but I don't know why he occurs.

The shortened, still not working script:

Sub set_cog()
    ThisDrawing.SendCommand "_astm4balancepoint" & vbCr
End Sub

sub cog_to_dwg()
	Call set_cog
End Sub

The error is (in) the SendDommand - after sending the command I get a result, for example

The center of gravity of the selected objects is (633,685,718), the total weight is 4.65 kg.

but the output is followed by Execution Error and my script stops working.

Until now, SendCommand worked always properly?

Does anyone know a way to fix this, so that I can use the full script? 

thanks and kind regards

[Ed__Jobe]

I don't think you've included enough information for me to get the whole picture of what  you're doing, but remember that the SendCommand method is asynchronous. It will run after the vba has finished. So if you are relying on vba to do something after SendCommand finishes, then your logic will fail.

It looks like all your code is doing is running a command created by Advance Steel, which I am not familiar with. If Advance Steel is loaded, you don't need vba to run the command, just call _astm4balancepoint in your ribbon macro.

[Anonymous]

Hello and thanks for your answer.

Here some more Information 🙂

I know that SendCommand is not the best way to get some results, but in this case I need it.
What my complete script does this: delete all points - SendCommand for the Center of gravity - read the coordinates of the point - bring the coordinates onto the drawing which belongs to the model,

I've been running this macro many times, from the play button in the VBA-Editor or from the "run vba macro"-Button in Advance Steel - it worked always. After finishing scripting, I wanted to implement it in the ASteel-Toolpalette (see command for it in my last post), the used commands are the same as the program used in the other ways of executing the script....

After searching where the error occurs, I found the SendCommand is the source of the error, so I shortened the script in my first post (sorry if some things got unclear). The SendCommand brings a result but it stops the scipt.

What  I don't understand is: If I run the complete script "manually" from ASteel (via the "Run VBA Macro" - Button in the ribbons or via Play-Button from VBA-Editor - it works. But if I implement the command in the ASteel-Toolpalette, it don't work, so I think the asynchronity couldn't be the reason - but I'm not sure. 

At the moment I'm looking for a command which sets an delay or which stops the script as long as ASteel is not ready. (a good way seems a loop with : ThisDrawing.Application.GetAcadState.IsQuiescent = True..)

I'll try to solve the problem, and if I get a solution I'll post it here 🙂

kind regards....

[Ed__Jobe]

Are you saying that the set_cog method does more than issue the SendCommand method? If so, show the code for set_cog.

[Anonymous]

Hello,

yes, it does more. 

Here the Code:

The UserForm:

Sub De_Eng_Click()
    ThisDrawing.stamp_lang = "T-SCHWPKT-D"
    Unload UserForm1
End Sub

Sub De_Ru_Click()
    ThisDrawing.stamp_lang = "T-SCHWPKT-R"
    Unload UserForm1
End Sub

Sub De_Sp_Click()
    ThisDrawing.stamp_lang = "T-SCHWPKT-S"
    Unload UserForm1
End Sub

Sub En_Ru_Click()
    ThisDrawing.stamp_lang = "T-SCHWPKT-RE"
    Unload UserForm1
End Sub

Sub En_Sp_Click()
    ThisDrawing.stamp_lang = "T-SCHWPKT-SE"
    UserForm1.Hide
End Sub

and the Script:

Public objSSEnt As AcadSelectionSet
Public SelCount As Integer
Public objEnt As AcadPoint
Public get_point As Variant
Public stamp_lang As String

Sub select_point()
    Dim SelCode(3) As Integer
    Dim SelData(3) As Variant
    Dim Filter1, Filter2 As Variant
     
    On Error Resume Next

    Set objSSEnt = ThisDrawing.SelectionSets.Add("SScollectPoint")
    If Err.Number <> 0 Then
        Set objSSEnt = ThisDrawing.SelectionSets.Item("SScollectPoint")
    End If

    objSSEnt.Clear
    SelCode(0) = 410
    SelData(0) = "Model"
    SelCode(1) = -4
    SelData(1) = "<OR"
    SelCode(2) = 0
    SelData(2) = "Point"
    SelCode(3) = -4
    SelData(3) = "OR>"
    Filter1 = SelCode
    Filter2 = SelData
    objSSEnt.Select acSelectionSetAll, , , Filter1, Filter2
End Sub
Sub kill_points()
    Call select_point
    For Each objEnt In objSSEnt
        objEnt.Delete
    Next
End Sub
Sub set_cog()
    ThisDrawing.SendCommand "_astm4balancepoint" & vbCr
End Sub
Sub read_point()
    Dim location(0 To 2) As Double
    Call select_point
    For Each objEnt In objSSEnt
        get_point = objEnt.Coordinates
        location(0) = get_point(0): location(1) = get_point(1): location(2) = get_point(2)
    Next
End Sub
Sub InsertBlock()
    Dim ActiveDwg As AcadDocument
    Dim TargetDwg As AcadDocument
    Dim ActiveDwg_Name As String
    Dim ActiveDwg_Path As String
    Dim TargetDwg_Name As String
    Dim TargetDwg_Path As String
'creating paths and names
    ActiveDwg_Name = ThisDrawing.Name
    ActiveDwg_Path = ThisDrawing.Path
    TargetDwg_Name = Left(ActiveDwg_Name, 9) & "sheet01.dwg"
    TargetDwg_Path = ActiveDwg_Path & "\" & Left(ActiveDwg_Name, Len(ActiveDwg_Name) - 4) & "\Details\"
    Set ActiveDwg = Application.ActiveDocument
    
'check if file exists
    If FileExists(TargetDwg_Path & TargetDwg_Name) Then
        'create the specific block
            Set TargetDwg = Application.Documents.Open(TargetDwg_Path & TargetDwg_Name)
            Call Create_Block_w_Attribute
        'update the block in target
            Call mod_Block
        'close the drawing
            TargetDwg.Close (True)  'save & close
            ActiveDwg.Activate
    Else
        MsgBox "There's no Drawing with the Name " & TargetDwg_Name & "!"
    End If
End Sub
Sub mod_Block()
    Dim grpCode(1) As Integer
    Dim dataVal(1) As Variant
    Dim ssetObj As AcadSelectionSet
    Dim vAtt As Variant
    Dim oBlockRef As AcadBlockReference

    grpCode(0) = 0: dataVal(0) = "INSERT"
    grpCode(1) = 2: dataVal(1) = stamp_lang
    Set ssetObj = ActiveDocument.SelectionSets.Add("SS01")
    ssetObj.Select acSelectionSetAll, , , grpCode, dataVal
    For Each oBlockRef In ssetObj
         If oBlockRef.HasAttributes Then
            vAtt = oBlockRef.GetAttributes()
            get_point(0) = Math.Round(get_point(0), 2)
            get_point(1) = Math.Round(get_point(1), 2)
            get_point(2) = Math.Round(get_point(2), 2)
            vAtt(0).TextString = get_point(0)
            vAtt(1).TextString = get_point(1)
            vAtt(2).TextString = get_point(2)
        End If
    Next oBlockRef
    ssetObj.Delete

End Sub
Sub Create_Block_w_Attribute()
'Check if Block already exists
    On Error Resume Next
    If ThisDrawing.Blocks(stamp_lang).Name = "" Then
' Define the block
        Dim blockObj As AcadBlock
        Dim insertionPnt(0 To 2) As Double
        insertionPnt(0) = 0
        insertionPnt(1) = 0
        insertionPnt(2) = 0
        Set blockObj = ThisDrawing.Blocks.Add(insertionPnt, stamp_lang)
    
' Create the borders
        Dim lineObj As AcadLine
        Dim start_Line(0 To 2) As Double
        Dim end_Line(0 To 2) As Double
        Dim i As Integer
 
        start_Line(0) = 0: start_Line(1) = 12: start_Line(2) = 0
        end_Line(0) = 47: end_Line(1) = 12: end_Line(2) = 0
        Set lineObj = blockObj.AddLine(start_Line, end_Line)
    
        For i = 1 To 3
            start_Line(0) = 0: start_Line(1) = start_Line(1) + 7.5: start_Line(2) = 0
            end_Line(0) = 47: end_Line(1) = end_Line(1) + 7.5: end_Line(2) = 0
            Set lineObj = blockObj.AddLine(start_Line, end_Line)
        Next
    
        start_Line(0) = 0: start_Line(1) = 47.5: start_Line(2) = 0
        end_Line(0) = 47: end_Line(1) = 47.5: end_Line(2) = 0
        Set lineObj = blockObj.AddLine(start_Line, end_Line)
    
        start_Line(0) = 0: start_Line(1) = 0: start_Line(2) = 0
        end_Line(0) = 47: end_Line(1) = 0: end_Line(2) = 0
        Set lineObj = blockObj.AddLine(start_Line, end_Line)
 
        start_Line(0) = 0: start_Line(1) = 0: start_Line(2) = 0
        end_Line(0) = 0: end_Line(1) = 47.5: end_Line(2) = 0
        Set lineObj = blockObj.AddLine(start_Line, end_Line)
 
        start_Line(0) = 47: start_Line(1) = 0: start_Line(2) = 0
        end_Line(0) = 47: end_Line(1) = 47.5: end_Line(2) = 0
        Set lineObj = blockObj.AddLine(start_Line, end_Line)
 
        start_Line(0) = 29: start_Line(1) = 0: start_Line(2) = 0
        end_Line(0) = 29: end_Line(1) = 34.5: end_Line(2) = 0
        Set lineObj = blockObj.AddLine(start_Line, end_Line)

' Create the Text
        Dim MTextObj As AcadMText
        Dim corner_hl(0 To 2) As Double
        Dim corner_x(0 To 2) As Double
        Dim corner_y(0 To 2) As Double
        Dim corner_z(0 To 2) As Double
        Dim corner_f(0 To 2) As Double
        Dim width_hl, with_xyz As Double
        Dim headline, footer, X_Line, Y_Line, Z_Line As String
    
        corner_hl(0) = 0: corner_hl(1) = 45.7: corner_hl(2) = 0#
        corner_x(0) = 0: corner_x(1) = 32.9: corner_x(2) = 0#
        corner_y(0) = 0: corner_y(1) = 25.4: corner_y(2) = 0#
        corner_z(0) = 0: corner_z(1) = 17.9: corner_z(2) = 0#
        corner_f(0) = 0: corner_f(1) = 11.6: corner_f(2) = 0#
        width_hl = 47
        width_xyz = 29
        X_Line = "X[m]"
        Y_Line = "Y[m]"
        Z_Line = "Z[m]"
        MsgBox stamp_lang
        
        If stamp_lang = "T-SCHWPKT-RE" Then
            headline = ChrW(1062) & ChrW(1045) & ChrW(1053) & ChrW(1058) & ChrW(1056) & " " & ChrW(1058) & ChrW(1071) & ChrW(1046) & ChrW(1045) & ChrW(1057) & ChrW(1058) & ChrW(1048) & vbNewLine & "CENTER OF GRAVITY"
            footer = ChrW(1042) & ChrW(1045) & ChrW(1057) & " [kg]" & vbNewLine & "WEIGHT [kg]"
        ElseIf stamp_lang = "T-SCHWPKT-SE" Then
            headline = "CENTER OF GRAVITY" & vbNewLine & "CENTRO DE GRAVEDAD"
            footer = "WEIGHT [kg]" & vbNewLine & "PESO [kg]"
        ElseIf stamp_lang = "T-SCHWPKT-D" Then
            headline = "SCHWERPUNKT" & vbNewLine & "CENTER OF GRAVITY"
            footer = "GEWICHT [kg]" & vbNewLine & "WEIGHT [kg]"
        ElseIf stamp_lang = "T-SCHWPKT-R" Then
            headline = "SCHWERPUNKT" & vbNewLine & ChrW(1062) & ChrW(1045) & ChrW(1053) & ChrW(1058) & ChrW(1056) & " " & ChrW(1058) & ChrW(1071) & ChrW(1046) & ChrW(1045) & ChrW(1057) & ChrW(1058) & ChrW(1048)
            footer = "GEWICHT [kg]" & vbNewLine & ChrW(1042) & ChrW(1045) & ChrW(1057) & " [kg]"
        ElseIf stamp_lang = "T-SCHWPKT-S" Then
            headline = "SCHWERPUNKT" & vbNewLine & "CENTRO DE GRAVIDAD"
            footer = "GEWICHT [kg]" & vbNewLine & "PESO [kg]"
        End If
        
        Set MTextObj = blockObj.AddMText(corner_hl, width_hl, headline)
        MTextObj.height = 3.5
        MTextObj.AttachmentPoint = acAttachmentPointMiddleCenter
        Set MTextObj = blockObj.AddMText(corner_x, width_xyz, X_Line)
        MTextObj.height = 3.5
        MTextObj.AttachmentPoint = acAttachmentPointMiddleCenter
        Set MTextObj = blockObj.AddMText(corner_y, width_xyz, Y_Line)
        MTextObj.height = 3.5
        MTextObj.AttachmentPoint = acAttachmentPointMiddleCenter
        Set MTextObj = blockObj.AddMText(corner_z, width_xyz, Z_Line)
        MTextObj.height = 3.5
        MTextObj.AttachmentPoint = acAttachmentPointMiddleCenter
        Set MTextObj = blockObj.AddMText(corner_f, width_xyz, footer)
        MTextObj.height = 3.5
        MTextObj.AttachmentPoint = acAttachmentPointMiddleCenter
 
' Add attributes to the block
        Dim attributeObj As AcadAttribute
        Dim height As Double
        Dim mode As Long
        Dim prompt1 As String
        Dim prompt2 As String
        Dim prompt3 As String
        Dim prompt4 As String
        Dim insertionPoint1(0 To 2) As Double
        Dim insertionPoint2(0 To 2) As Double
        Dim insertionPoint3(0 To 2) As Double
        Dim insertionPoint4(0 To 2) As Double
        Dim tag1 As String
        Dim tag2 As String
        Dim tag3 As String
        Dim tag4 As String
        Dim value As String
    
        height = 3.5
        mode = acAttributeModeVerify
        prompt1 = "X"
        prompt2 = "Y"
        prompt3 = "Z"
        prompt4 = "Weight"
        insertionPoint1(0) = 30.5: insertionPoint1(1) = 29: insertionPoint1(2) = 0
        insertionPoint2(0) = 30.5: insertionPoint2(1) = 21.5: insertionPoint2(2) = 0
        insertionPoint3(0) = 30.5: insertionPoint3(1) = 14: insertionPoint3(2) = 0
        insertionPoint4(0) = 30.5: insertionPoint4(1) = 4: insertionPoint4(2) = 0
        tag1 = "T-X"
        tag2 = "T-Y"
        tag3 = "T-Z"
        tag4 = "T-Weight"
        value = "0.000"
        Set attributeObj = blockObj.AddAttribute(height, mode, prompt1, insertionPoint1, tag1, value)
        Set attributeObj = blockObj.AddAttribute(height, mode, prompt2, insertionPoint2, tag2, value)
        Set attributeObj = blockObj.AddAttribute(height, mode, prompt3, insertionPoint3, tag3, value)
        Set attributeObj = blockObj.AddAttribute(height, mode, prompt4, insertionPoint4, tag4, value)
' Insert the block, creating a block reference and an attribute reference
        Dim blockRefObj As AcadBlockReference
        insertionPnt(0) = 25
        insertionPnt(1) = 15
        insertionPnt(2) = 0
        Set blockRefObj = ThisDrawing.PaperSpace.InsertBlock(insertionPnt, stamp_lang, 1#, 1#, 1#, 0)
    Else
        MsgBox "Block already exists and will be updated only!"
    End If
End Sub
Function FileExists(FilePath As String) As Boolean
Dim TestStr As String
    TestStr = ""
    On Error Resume Next
    TestStr = Dir(FilePath)
    On Error GoTo 0
    If TestStr = "" Then
        FileExists = False
    Else
        FileExists = True
    End If
End Function
Sub cog_to_dwg()

    UserForm1.show          'Variable: stamp_lang
   
    Call kill_points
    Call set_cog
    Call read_point
    Call InsertBlock
    Call kill_points
End Sub

[Ed__Jobe]

If you label the processes as shown below,

Sub cog_to_dwg()

    UserForm1.show          'Step 1
   
    Call kill_points     'Step 2
    Call set_cog         'Step 3, asynchronous
    Call read_point      'Step 4
    Call InsertBlock     'Step 5
    Call kill_points     'Step 6
End Sub

 Then, because Step 3 is asynchronous, it will complete last and the order will be 1,2,  4,5 6,  3. If Step 4 relies on results from Step 3 (it looks like read_point sub expects Advance Stell routine to have created an AcadPoint object), then you will get a runtime error in Step 4. Often it is an "Object or block not set" error.

[Anonymous · Accepted solution]

Sorry for the extreme late reply, but I had a lot of work to do and had no time to look for the forum or my code.

But in between I've got a solution.

My code works right, the problem was Advance Steel. The toolpalette is directed by a xml-file and if you click a command on it you are "leaving" Advance Steel for a short time. This "leaving" is the reason for the execution error.

Now I've left the toolpalette and built my own CUIx-File and everything works perfect.

thanks anyway for your help 🙂