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