Macro de composition a emporter

vos questions concernant les API SolidWorks

Macro de composition a emporter

Messagepar Agadoudou » Lun 07 Jan 2013, 16:32

Bonjour à tous et meilleurs voeuxxx !!!!

Je viens vers vous car mes compétences sont encore mis a rude épreuve !!!

Je souhaite automatiser une phase de composition a emporter.

Le but et de la lancer, après une succession de modifications qu’exécute une autre macro sur un assemblage type et de permettre ainsi a l'utilisateur de sauvegarder son ensemble là ou il le souhaite.

J'ai trouvé un code dans l'aide API :

Code: Tout sélectionner
Option Explicit

Dim swApp As SldWorks.SldWorks
Dim swModelDoc As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swPackAndGo As SldWorks.PackAndGo
Dim openFile As String
Dim myFileName As String
Dim pgFileNames As Variant
Dim pgFileStatus As Variant
Dim pgSetFileNames() As String
Dim pgGetFileNames As Variant
Dim pgDocumentStatus As Variant
Dim status As Boolean
Dim warnings As Long
Dim errors As Long
Dim i As Long
Dim j As Long
Dim namesCount As Long
Dim myPath As String
Dim statuses As Variant

Sub main()

Set swApp = Application.SldWorks

' Open assembly
openFile = "C:\test\ensemble.sldasm"
Set swModelDoc = swApp.OpenDoc6(openFile, swDocASSEMBLY, swOpenDocOptions_Silent, "", errors, warnings)
Set swModelDocExt = swModelDoc.Extension

' Get Pack and Go object
Debug.Print "Pack and Go"
Set swPackAndGo = swModelDocExt.GetPackAndGo

' Get number of documents in assembly
namesCount = swPackAndGo.GetDocumentNamesCount
Debug.Print "  Number of model documents: " & namesCount

' Include any drawings and simulation results
swPackAndGo.IncludeDrawings = True
Debug.Print "  Include drawings: " & swPackAndGo.IncludeDrawings
swPackAndGo.IncludeSimulationResults = True
Debug.Print "  Include simulation results: " & swPackAndGo.IncludeSimulationResults

' Get current paths and filenames of the assembly's documents
status = swPackAndGo.GetDocumentNames(pgFileNames)
Debug.Print ""
Debug.Print "  Current path and filenames: "
If (Not (IsEmpty(pgFileNames))) Then
    For i = 0 To UBound(pgFileNames)
        Debug.Print "    The path and filename is: " & pgFileNames(i)
    Next i
End If

' Get current save-to paths and filenames of the assembly's documents
status = swPackAndGo.GetDocumentSaveToNames(pgFileNames, pgFileStatus)
Debug.Print ""
Debug.Print "  Current default save-to filenames: "
If (Not (IsEmpty(pgFileNames))) Then
    For i = 0 To UBound(pgFileNames)
        Debug.Print "   The path and filename is: " & pgFileNames(i)
    Next i
End If

' Folder where to save the files
myPath = "C:\temptest\"

' Create your own filenames for the model's documents
ReDim pgSetFileNames(namesCount - 1)
Debug.Print ""
Debug.Print "  My Pack and Go path and filenames before adding prefix and suffix: "
j = 0
For i = 0 To (namesCount - 1)
         myFileName = pgFileNames(i)
         ' Determine type of SolidWorks file based on file extension
             If InStr(LCase(myFileName), "sldprt") > 0 Then
                 myFileName = j & ".sldprt"
             ElseIf InStr(LCase(myFileName), "sldasm") > 0 Then
                 myFileName = j & ".sldasm"
            ElseIf InStr(LCase(myFileName), "slddrw") > 0 Then
                 myFileName = j & ".slddrw"
             Else
                 ' Only packing up SolidWorks files
                 Exit Sub
             End If
        pgSetFileNames(i) = myPath & myFileName
        Debug.Print "    My path and filename is: " & pgSetFileNames(i)
         j = j + 1
Next i

' If a drawing document existed for the assembly or part document
' used in this example, then you have to ensure that the
' drawing document copied by Pack and Go references the assembly
' or part document copied by Pack and Go and not the original
' assembly or part document
' Calling IPackAndGo::SetSaveToName sets the target for drawings
' included in Pack and Go and overrides a call to
' IPackAndGo::SetDocumentSaveToNames
'status = swPackAndGo.SetSaveToName(True, myPath)

' Set document paths and names for Pack and Go
status = swPackAndGo.SetDocumentSaveToNames(pgSetFileNames)

' Add a prefix and suffix to the new Pack and Go filenames
swPackAndGo.AddPrefix = "SW"
swPackAndGo.AddSuffix = "PackAndGo"

 ' Verify document paths and filenames after adding prefix and suffix
ReDim pgGetFileNames(namesCount - 1)
ReDim pgDocumentStatus(namesCount - 1)
status = swPackAndGo.GetDocumentSaveToNames(pgGetFileNames, pgDocumentStatus)
Debug.Print ""
Debug.Print "  My Pack and Go path and filenames after adding prefix and suffix: "
For i = 0 To (namesCount - 1)
     Debug.Print "    My path and filename is: " & pgGetFileNames(i)
Next i

' Pack and Go
statuses = swModelDocExt.SavePackAndGo(swPackAndGo)

End Sub


Le problème que j'ai, est de tout simplement savoir où le naming des fichiers se fait et surtout ... comment !!! Je vois bien pour le suffixe et le préfixe mais la macro supprime les noms de pièces pour les incrémenter de 1 en 1 ... Ce qui donne des noms du style "SW1Packandgo" ....

Pour ma part, je souhaiterais seulement changer les 4 premiers caractères du nom de chaque pièce et ensemble a partir d'une userform.

Mais étant donné que je ne sais pas quelle partie du code gère ça .... c'est compliqué ....

Idem pour l'endroit où le tout sera sauvegardé ... je vois où est définie l'endroit, mais je souhaiterais que l'utilisateur pointe lui-même le dossier de sauvegarde.

Code: Tout sélectionner
myPath = "C:\temptest\"


Enfin, pour finir, est ce que vous savez si je peux faire une composition a emporter sans la mise a plat du dossier ???

Merci d'avance :D
Merci à TOUS !!!!!
Agadoudou
Padawan SolidWorks
 
Messages: 84
Inscription: Ven 13 Avr 2012, 7:19
Localisation: Clermont Fd

Re: Macro de composition a emporter

Messagepar Agadoudou » Mar 08 Jan 2013, 11:02

Donc après un peu de recherche, j'ai réussi a créer un userform qui vient remplir le suffixe. Mais je n'arrive pas a me debarasser de la phase de changement de nom de fichier d'origine ...

Avec ce code, chaque pièce ou ensemble est renommé entièrement. Le nouveau nom est donné par une espèce de compteur. Par exemple j'ai 6 pièces dans mon assemblage. Il me renomme donc mes fichiers de 0 à 7. (0 étant l'ensemble)

Avec le code comme il est, une pièce s'appelant A.sldprt devient numérod'affaire1.sldprt. (Le numéro d'affaire étant générer par l'userform)

Est ce que quelqu'un pourrais me dire comment virer cette histoire de compteur pour laisser place au nom d'origine ...

Je sais, c'est simple mais je n'y arrive pas !!!! :oops:

Code: Tout sélectionner
Option Explicit

Dim swApp As SldWorks.SldWorks
Dim swModelDoc As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swPackAndGo As SldWorks.PackAndGo

Dim openFile As String
Dim myFileName As String
Dim pgFileNames As Variant
Dim pgFileStatus As Variant
Dim pgSetFileNames() As String
Dim pgGetFileNames As Variant
Dim pgDocumentStatus As Variant
Dim status As Boolean
Dim warnings As Long
Dim errors As Long
Dim i As Long
Dim j As Long
Dim namesCount As Long
Dim myPath As String
Dim statuses As Variant

Sub main()

Set swApp = Application.SldWorks

' Open assembly
openFile = "C:\test\ensemble.sldasm"

Set swModelDoc = swApp.OpenDoc6(openFile, swDocASSEMBLY, swOpenDocOptions_Silent, "", errors, warnings)
Set swModelDocExt = swModelDoc.Extension

' Get Pack and Go object
Debug.Print "Pack and Go"
Set swPackAndGo = swModelDocExt.GetPackAndGo


' Get number of documents in assembly
namesCount = swPackAndGo.GetDocumentNamesCount
Debug.Print "  Nombre de documents modèles : " & namesCount

' Include any drawings
swPackAndGo.IncludeDrawings = True
Debug.Print "  Include drawings: " & swPackAndGo.IncludeDrawings


' Obtenez des chemins courant et de fichiers de documents de l'assemblage
status = swPackAndGo.GetDocumentNames(pgFileNames)

Debug.Print "  Chemin actuel et noms de fichier : "
If (Not (IsEmpty(pgFileNames))) Then
    For i = 0 To UBound(pgFileNames)
        Debug.Print "    Le chemin et le nom de fichier actuel sont : " & pgFileNames(i)
        'MsgBox "    Le chemin et le nom de fichier actuel sont : " & pgFileNames(i)
     
    Next i
End If

' Obtenez le chemin de sauvegarde courant à des chemins et noms de fichier des documents de l'assemblage
status = swPackAndGo.GetDocumentSaveToNames(pgFileNames, pgFileStatus)

Debug.Print "  Le chemin par défaut actuel : "
If (Not (IsEmpty(pgFileNames))) Then
    For i = 0 To UBound(pgFileNames)
        Debug.Print "   Le chemin et le nom de fichier actuel sont : " & pgFileNames(i)
            Next i
           
End If

' Dossier dans lequel enregistrer les fichiers
myPath = "C:\temptest\"

' Créez vos propres noms de fichiers pour les documents du modèle
ReDim pgSetFileNames(namesCount - 1)

UserForm1.Show

Debug.Print "  Composition a emporter chemin et des noms de fichier avant le préfixe ajoutant et le suffixe : "
j = 0
For i = 0 To (namesCount - 1)
         myFileName = pgFileNames(i)
         ' Determine type of SolidWorks file based on file extension
             If InStr(LCase(myFileName), "sldprt") > 0 Then
                 myFileName = j & ".sldprt"
             ElseIf InStr(LCase(myFileName), "sldasm") > 0 Then
                 myFileName = j & ".sldasm"
            ElseIf InStr(LCase(myFileName), "slddrw") > 0 Then
                 myFileName = j & ".slddrw"
             Else
                 ' Only packing up SolidWorks files
                Exit Sub
             End If
        pgSetFileNames(i) = myPath & myFileName
       
         j = j + 1
         
Next i

' Si un document de dessin a existé pour le document de part ou assemblage
' Utilisé dans cet exemple, alors vous devez assurer que le
' Le dessin du document copié par la composition a emporter des références assemblées
' Ou le document de partie copié par la composition a emporter et pas l'original
' Assemblage ou piece
' appel IPackAndGo : SetSaveToName met la cible pour des dessins
' Inclus dans la composition a emporter et ignore un appel à
' IPackAndGo::SetDocumentSaveToNames
status = swPackAndGo.SetSaveToName(True, myPath)

' Définition des chemins et les noms de documents à emporter
status = swPackAndGo.SetDocumentSaveToNames(pgSetFileNames)

' Ajoutez un préfixe et un suffixe au nouveau fichiers
swPackAndGo.AddPrefix = UserForm1.numeroaff.Value
swPackAndGo.AddSuffix = ""

 ' Vérifiez chemins de documents et de fichiers après l'ajout de préfixes et de suffixes
ReDim pgGetFileNames(namesCount - 1)
ReDim pgDocumentStatus(namesCount - 1)
status = swPackAndGo.GetDocumentSaveToNames(pgGetFileNames, pgDocumentStatus)
Debug.Print ""
Debug.Print "  Mon chemin et les noms de fichiers après l'ajout de préfixes et de suffixes: "
For i = 0 To (namesCount - 1)
     Debug.Print "Mon chemin et le nom du fichier est: " & pgGetFileNames(i)
Next i

' Pack and Go
statuses = swModelDocExt.SavePackAndGo(swPackAndGo)

End Sub
Merci à TOUS !!!!!
Agadoudou
Padawan SolidWorks
 
Messages: 84
Inscription: Ven 13 Avr 2012, 7:19
Localisation: Clermont Fd

Re: Macro de composition a emporter

Messagepar liryc » Mar 08 Jan 2013, 13:34

Bonjour,
C'est dans cette partie:
Code: Tout sélectionner
Debug.Print "  Composition a emporter chemin et des noms de fichier avant le préfixe ajoutant et le suffixe : "
j = 0
For i = 0 To (namesCount - 1)
         myFileName = pgFileNames(i)
         ' Determine type of SolidWorks file based on file extension
             If InStr(LCase(myFileName), "sldprt") > 0 Then
                 myFileName = j & ".sldprt"
             ElseIf InStr(LCase(myFileName), "sldasm") > 0 Then
                 myFileName = j & ".sldasm"
            ElseIf InStr(LCase(myFileName), "slddrw") > 0 Then
                 myFileName = j & ".slddrw"
             Else
                 ' Only packing up SolidWorks files
                Exit Sub
             End If
        pgSetFileNames(i) = myPath & myFileName
       
         j = j + 1
         
Next i

Il faut modifier voir supprimer (à tester) le renommage des fichiers dans ces lignes:
Code: Tout sélectionner
 myFileName = j & ".sldprt"
myFileName = j & ".sldasm"
myFileName = j & ".slddrw"

C'est ça qui crée l'incrémentation.
liryc
Chevalier Jedi SolidWorks
 
Messages: 479
Inscription: Ven 02 Mar 2007, 8:14
Localisation: Paris - SW2009 SP5.0

Re: Macro de composition a emporter

Messagepar Agadoudou » Mar 08 Jan 2013, 13:45

Bonjour lyric,

Merci pour ta réponse, effectivement c'était bien ça !!!

je l'ai donc modifié :

Code: Tout sélectionner

' Créez vos propres noms de fichiers pour les documents du modèle

ReDim pgSetFileNames(i)


En revanche, pourrais tu me dire comment je peux déclencher une exporateur windows pour que l'utilisateur détérmine sont dossier cible. Actuellement, le chemin est en dure :

Code: Tout sélectionner
' Dossier dans lequel enregistrer les fichiers
myPath = "C:\temptest\"


Merci pour ta réponse
Merci à TOUS !!!!!
Agadoudou
Padawan SolidWorks
 
Messages: 84
Inscription: Ven 13 Avr 2012, 7:19
Localisation: Clermont Fd

Re: Macro de composition a emporter

Messagepar liryc » Mar 08 Jan 2013, 13:51

liryc
Chevalier Jedi SolidWorks
 
Messages: 479
Inscription: Ven 02 Mar 2007, 8:14
Localisation: Paris - SW2009 SP5.0

Re: Macro de composition a emporter

Messagepar Agadoudou » Mar 08 Jan 2013, 15:21

Merci a toi.

Malgré leurs explications, je n'arrive pas a faire fonctionner cette fonction ... :(

J'ai bien mis cç au début du module :

Code: Tout sélectionner
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2

Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, _
    ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, _
    ByVal lpString2 As String) As Long

Private Type BrowseInfo
    hWndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
     ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type


Avec ça dans ma macro ...

Code: Tout sélectionner
Public Function SelectFolder(Titre As String, Handle As Long) As String

Dim lpIDList As Long
Dim strBuffer As String
Dim strTitre As String
Dim tBrowseInfo As BrowseInfo

strTitre = Titre
With tBrowseInfo
    .hWndOwner = Handle
    .lpszTitle = lstrcat(strTitre, "")
    .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With

lpIDList = SHBrowseForFolder(tBrowseInfo)

If (lpIDList) Then
    strBuffer = String(260, vbNullChar)
    SHGetPathFromIDList lpIDList, strBuffer
    SelectFolder = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1)
End If

End Function


Mais ça ne fonctionne pas. Tu pourrais me préciser si mes insertions sont bonnes ?

Merci !
Merci à TOUS !!!!!
Agadoudou
Padawan SolidWorks
 
Messages: 84
Inscription: Ven 13 Avr 2012, 7:19
Localisation: Clermont Fd

Re: Macro de composition a emporter

Messagepar liryc » Mar 08 Jan 2013, 18:37

Essaye plutôt ça:
En en-tête ou dans un autre module de ta macro:
Code: Tout sélectionner
Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000
Public Const BIF_NEWDIALOGSTYLE = &H40
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Function GetFolder(ByVal sTitle As String) As String

Dim bInf As BROWSEINFO
Dim retval As Long
Dim PathID As Long
Dim RetPath As String
Dim Offset As Integer

bInf.lpszTitle = sTitle
bInf.ulFlags = BIF_NEWDIALOGSTYLE
PathID = SHBrowseForFolder(bInf)
RetPath = Space$(512)

retval = SHGetPathFromIDList(ByVal PathID, ByVal RetPath)

If retval Then
    Offset = InStr(RetPath, Chr$(0))
    GetFolder = Left$(RetPath, Offset - 1)
End If

End Function

Et dans ta macro principale tu appelles de cette façon:
GetFolder("Choisir un répertoire à traiter...")

Derrière il faudra que tu enregistre le résultat dans une variable de type String. DOnc en gros:
Code: Tout sélectionner
x = GetFolder("Choisir un répertoire à traiter...")
liryc
Chevalier Jedi SolidWorks
 
Messages: 479
Inscription: Ven 02 Mar 2007, 8:14
Localisation: Paris - SW2009 SP5.0

Re: Macro de composition a emporter

Messagepar Agadoudou » Mer 09 Jan 2013, 8:52

Merci Lyric !!!! Ça marche impeccable.

Donc l'utilisateur pourra bien sélectionner le répertoire de sauvegarde de la composition a emporter . En revanche, comment faire pour que ce soit le fichier ouvert actif dans solid qui soit copié ?

Code: Tout sélectionner
openFile = "C:\test\ensemble.sldasm"


Tout de suite il va m'ouvrir un ensemble en dure.

J'imagine que c'est avec des activedoc on doit s'en sortir mais je n'arrive pas a écrire les Dim et autres Set ....

Code: Tout sélectionner
Option Explicit

Dim swApp As SldWorks.SldWorks
Public Enum swDocumentTypes_e
    swDocNONE = 0       ' Used to be TYPE_NONE

    swDocPART = 1       ' Used to be TYPE_PART

    swDocASSEMBLY = 2   ' Used to be TYPE_ASSEMBLY

    swDocDRAWING = 3    ' Used to be TYPE_DRAWING
End Enum

Dim swDoc As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc


Dim swModelDoc As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swPackAndGo As SldWorks.PackAndGo

Dim openFile As String
Dim myFileName As String
Dim pgFileNames As Variant
Dim pgFileStatus As Variant
Dim pgSetFileNames() As String
Dim pgGetFileNames As Variant
Dim pgDocumentStatus As Variant
Dim status As Boolean
Dim warnings As Long
Dim errors As Long
Dim i As Long
Dim j As Long
Dim namesCount As Long
Dim myPath As String
Dim statuses As Variant


Sub Copie()

Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc

' Open assembly
'openFile = "C:\test\ensemble.sldasm"

openFile = swDraw

Set swModelDoc = swApp.OpenDoc6(openFile, swDocASSEMBLY, swOpenDocOptions_Silent, "", errors, warnings)
Set swModelDocExt = swModelDoc.Extension

' Get Pack and Go object
Debug.Print "Pack and Go"
Set swPackAndGo = swModelDocExt.GetPackAndGo


' Include any drawings
swPackAndGo.IncludeDrawings = True
Debug.Print "  Include drawings: " & swPackAndGo.IncludeDrawings



De plus, pour la composition a emporter il faut partir lu dessin d'ensemble afin que tous les ensembles, sous-ensemble et plans soient copiés. Là pour l'instant je ne part que du fichier ensemble.

Y'a t-il moyen de faire la copie que l'on parte de l'asm ou du drw ? Du coup, si l'utilisateur fais la copie a partir de l'asm, je lui afficherais que le plan d'ensemble de cet asm ne sera pas copié.
Merci à TOUS !!!!!
Agadoudou
Padawan SolidWorks
 
Messages: 84
Inscription: Ven 13 Avr 2012, 7:19
Localisation: Clermont Fd

Re: Macro de composition a emporter

Messagepar liryc » Mer 09 Jan 2013, 9:54

Tout est possible tout est réalisable, c'est le jeu de la vie :)
Donc oui c'est bien activedoc qu'il faut utiliser.
Tu supprimes donc dans ton code tout ce qui concerne l'ouverture d'un document et et contente de mettre:
Code: Tout sélectionner
Set swDoc = swApp.ActiveDoc

Et tu modifies la suite:
Code: Tout sélectionner
Set swModelDocExt = swDoc.Extension
...

Pour ta dernière question, tu peux rentrer dans ce mode de fonctionnement assez simplement en te basant sur l'extension.
A base If xxx then tu affiches soit des messages soit tu mets un terme à la macro ou tu reboucles au départ.
En partant du drw, tu devras passer cette ligne à False:
Code: Tout sélectionner
swPackAndGo.IncludeDrawings = True

Je n'ai pas le temps tout de suite de te modifier ton code et te le mettre à disposition mais si beosin d'aide je peux te faire ça dans l'après-midi je pense.
liryc
Chevalier Jedi SolidWorks
 
Messages: 479
Inscription: Ven 02 Mar 2007, 8:14
Localisation: Paris - SW2009 SP5.0

Re: Macro de composition a emporter

Messagepar liryc » Mer 09 Jan 2013, 15:39

Re,
Donc en gros voilà le code:
Code: Tout sélectionner
Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc
    If swDoc Is Nothing Then MsgBox ("Pas de document ouvert"): Exit Sub
    If swDoc.GetType = 1 Then MsgBox ("Ce programme ne fonctionne pas" & vbNewLine & "sur un fichier pièce"): Exit Sub
    If swDoc.GetType = 2 Then MsgBox ("La mise en plan de cet assemblage ne sera pas copiée")

Set swModelDocExt = swDoc.Extension

' Get Pack and Go object
Set swPackAndGo = swModelDocExt.GetPackAndGo


' Include any drawings
swPackAndGo.IncludeDrawings = False
Debug.Print "  Include drawings: " & swPackAndGo.IncludeDrawings

A tester et modifier suivant le besoin.
liryc
Chevalier Jedi SolidWorks
 
Messages: 479
Inscription: Ven 02 Mar 2007, 8:14
Localisation: Paris - SW2009 SP5.0

Re: Macro de composition a emporter

Messagepar Agadoudou » Mer 09 Jan 2013, 17:00

Nickel !!!! Tout marche bien. J'ai mis un userform pour que l'utilisateur revoi son chemin avant de valider et donc voilà le code ...

Code: Tout sélectionner
Option Explicit

Dim swApp As SldWorks.SldWorks
Public Enum swDocumentTypes_e
    swDocNONE = 0       ' Used to be TYPE_NONE

    swDocPART = 1       ' Used to be TYPE_PART

    swDocASSEMBLY = 2   ' Used to be TYPE_ASSEMBLY

    swDocDRAWING = 3    ' Used to be TYPE_DRAWING
End Enum

Dim swDoc As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swModelDoc As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swPackAndGo As SldWorks.PackAndGo
Dim myFileName As String
Dim pgFileNames As Variant
Dim pgFileStatus As Variant
Dim pgSetFileNames() As String
Dim pgGetFileNames As Variant
Dim pgDocumentStatus As Variant
Dim status As Boolean
Dim warnings As Long
Dim errors As Long
Dim i As Long
Dim j As Long
Dim namesCount As Long
Dim myPath As String
Dim statuses As Variant


Sub Copie()


Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc
    If swDoc Is Nothing Then MsgBox ("Pas de document ouvert"): Exit Sub
    If swDoc.GetType = 1 Then MsgBox ("Ce programme ne fonctionne pas" & vbNewLine & "sur un fichier pièce"): Exit Sub
    If swDoc.GetType = 2 Then MsgBox ("La mise en plan de cet assemblage ne sera pas copiée")

Set swModelDocExt = swDoc.Extension

' Get Pack and Go object
Set swPackAndGo = swModelDocExt.GetPackAndGo


' Inclure les plans
swPackAndGo.IncludeDrawings = True
Debug.Print "  Include drawings: " & swPackAndGo.IncludeDrawings

' Obtenez des chemins courant et de fichiers de documents de l'assemblage
status = swPackAndGo.GetDocumentNames(pgFileNames)

Debug.Print "  Chemin actuel et noms de fichier : "
If (Not (IsEmpty(pgFileNames))) Then
    For i = 0 To UBound(pgFileNames)
        Debug.Print "    Le chemin et le nom de fichier actuel sont : " & pgFileNames(i)
     
    Next i
End If

' Obtenez le chemin de sauvegarde courant à des chemins et noms de fichier des documents de l'assemblage

status = swPackAndGo.GetDocumentSaveToNames(pgFileNames, pgFileStatus)

Debug.Print "  Le chemin par défaut actuel : "
If (Not (IsEmpty(pgFileNames))) Then
    For i = 0 To UBound(pgFileNames)
        Debug.Print "   Le chemin et le nom de fichier actuel sont : " & pgFileNames(i)
           Next i
           End If


' Créez vos propres noms de fichiers pour les documents du modèle

ReDim pgSetFileNames(i)


UserForm1.Show

If Len(UserForm1.numeroaff.Text) <> 4 Then
MsgBox "Il doit y avoir 4 caractères"

UserForm1.Show

End If

'Emplacement de la coposition a emporter

myPath = UserForm1.TextBox1.Value
status = swPackAndGo.SetSaveToName(True, myPath)

' Définition des chemins et les noms de documents à emporter

status = swPackAndGo.SetDocumentSaveToNames(pgSetFileNames)

' Ajoutez un préfixe et un suffixe au nouveau fichiers
swPackAndGo.AddPrefix = UserForm1.numeroaff.Value & "-"
swPackAndGo.AddSuffix = ""

' Pack and Go
statuses = swModelDocExt.SavePackAndGo(swPackAndGo)


'Fermeture du document solidworks actif

'swApp.CloseDoc.swApp.ActiveDoc


End Sub


Juste si pouvais me dire comment fermer l'ensemble en cours sans l'enregistrer ... je n'y arrive pas, comme le prouve ma dernière ligne !!!

Encore Merci lyric !!!!
Merci à TOUS !!!!!
Agadoudou
Padawan SolidWorks
 
Messages: 84
Inscription: Ven 13 Avr 2012, 7:19
Localisation: Clermont Fd

Re: Macro de composition a emporter

Messagepar liryc » Mer 09 Jan 2013, 17:59

A la fin du code, remplace ça:
Code: Tout sélectionner
'Fermeture du document solidworks actif
'swApp.CloseDoc.swApp.ActiveDoc
End Sub

Par ça:
Code: Tout sélectionner
'Fermeture du document solidworks actif
MyPath = swDoc.GetPathName
swApp.CloseDoc MyPath
Set swDoc = Nothing: Set swApp = Nothing
End sub
liryc
Chevalier Jedi SolidWorks
 
Messages: 479
Inscription: Ven 02 Mar 2007, 8:14
Localisation: Paris - SW2009 SP5.0

Re: Macro de composition a emporter

Messagepar Agadoudou » Jeu 10 Jan 2013, 8:12

Merci encore !!!!

Du bon boulot !!!!
Merci à TOUS !!!!!
Agadoudou
Padawan SolidWorks
 
Messages: 84
Inscription: Ven 13 Avr 2012, 7:19
Localisation: Clermont Fd

Re: Macro de composition a emporter

Messagepar Agadoudou » Jeu 10 Jan 2013, 12:03

Une dernière question ...

Que faut-il rajouter comme bout de code en début de macro quand tu es sous excel, pour faire ouvrir un document solidworks ?

Code: Tout sélectionner
Private Sub CommandButton2_Click()
 


Dim swApp As Object
Dim Part As Object
Dim longstatus As Long, longwarnings As Long


Set swApp = Application.SldWorks


'ouvrir fichier

Dim Taille, Angle, Chemin

Taille = UserForm3.TextBox1.Value
Angle = UserForm3.TextBox2.Value
Chemin = "U:\BUREAU D'ETUDES\blablabla\N°2\" & Taille & "\" & Angle & "\" & Taille & "-" & Angle & "-Ensemble.sldasm"


Set Part = swApp.NewDocument(Chemin, 0, 0, 0)

Exit Sub

End Sub
Merci à TOUS !!!!!
Agadoudou
Padawan SolidWorks
 
Messages: 84
Inscription: Ven 13 Avr 2012, 7:19
Localisation: Clermont Fd

Re: Macro de composition a emporter

Messagepar liryc » Jeu 10 Jan 2013, 14:05

Code: Tout sélectionner
Set swapp = CreateObject("SldWorks.Application")

Et faut penser à activer les références solidworks dans excel:
- SldWorks XXXX Type Libray
- Solidworks XXXX Constant type library
- Solidworks XXXX Commands type library
liryc
Chevalier Jedi SolidWorks
 
Messages: 479
Inscription: Ven 02 Mar 2007, 8:14
Localisation: Paris - SW2009 SP5.0

Suivante

Retourner vers Questions générales sur les API

 


  • Articles en relation
    Réponses
    Vus
    Dernier message

Qui est en ligne

Utilisateurs parcourant ce forum: Aucun utilisateur enregistré et 3 invités

banniere