Diagnostische import op verschillende onderdelen van een assembly

3D Design Assembly
1

Hallo

Ik heb een IGES geïmporteerd uit een assembly. Solidworks maakt alle onderdelen voor mij, maar voor elk van hen moet ik een importdiagnose uitvoeren om de gezichten te repareren.

Is er een manier om alle onderdelen te repareren zonder ze 1 voor 1 te openen?

2

Nee

3

Hallo

Niet bij mijn weten, maar met behulp van een macro is het zeker mogelijk. 

Fijne dag

1 like
4

Nou ja, eindelijk heb ik een macro gedaan, het kostte me 5 minuten. Je hoeft niet verder te zoeken, hoewel het leuk zou zijn geweest om een speciale functie te hebben:)

1 like
5

Hallo

Kun je het delen?
Zelfs als het beknopt is, kan het praktisch zijn.

Bedankt

6

Ik ben geen VBA-pro, ik heb net gesleuteld, maar het werkt. Ik heb ook een BrowseFolder geplaatst.

 

 

Optie Expliciete

Dim swApp        als SldWorks.SldWorks
Dim swModel      als SldWorks.ModelDoc
Dim sFileName    als tekenreeks
Dim Bestandsnaam    Als String
Dim pad         als snaar
Dim newPath         als tekenreeks
Dim swLayerMgr   Als SldWorks.LayerMgr
Dim swLayer      als SldWorks.Layer
Dim nErrors      zo lang
Dim nWaarschuwingen    zo lang mogelijk

Dim boolstatus als Booleaanse
Dim longstatus Zo lang
Dim lange waarschuwingen zo lang mogelijk
Privé Const BIF_RETURNONLYFSDIRS zo lang = &H1
Privé Const BIF_DONTGOBELOWDOMAIN zo lang = &H2
Privé Const BIF_RETURNFSANCESTORS zo lang = &H8
Privé Const BIF_BROWSEFORCOMPUTER zo lang = &H1000
Privé Const BIF_BROWSEFORPRINTER zo lang = &H2000
Privé Const BIF_BROWSEINCLUDEFILES zo lang = &H4000
Privé Const MAX_PATH zo lang = 260

Functie BrowseFolder (optioneel bijschrift als tekenreeks, optionele InitialFolder als tekenreeks) als tekenreeks

Map dimmen als object
Dim F als map
Dim ShellApp als object
Set ShellApp = CreateObject("Shell.Application")

Set F = ShellApp.BrowseForFolder(0&, Bijschrift, BIF_RETURNONLYFSDIRS, InitialFolder)
Zo niet, dan is F niets, dan is
    Als F = "Desktop" dan
        BrowseFolder = Over ("GEBRUIKERSPROFIEL") & "\Bureaublad"
    Anders
        BrowseFolder = F.Items.Item.Path
    Einde als
Einde als

Functie beëindigen

Sub hoofd()

Stel swApp = Toepassing.SldWorks in

' De bronmap kiezen
Path = BrowseFolder(Caption:="Selecteer bronmap")

    Als pad = "" dan
    'MsgBox "Selecteer bronmap"
    Einde
    Anders
    Pad = Pad & "\"
    Einde als

sFileName = Dir(Pad & "*.sldprt")
    
Doen tot sFileName = ""

Stel swModel in = swApp.OpenDoc6(Pad + sFileName, swDocPART, swOpenDocOptions_Silent, "", nErrors, nWarnings)
Stel swModel = swApp.ActiveDoc in

longstatus = swModel.ImportDiagnosis(Waar, Onwaar, Waar, 0)

Dim swErrors zo lang mogelijk
Dim swWaarschuwingen zo lang mogelijk
boolstatus = swModel.Save3(1, swErrors, swWarnings)

swApp.CloseDoc swModel.GetTitle
Set swModel = Niets


sFileName = Dir

Strik

Einde Sub
 

2 likes