RSTAB8 mit Excel VBA

[brm]

Guten Tag

Mein Ziel ist es, mit RS-Com die Arbeit zu erleichtern.
Gerne möchte ich meine Errungenschaften mit euch teilen und dank euren Vorschlägen verbessern.

Die zip-Datei enthält eine "vollständige" xlsm-Datei mit einigen Hilfsprogrammen.

Als erste Kostprobe mein Makro zum erstellen eines Modells aus einer Vorlage.

Option Explicit

'Erstellt von Bruno Maurer am 25.04.2017

Sub pRSsave()

Dim sBox As String
Dim sVpfad As String
Dim sPfad As String
Dim sVname As String
Dim sName As String
Dim sFile As String

Dim i As Integer
Dim iCount As Integer

'RS-COM Objekte (Verweis auf "Dlubal RSTAB Type Library v8.0" muss aktiv sein.)
Dim vApp As IApplication

On Error GoTo e     'Sprung falls Fehler

' Variabeln einlesen
sVname = Cells(5, 2)
sVpfad = "N:\500_Engineering\511_RSTAB\513_Vorlagen\" & sVname & ".st8"
sName = Cells(2, 2)
sPfad = Cells(3, 2)
sFile = sPfad & "\" & sName & ".rs8"

'Kontrollen
If Mid(sVname, 2, 1) <> "-" Then                        'Programm-Abbruch mit MessageBox
    sBox = MsgBox("Es wurde keine nH-RSTAB-Vorlage aktiviert." & Chr(13) & "Deren Name enthält als zweites Zeichen einen Bindestrich.", , "Meldung")
    Exit Sub
End If

Call pExists(sPfad, sName)

If bExists = True Then                        'Programm-Abbruch mit MessageBox
    sBox = MsgBox("Die Datei exisiert bereits." & Chr(13) & "Wähle einen anderen Namen.", , "Meldung")
    Exit Sub
End If

Set vApp = New RSTAB8.Application
vApp.LockLicense                                                'Lizenz blockieren
vApp.Show

vApp.OpenModel (sVpfad)                                         'Modell(-vorlage) öffnen

vApp.GetActiveModel.Save (sFile)                                'Modell abspeichern (Es wird ohne zu fragen überschrieben. Darum die Kontrolle am Anfang.)

Application.WindowState = xlMinimized

e:                                                                              'Fehlermeldung ausgeben
If Err.Number <> 0 Then MsgBox Err.Description, vbCritical, Err.Source

vApp.UnlockLicense          'unlocking RS-COM licence
Set vApp = Nothing          'Objektvariabeln leeren

End Sub

Sub pExists(ByVal sPfad As String, ByVal sName As String)

Dim oFS As Object
Dim oFolder As Object
Dim oFile As Object

Set oFS = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFS.GetFolder(sPfad)

bExists = False

For Each oFile In oFolder.Files

    If oFile.Name Like sName & ".rs8" Then
    
        bExists = True

    End If
    
Next oFile

Set oFS = Nothing                 'Objektvariabeln leeren
Set oFolder = Nothing
Set oFile = Nothing

End Sub

Viel Spass und bis bald.