Hallo Zusammen jetzt ist die Sache fertig:
anbei der Code:
' Globale Variable
Dim Zeile As Integer ' Zeilenzähler für Ausgabe im Blatt
Dim Blockanzahl As Long
Dim Featureanzahl As Long
Dim Blockstufe
Sub Main() 'Hauptprogramm
Blockstufe = 1
Featureanzahl = 0 'Featureanzahl = 0 'mal löschen um Featurezaehler auf 0 zu setzen
Call Blattleeren
Call Bloeckeliste
Call Bloeckezaehlen
While Blockstufe < Blockanzahl 'Schleife
Call Oeffnen
Call Featurekopieren
Call Schließen
Call Featurezaehlen
Blockstufe = Blockstufe + 1
Wend
End Sub
Sub Blattleeren()
Worksheets("Features").Activate
Cells.Select
Selection.ClearContents
Range("A1").Select
ActiveCell.FormulaR1C1 = "Partname"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Featurenname"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Typ"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Status"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Anzeige"
End Sub
Sub Bloeckeliste() 'Dateien im Pfad listen hier die BLockliste'
Dim fs As Object
Dim fVerz As Object
Dim fDatei As Object
Dim fdateien As Object
Dim strDat As String
Dim Zeile As Integer
Worksheets("Blockliste").Activate 'Sonst Überschreibungsgefahr
Set fs = CreateObject("scripting.FileSystemObject")
Set fVerz = fs.getFolder("C:\Users\v.gaspert\Desktop\Temp\Blöcke\Parts") 'Pfad auswählen'
Set fdateien = fVerz.Files 'Bereich'
For Each fDatei In fdateien 'Schleife'
If InStr(fDatei, "") > 0 Then ' Integer-Wert zurück, der die Anfangsposition des ersten Auftretens einer Zeichenfolge innerhalb einer anderen Zeichenfolge angibt'
Zeile = Zeile + 1
Cells(Zeile, 1) = fDatei.Path
End If
Next fDatei
End Sub
Function AnzahlZeilen(Blatt As Worksheet) As Integer 'Benötigt für die Zählfunktion
AnzahlZeilen = WorksheetFunction.CountA(Blatt.Range("A:A"))
End Function
Sub Bloeckezaehlen() 'Bloeckzaehlen um Schleifendurchläufe zu bestimmen
Blockanzahl = AnzahlZeilen(Worksheets("Blockliste"))
'MsgBox ("Zeilen:" & Blockanzahl)
End Sub
Sub Oeffnen()
Set swApp = GetObject(, "sldworks.application")
Dim swmod As Object
Sheets("Blockliste").Select
swApp.OpenDoc ActiveSheet.Range("A" & Blockstufe).Value, 1
End Sub
Sub Schließen()
Set swApp = GetObject(, "sldworks.application")
swApp.CloseAllDocuments True
End Sub
Sub Featurekopieren()
Worksheets("Features").Activate 'Sonst wird das Blockskript überschrieben
Dim swApp As Object
Dim Model As Object
' an SolidWorks anklinken und aktives Part holen
Set swApp = CreateObject("SldWorks.Application")
Set Model = swApp.ActiveDoc
If Model Is Nothing Then
Exit Sub
End If
If (Model.GetType <> 1) Then ' Do not allow drawings or assemblies
Msg = "Only Allowed on Parts" ' Define message
Style = vbOKOnly ' OK Button only
Title = "Error" ' Define title
Call MsgBox(Msg, Style, Title) ' Display error message
Exit Sub ' Exit this program
End If
Zeile = Featureanzahl + 2
Set feat = Model.FirstFeature
Do While Not feat Is Nothing
Let featureName = feat.Name
'ist das Feature ein "body"Feature
'Ausschluß von Ebenen, Achsen, Skizzen, ...
res = Model.SelectByID(featureName, "BODYFEATURE", 0, 0, 0)
If res Then
' in Excelblatt den aktuellen Partnamen eintragen ...
Range("A" & Zeile).Select
ActiveCell.FormulaR1C1 = Model.GetTitle
' in Excelblatt den aktuellen Featurenamen eintragen ...
Range("B" & Zeile).Select
ActiveCell.FormulaR1C1 = featureName
' den FeatureTyp...
Range("C" & Zeile).Select
ActiveCell.FormulaR1C1 = feat.GetTypeName
' den Unterdrückungsstatus ...
Range("D" & Zeile).Select
If feat.IsSuppressed Then ActiveCell.FormulaR1C1 = "unterdrückt"
' und den Anzeigestatus im FeatureManager
Range("E" & Zeile).Select
If feat.GetUIState(1) Then ActiveCell.FormulaR1C1 = "versteckt"
' Zeilenzähler zur Ausgabe in Tabellenblatt erhöhen
Zeile = Zeile + 1
End If
' Get the next feature
Set feat = feat.GetNextFeature()
Loop
End Sub
Sub Featurezaehlen() 'Featurezaehlen um Schleifneuansatz zu bestimmen
Featureanzahl = AnzahlZeilen(Worksheets("Features"))
'MsgBox ("Zeilen:" & Featureanzahl)
End Sub
'Superhappy!!!!
------------------
Es gibt nichts Gutes außer man tut es
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP