[VBA] Définir le nom d'un fichier .sldprt en fonction d'une cellule du fichier excel de la famille de pièces associée

tmauduit · Février 13, 2017, 8:14

Bonjour à tous,

Après plusieurs essais infructueux, je me décide à venir chercher un peu plus d'aide.

J'ai besoin de récupérer dans un fichier excel le contenu d'une cellule pour ensuite le définir en tant que nom de fichier.

Le but serait donc :

-Récupérer le contenu de la cellule,

-Le définir en tant que nom de fichier dans une boite de dialogue, et le laisser modifiable pour que l'utilisateur puisse interragir,

-Enregistrer sous : - soit dans un dossier défini par l'utilisateur,

-soit sur le bureau si trop compliqué.

Je vous mets mon bout de code confectionné à l'aide de différent tutos/codes récupérés à droite à gauche

Dim swApp As Object

Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long

Sub main()

Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Dim PartPath As String
Dim Pathsize As Long
Dim PathNoExtension As String
Dim NewFileName As String
Dim Workbooks As Integer

PartPath = Part.GetPathName
Pathsize = Strings.Len(PartPath)
PathNoExtension = Strings.Left(PartPath, Pathsize - 7)

'NewFileName = InputBox("Renseignez le nouveau nom récupéré dans excel", "Enregistrer une copie", NewFileName)
'If NewFileName = "" Then
NewFileName = Workbooks("DESIGNTABLE").WorkSheets("Feuil1").Cells(1, 9)

'End If

longstatus = Part.SaveAs2(NewFileName & ".sldprt", 0, 1, 0)
'swApp.CloseDoc PartPath 'closes old document
Set Part = swApp.OpenDoc6(NewFileName & ".sldprt", 1, 0, "", longstatus, longwarnings)

End Sub

gt22 · Février 13, 2017, 10:41

question quel est le nom de ta celulle excel ?

est ce que c'est une concarenation de x celulles ?

puisque tu veux que ce soit le nom d'un fichier part

@+ ;-)

tmauduit · Février 13, 2017, 10:45

J'ai changé le code, plus performant que celui actuel.

Sub ENREGISTRER() 'save as
Dim swApp As SldWorks.SldWorks
Dim SWmoddoc As SldWorks.ModelDoc2
Dim CODE As String
Dim nErrors As Long
Dim nWarnings As Long
Set swApp = Application.SldWorks
Set SWmoddoc = swApp.ActiveDoc

PathName = UCase(SWmoddoc.GetPathName)

If Right(PathName, 3) = "DRW" Then
    MesgBOX = MsgBox("Macro à lancer uniquement depuis une pièce ou un assemblage", vbMsgBoxSetForeground, "Enregistrer-sous")
    Exit Sub
    ElseIf Right(PathName, 3) = "PRT" Then
        DRWPath = Replace(PathName, "PRT", "DRW")
    ElseIf Right(PathName, 3) = "ASM" Then
        DRWPath = Replace(PathName, "ASM", "DRW")
End If

FilePath = Left(PathName, InStrRev(PathName, "\"))

FileName = Right(PathName, Len(PathName) - InStrRev(PathName, "\"))

RET = MsgBox("Avez vous bien copié le nom de la poulie dans Excel ?", vbOKCancel + vbExclamation + vbMsgBoxSetForeground + vbSystemModal, "Enregistrer-sous")

If RET = vbCancel Then End
Do

NewName = InputBox("Merci d'indiquer le nouveau nom récupéré dans Excel " & vbNewLine, "Enregistrer", libelleFR)

If StrPtr(NewName) = 0 Then
MsgBox "Procédure annulée"

Exit Sub
End If

Do While InStr(NewName, Chr(34)) > 0 Or InStr(NewName, "\") > 0 Or InStr(NewName, "/") > 0 _
Or InStr(NewName, ":") > 0 Or InStr(NewName, "*") > 0 Or InStr(NewName, "?") > 0 Or InStr(NewName, "<") > 0 Or InStr(NewName, ">") > 0 Or InStr(NewName, "|") > 0

        NewName = InputBox("Attention, le nom contient au moins un des caractère interdits \/:*?""<>|" & vbNewLine & vbNewLine & _
        "Merci d'indiquer le nouveau nom : ", "Enregistrer-sous", NewName)
    Loop

Loop While NewName = ""

Do
    FilePath = InputBox("Dans quel dossier voulez vous enregistrer la poulie ?", "Enregistrer-sous", FilePath)
    If StrPtr(FilePath) = 0 Then
        MsgBox "Procédure annulée"
        Exit Sub
    End If
    If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"

    If Dir$(FilePath) <> "" Then
        EXISTE = 1
    Else: MsgBox "Le répertoire n'existe pas, merci de le créer"
    Debug.Print Dir$(FilePath)
    End If

Loop While EXISTE <> 1

Set swModel = swApp.ActivateDoc2(PathName, False, nErrors)

If (SWmoddoc.GetType = swDocASSEMBLY) Then

SWmoddoc.SaveAs (FilePath + NewCode + NewName + ".SLDASM")
ElseIf (SWmoddoc.GetType = swDocPART) Then

SWmoddoc.SaveAs (FilePath + NewName + ".SLDPRT")
End If

End Sub

Ma cellule n'a pas de nom particulier. Elle récupère simplement des infos du tableur en rajoutant des lettres pour identifier les paramètres récupérés dans le tableur. Le nom du fichier ressemble à ça :

TXXXXX_PD_XXXX - P_M8_C2_R

Les paramètres récupérés (et donc variables) sont : 8, 2 et R, tout le reste est invariable.

Merci pour ta réponse :)

gt22 · Février 13, 2017, 11:12

voir ce lien

https://forum.excel-pratique.com/excel/creation-de-dossier-a-partir-de-valeur-de-cellule-t69912.html

http://www.commentcamarche.net/forum/affich-32704381-creation-dossier-par-rapport-a-une-valeur-cellule-excel?page=2

https://www.developpez.net/forums/d1549758/logiciels/microsoft-office/excel/creation-dossier-excel-partir-d-cellule/

tuto pour la creation de dossier

http://warin.developpez.com/access/fichiers/

pas teste a voir

@+ ;-)

tmauduit · Février 13, 2017, 12:40

J'ai regardé en détail ce que tu avais posté, mais ça ne correspond pas vraiment à ma demande, tout ce que je voudrais c'est juste de récupérer une info dans une cellule, pour ensuite l'afficher dans une boîte de dialogue avant l'enregistrement du fichier. Le dossier dans lequel la pièce ira est déjà créé.

Cyril.f · Février 13, 2017, 1:23

Bonjour,

Je ne comprends pas bien la demande. Le fichier excel dans lequel tu tapes, c'est une sélection par l'utilisateur qui devient le nom d'enregistrement ou c'est une cellule fixe dans laquelle tu vas chercher l'information?

tmauduit · Février 13, 2017, 2:18

@Cyril.f

Ma cellule est une concaténation de certaines infos de mon tableur et de texte. Elle est toujours au même endroit car une seule feuille, et un seul fichier excel.

yvest · Février 13, 2017, 4:14

Bonjour,

Bien que j'ai du mal à comprendre l'utilité si vous passez par une famille de pièce qui vous créé des configurations différentes, vous trouverez le code qui corespond à ce que j'ai compris de votre question :)

Soit :

Ouvrir un classeur excel depuis solidworks
Récupérer la valeur d'une cellule
Renomer un fichier (avec ou sans l'ancien nom)
Enregistrer une copie avec le nouveau nom

J'ai rajouté une boite de dialogue pour rechercher le classeur excel.

Le code :

'Penser à ajouter les références Microsoft excel et Office

Dim swApp As SldWorks.SldWorks
Dim xlApp As Excel.Application
Dim swDoc As ModelDoc2
Dim fDialog As Office.FileDialog
Dim xlDoc As Excel.Workbook
Dim xlCell As Excel.Range
Dim DocName, NewName, Folder, NewPath As String
Dim fso As Object

Sub main()

Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc
Set xlApp = New Excel.Application
Set fDialog = xlApp.FileDialog(msoFileDialogOpen)
'On peux rajouter des options à fDialog pour filtrer ou n'ouvrir qu'un document
If fDialog.Show = -1 Then
Set xlDoc = xlApp.Workbooks.Open(fDialog.SelectedItems(1))
Set xlCell = xlDoc.Worksheets(1).Range("A1")
'Je créé un objet fso pour manipuler facilement des fichiers
Set fso = CreateObject("Scripting.fileSystemObject")

DocName = swDoc.GetPathName
NewName = fso.GetBaseName(DocName) & " " & xlCell.Value
'Je recréé le nouveau nom du fichier à partir de l'ancien
NewPath = fso.GetParentFolderName(DocName) & "\" & NewName & "." & fso.getextensionName(DocName)
'j'enregistre
f = swDoc.SaveAs(NewPath)

End If

'On pense à détruire ce qui ne sert plus

Set fso = Nothing
Set xlApp = Nothing
End Sub

Amusez vous bien :)

gt22 · Février 13, 2017, 6:35

tmauduit

J'ai regardé en détail ce que tu avais posté, mais ça ne correspond pas vraiment à ma demande, tout ce que je voudrais c'est juste de récupérer une info dans une cellule, pour ensuite l'afficher dans une boîte de dialogue avant l'enregistrement du fichier. Le dossier dans lequel la pièce ira est déjà créé.

la question est

'ai besoin de récupérer dans un fichier excel le contenu d'une cellule pour ensuite le définir en tant que nom de fichier.

Le but serait donc :

-Récupérer le contenu de la cellule,

-Le définir en tant que nom de fichier dans une boite de dialogue, et le laisser modifiable pour que l'utilisateur puisse interragir,

donc dans les liens la reponse y est ;-(

maintenant tu veux changer le nom d'un fichier deja creer ??????????????????????????

faut peut etre savoir ce que tu veux !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

@+;-( version pas ravi du tout ;-(

ps en + pour quel utilite ????????????

tmauduit · Février 14, 2017, 8:19

@gt22, je récupère le nom dans la cellule, et l'injecte en tant que nouveau nom pour un enregistrer-sous- dans un dossier existant.

@industrialcadservice Je regarde ça !

Merci pour vos réponses :)

tmauduit · Février 14, 2017, 10:08

Bon, petite modification en utilisant les smartproperties : je définis mon TITRE3 grâce à Excel, puis le récupère ensuite par la macro, mais toujours un soucis, plus du côté solidworks, en effet,les smart properties sont liées soit au document, soit à la configuration, et mon titre 3 change dans la configuration, mais pas dans le document, et c'est celui du document que je récupère, et non pas celui de la configuration... Quelqu'un saurait ou est le loup ?

Bout de code ci après

Set SWmoddoc = swApp.ActiveDoc

PathName = UCase(SWmoddoc.GetPathName)

If Right(PathName, 3) = "DRW" Then
    MesgBOX = MsgBox("Macro à lancer uniquement depuis une pièce ou un assemblage", vbMsgBoxSetForeground, "Enregistrer-sous")
    Exit Sub
    ElseIf Right(PathName, 3) = "PRT" Then
        DRWPath = Replace(PathName, "PRT", "DRW")
    ElseIf Right(PathName, 3) = "ASM" Then
        DRWPath = Replace(PathName, "ASM", "DRW")
End If

FilePath = Left(PathName, InStrRev(PathName, "\"))

FileName = Right(PathName, Len(PathName) - InStrRev(PathName, "\"))

RET = MsgBox("Avez vous bien copié le nom de la poulie/du tambour dans Excel ?", vbOKCancel + vbExclamation + vbMsgBoxSetForeground + vbSystemModal, "Enregistrer-sous")

If RET = vbCancel Then End
Do

'on recupere le TITRE 3
NewName = SWmoddoc.CustomInfo("TITRE3")

'On l'affiche
RET = MsgBox(NewName, vbMsgBoxSetForeground)
'NewName = InputBox("Merci d'indiquer le nouveau nom récupéré dans Excel " & vbNewLine, "Enregistrer", libelleFR)

'If StrPtr(NewName) = 0 Then
'MsgBox "Procédure annulée"

'Exit Sub
'End If

Merci d'avance

yvest · Février 14, 2017, 11:13

Bonjour,

je ne suis pas devant mon pc mais je présume que sw récupère la propriété de la configuration active. Avez vous essayé votre macro avec une configuration différente?

Sinon, pouvez vous nous expliquer le but de telles manip? Parce que personnellement, je n'en vois pas l'intérêt...

tmauduit · Février 14, 2017, 1:13

J'ai effectivement essayé avec une autre configuration,mais le résultat est le même, le changement de titre ne se fait que du côté excel et de la configuration, et pas dans le fichier .prt en lui même

L'intérêt est que tout cela soit câché à l'utilisateur final : il paramètre, lance la macro, et valide ou pas le nom. je fournis juste un excel avec ses paramètre à rentrer. La création de la référence n'apparait à aucun moment dans excel pour l'utilisateur.

tmauduit · Février 15, 2017, 10:58

Sub ENREGISTRER() 'save as
Dim swApp As SldWorks.SldWorks
Dim Part As SldWorks.ModelDoc
Dim CODE As String
Dim nErrors As Long
Dim nWarnings As Long

Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc

PathName = UCase(Part.GetPathName)

If Right(PathName, 3) = "DRW" Then
    MesgBOX = MsgBox("Macro à lancer uniquement depuis une pièce ou un assemblage", vbMsgBoxSetForeground, "Enregistrer-sous")
    Exit Sub
    ElseIf Right(PathName, 3) = "PRT" Then
        DRWPath = Replace(PathName, "PRT", "DRW")
    ElseIf Right(PathName, 3) = "ASM" Then
        DRWPath = Replace(PathName, "ASM", "DRW")
End If

FilePath = Left(PathName, InStrRev(PathName, "\"))

FileName = Right(PathName, Len(PathName) - InStrRev(PathName, "\"))

RET = MsgBox("Avez vous terminé le paramétrage de votre pièce ?", vbOKCancel + vbExclamation + vbMsgBoxSetForeground + vbSystemModal, "Enregistrer-sous")

If RET = vbCancel Then End
Do
    'on récupère le TITRE3
    NewName = Part.CustomInfo("TITRE3")
    'on l'affiche
    'RET = MsgBox(NewName, vbMsgBoxSetForeground)
    NewName = InputBox("Validez ou modifiez le nom de la pièce" & vbNewLine & vbNewLine, "Définition du nom", NewName)

If StrPtr(NewName) = 0 Then
MsgBox "Procédure annulée"

Exit Sub
End If

Do While InStr(NewName, Chr(34)) > 0 Or InStr(NewName, "\") > 0 Or InStr(NewName, "/") > 0 _
Or InStr(NewName, ":") > 0 Or InStr(NewName, "*") > 0 Or InStr(NewName, "?") > 0 Or InStr(NewName, "<") > 0 Or InStr(NewName, ">") > 0 Or InStr(NewName, "|") > 0

        NewName = InputBox("Attention, le nom contient au moins un des caractère interdits \/:*?""<>|" & vbNewLine & vbNewLine & _
        "Merci d'indiquer le nouveau nom : ", "Enregistrer-sous", NewName)
    Loop

Loop While NewName = ""

Do
    FilePath = InputBox("Dans quel dossier voulez vous enregistrer la pièce ?", "Enregistrer-sous", FilePath)
    If StrPtr(FilePath) = 0 Then
        MsgBox "Procédure annulée"
        Exit Sub
    End If
    If Right(FilePath, 1) <> "\" Then FilePath = FilePath & "\"

    If Dir$(FilePath) <> "" Then
        EXISTE = 1
    Else: MsgBox "Le répertoire n'existe pas, merci de le créer"
    Debug.Print Dir$(FilePath)
    End If

Loop While EXISTE <> 1

Set swModel = swApp.ActivateDoc2(PathName, False, nErrors)

If (Part.GetType = swDocASSEMBLY) Then

Part.SaveAs (FilePath + NewName + ".SLDASM")
ElseIf (Part.GetType = swDocPART) Then

Part.SaveAs (FilePath + NewName + ".SLDPRT")
End If

End Sub

Le problème du côté VBA est pour moi résolu, j'ouvre un autre topic pour le soucis avec Smart Properties