Open Rhino drawing and read/write text field with VBA or .net VB


#1

Hi all,

I need advice how to read/write some text fields in the template of 3DM drawing with use of VBA (MS Access Visual Basic) or alternatively .net VB. I found in my installation folder of Rhino some .dll but most of them are not usable as reference in VBA. Are there some another .dll/ocx for VBA? If not then I can write program in .net VB which can be called from VBA and take/write text in a text file. Anyway I need help with beginning. Are there some examples and guides please?

Radek Freisleben


(Dale Fugier) #2

Rhino can be automated via COM/ActiveX.

http://4.rhino3d.com/5/rhinoscript/introduction/external_access.htm

Does this help?


#3

Thanks too much Dale,

I am now able to open Rhino and execute some commands but I need yet to open concrete rhino file, switch to another sheet (if necessary), connect object with fixed ID and read or write text of this object. I tried to make this with script object but I am not so experienced or it is not right way. I select this object by ID but then i need to access his properties. Please advise me one more time.

Radek


(Dale Fugier) #4

If you need to open a file, just script the Open command using the Rhino.Command method.

For example:

Call Rhino.Command("_-Open test.3dm", 0)


#5

It was quite difficult for me but I have achieve it. I give my code here. Maybe can it inspire someone with similar problem.

Public Declare Function GetUserName& Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long)

Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long

Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal 
lpString As String, ByVal cch As Long) As Long

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long

Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal wIndx As Long) As Long

Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long

Const GW_HWNDFIRST = 0
Const GW_HWNDLAST = 1
Const GW_HWNDNEXT = 2
Const GW_HWNDPREV = 3
Const GW_OWNER = 4
Const GW_CHILD = 5
Const GW_MAX = 5
Const GWL_STYLE = (-16)
Const WS_VISIBLE = &H10000000
Const WS_BORDER = &H800000
Dim instanci As Byte

Public Sub WriteInRhino(ID As Long)

    Dim rh
    Dim fso
    Dim file
    Dim Name As String
    Dim Text As String
    Dim rst As DAO.Recordset
    Dim inst As Byte
    On Error GoTo Exithere

    Name = "C:\HAKProg\Vykresy\ID.rvb"
    
    If UCase(DLookup("Koncovka", "tblSoubory", "ID=" & ID)) <> "3DM" Then
        Bublina "Chyba", "Soubor není *.3DM !", btWarning
        GoTo Exithere
    End If

    If Nz(ID, "") = "" Then GoTo Exithere

Znovu:
    While inst = RhinoInstanci > 1
        If MsgBox("Máte spuštěnou více než jednu instanci Rhina!" & vbCrLf & "Smí běžet maximálně jedna instance s tímto výkresem.", vbRetryCancel, "Příliš instancí") = vbCancel Then
            GoTo Exithere
        End If
    Wend

    Set rst = CurrentDb.OpenRecordset("Select * From tblTMPTitles")

    If inst = 1 Then
        If rst.RecordCount = 1 Then
            rst.MoveFirst
            Text = Left(rst!Title, InStr(1, rst!Title, ".3DM", vbTextCompare) - 1)
            If Text <> CStr(ID) Then
                Select Case MsgBox("Máte otevřený jiný výkres!", vbAbortRetryIgnore, "Pozor")
                    Case vbAbort
                        GoTo Exithere
                    Case vbRetry
                        GoTo Znovu
                End Select
            End If
        End If
    End If
    
    Set rst = CurrentDb.OpenRecordset("Select * From tblSoubory Where ((tblSoubory.ID)=" & ID & ")")

    If rst.RecordCount > 0 Then
        Set fso = CreateObject("scripting.filesystemobject")
        Set file = fso.CreateTextFile(Name, True, False)

        file.WriteLine ("Option Explicit")
        file.WriteLine ("Call Main")
        file.WriteLine ("Sub Main()")
        file.WriteLine ("Rhino.TextObjectText " & Chr(34) & "3384ea3d-3ff1-4cc8-a0e2-478dd20b88d6" & Chr(34) & ", " & Chr(34) & rst!Popis & Chr(34))
        Text = DLookup("UID", "tblVykresy", "ID=" & rst!IDVykresu) & "-" & rst!UID & "-V-" & rst!Verze
        file.WriteLine ("Rhino.TextObjectText " & Chr(34) & "c45baa7c-7591-4226-ba4c-c93e2ee03cd7" & Chr(34) & ", " & Chr(34) & Text & Chr(34))
        file.WriteLine ("Rhino.TextObjectText " & Chr(34) & "869ea492-9ecf-45dc-8f0d-22ffc784d6fa" & Chr(34) & ", " & Chr(34) & WindowsUserName & Chr(34))
        
        file.WriteLine ("Rhino.TextObjectText " & Chr(34) & "d17a1d6b-8aa7-40ed-9480-c4382e01ad81" & Chr(34) & ", " & Chr(34) & rst!Popis & Chr(34))
        file.WriteLine ("Rhino.TextObjectText " & Chr(34) & "746353c0-ed3c-4ec2-bd03-6ded62421980" & Chr(34) & ", " & Chr(34) & Text & Chr(34))
        file.WriteLine ("Rhino.TextObjectText " & Chr(34) & "07316c9d-aa7b-49bb-be46-0ba52fc5c34f" & Chr(34) & ", " & Chr(34) & WindowsUserName & Chr(34))
        
        file.WriteLine ("End Sub")
        file.Close
        
        Set file = Nothing
        Set fso = Nothing

        Set rh = CreateObject("Rhino5x64.Interface")
        
        rh.Visible = True
        If inst = 0 Then
            rh.RunScript "_-Open " & rst!Soubor, 0
        End If
        rh.RunScript "_-Loadscript " & Name, 0
        rh.RunScript "_Save", 0
        
    End If

Exithere:

    Set rst = Nothing
    Set rh = Nothing

End Sub

Public Function RhinoInstanci() As Byte

    Dim hWnd As Long, tbuf As String, RetVal As Long

    CurrentDb.Execute ("Delete * From tblTMPTitles")
    
    instanci = 0
    
    hWnd = GetDesktopWindow()
    hWnd = GetWindow(hWnd, GW_CHILD)
    GetWindowInfo hWnd

    Do While hWnd <> 0
        tbuf = String(255, 0)
        RetVal = GetWindowText(hWnd, tbuf, Len(tbuf))
        hWnd = GetWindow(hWnd, GW_HWNDNEXT)
        GetWindowInfo hWnd
    Loop
    
    RhinoInstanci = instanci
    
End Function

Private Sub GetWindowInfo(ByVal hWnd&)

    Dim Parent&, Task&, Result&, X&, Style&, Title$
    Dim rst As DAO.Recordset

    Style = GetWindowLong(hWnd, GWL_STYLE)
    Style = Style And (WS_VISIBLE Or WS_BORDER)

    Result = GetWindowTextLength(hWnd) + 1
    Title = Space$(Result)
    Result = GetWindowText(hWnd, Title, Result)
    Title = Left$(Title, Len(Title) - 1)

    Set rst = CurrentDb.OpenRecordset("Select * From tblTMPTitles")

    If Style = (WS_VISIBLE Or WS_BORDER) Then
        If InStr(1, Title, " - Rhinoceros (Commercial)", vbTextCompare) <> 0 Then
            rst.AddNew
            rst!Title = Title
            rst.Update
            instanci = instanci + 1
        End If
    End If
    
End Sub

Public Function WindowsUserName() As String
   
    Dim szBuffer As String * 100
    Dim lBufferLen As Long
    
    lBufferLen = 100
     
    If CBool(GetUserName(szBuffer, lBufferLen)) Then
        WindowsUserName = Left$(szBuffer, lBufferLen - 1)
    Else
        WindowsUserName = CStr(Empty)  
    End If

End Function

You need to use Microsoft Scripting Runtime, and Rhinoceros 5.0 Type Library (can find in [Rhino install folder]\System\Rhino5.tlb) references. Bublina is bubble popup and can be replaced with msgbox.

Radek


(Dale Fugier) #6

Wow, that was a lot of work. I though you might do something like this:


#7

Yes it was but it will be payed back after few hundreds drawings. Our company have an access database for technical documentation and every drawing have a template which must be filled with description, ID, name etc. This information are already in database and i save few minutes every database user by every drawing and avoid mistakes.

In any case thanks.