Hello,
I am currently on solidworks 2024.
I created a macro that checks my indices and I would like it to add a row to the revision table, does anyone know in VBA add a row to the revision table? I can't find anything on the subject.
Regards
Look at this code that index species and also adds a revision to a table.
See AddRevision function at the bottom of the code
Not too much time to sort, I'll put all my code for you, even if only a small part concerns you.
Option Explicit
'Maj 2023-06-12 voir commentaire
'Maj 2022-10-25 voir commentaire
'Ajouter la référence à MicrosoftXML v3.0
' Ajout déclaration pour vérif type de documents
Global Const nomfichierXML = "SaveMacroIndice.xml"
Global sPathXML, sPathNameXML As String
Global FileTyp As Long
Global Source As String
Global FichierXml As String
Dim swApp As Object
Dim swModel As SldWorks.ModelDoc2
Dim swPart As SldWorks.PartDoc
Dim swAssembly As SldWorks.AssemblyDoc
Dim Designation As String
Dim Compteur As String
Dim OldIndice As String
Global Indice As String
Dim Filename As String
Dim Filepath As String
Dim File As String
Dim Extension As String
Dim path As String
Dim fso As Object
Dim bRet As Boolean
Dim PathMep As String
Dim swCustProp As CustomPropertyManager
Dim swDocType As Variant
Dim fileerror As Long
Dim filewarning As Long
Dim doc As SldWorks.ModelDoc2
Sub main()
Set swApp = Application.SldWorks
sPathXML = Environ("USERPROFILE") & "\.SaveMacroSldworks\"
sPathNameXML = sPathXML & nomfichierXML
'Debug.Print sPathXML & nomfichierXML
'On vérifie si le dossier de sauvegarde existe sinon crétion de ce dossier
If Dir(sPathXML, vbDirectory + vbHidden) = "" Then
'Debug.Print "Création du dossier: " & sPathXML
MkDir sPathXML
End If
FichierXml = sPathXML & nomfichierXML
'Debug.Print "Fichier xml:" & FichierXml
' on affiche le useforms
UserformOptionsMacro.Show
End Sub
'------------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------------
Sub execute()
'---------------
'0-°) On vérifie si la pièce ou assemblage est en lecture seule-> remise en écriture
'On récupère le nom de la pièce ou de l'assemblage ainsi que la propriété Indice et la propriété designation
'Vérification du type de document d'ouvert
Set swApp = CreateObject("SldWorks.Application")
Set swModel = swApp.ActiveDoc 'On récupère le modèle d'ouvert
If swModel Is Nothing Then '// Vérification si un document est ouvert
MsgBox "Pas de document d'ouvert." + Chr$(13) + _
"Une pièce ou un assemblage SolidWorks doit être ouverte, " + Chr$(13) + _
"avant de relancer cette macro."
Else '// Vérification si un document est ouvert
FileTyp = swModel.GetType
If FileTyp = swDocPART Or FileTyp = swDocASSEMBLY Then '// Si le document n'est pas une MEP (swDocDRAWING)
'Vérification lecture seule (Nouvelle méthode à vérifier)
'If swModel.IsOpenedReadOnly Then
'Debug.Print "Read Only status actived"
'Else
'Debug.Print "Not actived"
'End If
'Fin vérification lecture seule (Nouvelle méthode à vérifier)
readProperties
'Debug.Print " Propriétées:"
'Debug.Print " Designation:" & Designation
'Debug.Print " Compteur:" & Compteur
'Debug.Print " Indice:" & Indice
'On récupère le chemin de la pièce ou de l'assemblage
recupInfoChemin
'On vérifie si le fichier est en lecture seule
verificationLectureSeule
'On vérifie si le fichier est accessible (Pas ouvert par une autre personne)
'Vérification lecture seule (Nouvelle méthode à vérifier)
If swModel.IsOpenedReadOnly Then
MsgBox "Le fichier n'est pas accessible en écriture, l'indiçage est impossible sans accès en écriture."
Exit Sub
End If
'Fin vérification lecture seule (Nouvelle méthode à vérifier)
'On incrémente l'indice et on copie le plan
incrementationIndicePlan
'--------------------------
'1-°) Cacher l'ancienne MEP
'--------------------------
' ********** Code pour changement caché le plan *********
If UserformOptionsMacro.CheckBoxCacherPlan.Value <> 0 Then
'Debug.Print "On cache le plan de la pièce ou de l'assemblage"
'Code pour cacher le plan de la pièce ou de l'assemblage
cacheMEP
Else
'Debug.Print "On ne cache pas le plan de la pièce ou de l'assemblage"
End If
'On charge l'ancienne pièce ou assemblage
openOld
'------------------------------------------
'2-°) Cacher l'ancienne pièce ou assemblage
'------------------------------------------
' ********** Code pour changement cacher l'ancienne pièce ou assemblage *********
If UserformOptionsMacro.CheckBoxCacherPièce.Value <> 0 Then
'Debug.Print "On cache l'ancienne pièce ou assemblage"
'Code pour cacher l'ancienne pièce ou assemblage
cachePartAsm
Else
'Debug.Print "On ne cache pas l'ancienne pièce ou assemblage"
End If
'-----------------------------------------------------------------------------
'3-°) On change l'ancienne désignation (Remplacée par + désignation existante)
'-----------------------------------------------------------------------------
' ********** Code pour changement de désignation de la pièce ou assemblage *********
If UserformOptionsMacro.CheckBoxDesignation.Value <> 0 Then
'Debug.Print "On modifie la désignation de la pièce ou de l'assemblage"
'Code pour modifier la couleur de la pièce ou de l'assemblage
modifdesignation
Else
'Debug.Print "On ne modifie pas la désignation de la pièce ou de l'assemblage"
End If
'-----------------------------------------------------------
'4-°) On change la couleur de l'ancienne pièce ou assemblage (OBSOLETE -> Ne seaa pas appliqué fonction supprimé)
'-----------------------------------------------------------
' ********** Code pour changement de couleur de la pièce ou assemblage *********
If UserformOptionsMacro.CheckBoxCouleur.Value <> 0 Then
'Debug.Print "On modifie la couleur de la pièce ou de l'assemblage"
'Code pour modifier la couleur de la pièce ou de l'assemblage
couleurModif
Else
'Debug.Print "On ne modifie pas la couleur de la pièce ou de l'assemblage"
End If
'on sauvegarde l'ancienn pièce avec ses modifications:
saveOld
'-----------------------------------------------------------
'5-°) On met l'ancienne pièce ou l'assemblage en lecture seule
'-----------------------------------------------------------
' ********** Code pour mettre l'ancienne pièce ou l'assemblage en lecture seule *********
If UserformOptionsMacro.CheckBoxLectureSeule.Value <> 0 Then
'Debug.Print "On met la pièce ou l'assemblage en lecture seule"
'Code pour mettre l'ancienne pièce ou l'assemblage en lecture seule
readOnlyOld
Else
'Debug.Print "On ne met pas la pièce ou l'assemblage en lecture seule"
End If
'----------------------------------------------------------
'6-°) On ajoute une table de révision ou on ajoute une ligne
'-----------------------------------------------------------
If UserformOptionsMacro.CheckBoxRevision.Value <> 0 Then
'Debug.Print "On ajoute une table de révision ou on ajoute une ligne"
Call tableRevision
End If
'-----------------------------
'0-°) Reprise fin de condition
'-----------------------------
Else '// Si le document n'est pas une MEP (swDocDRAWING)
MsgBox "Pas de pièce ou d'assemblage d'ouvert." + Chr$(13) + _
"Une pièce ou un assemblage doit être ouvert, " + Chr$(13) + _
"avant de relancer cette macro."
End If '// Si le document n'est pas une MEP (swDocDRAWING)
End
End If '// Vérification si un document est ouvert
End Sub
Sub CreationCompleteXML() 'Création du fichier xml de sauvegardes des paramètres du menu options
Dim oXML As Object
Dim oNode As Object
Dim root As Object
Dim elem As Object
Dim rel As Object
Set oXML = New MSXML2.DOMDocument
Set oNode = oXML.createProcessingInstruction("xml", "version=""1.0"" encoding=""ISO-8859-1""")
oXML.appendChild oNode
With oXML.appendChild(oXML.createElement("OPTIONS"))
.appendChild oXML.createTextNode(vbCrLf)
.appendChild oXML.createTextNode(vbTab)
With .appendChild(oXML.createElement("CheckBoxLectureSeule"))
.Text = IIf(UserformOptionsMacro.CheckBoxLectureSeule.Value = 0, "False", "True")
End With
.appendChild oXML.createTextNode(vbCrLf)
.appendChild oXML.createTextNode(vbCrLf)
.appendChild oXML.createTextNode(vbTab)
With .appendChild(oXML.createElement("CheckBoxCacherPièce"))
.Text = IIf(UserformOptionsMacro.CheckBoxCacherPièce.Value = 0, "False", "True")
End With
.appendChild oXML.createTextNode(vbCrLf)
.appendChild oXML.createTextNode(vbTab)
With .appendChild(oXML.createElement("CheckBoxCacherPlan"))
.Text = IIf(UserformOptionsMacro.CheckBoxCacherPlan.Value = 0, "False", "True")
End With
.appendChild oXML.createTextNode(vbCrLf)
.appendChild oXML.createTextNode(vbTab)
With .appendChild(oXML.createElement("CheckBoxDesignation"))
.Text = IIf(UserformOptionsMacro.CheckBoxDesignation.Value = 0, "False", "True")
End With
.appendChild oXML.createTextNode(vbCrLf)
.appendChild oXML.createTextNode(vbTab)
With .appendChild(oXML.createElement("CheckBoxCouleur"))
'On modifie les 2 paramètres à False (Fonction obsolètes)
.Text = IIf(UserformOptionsMacro.CheckBoxCouleur.Value = 0, "False", "False")
End With
.appendChild oXML.createTextNode(vbCrLf)
.appendChild oXML.createTextNode(vbTab)
With .appendChild(oXML.createElement("CheckBoxRevision"))
.Text = IIf(UserformOptionsMacro.CheckBoxRevision.Value = 0, "False", "True")
End With
.appendChild oXML.createTextNode(vbCrLf)
End With
oXML.Save FichierXml
End Sub
Function readProperties()
Set swModel = swApp.ActiveDoc
Designation = swModel.GetCustomInfoValue("", "Designation")
Compteur = swModel.GetCustomInfoValue("", "Compteur")
Indice = swModel.GetCustomInfoValue("", "Indice")
End Function
Function recupInfoChemin()
'Debug.Print " Fonction recupInfoChemin lancé"
'on récupère le chemin complet
'Debug.Print " Info chemin pièces ou ASM"
File = swModel.GetPathName
'Debug.Print " File:" + File
'on récupère le chemin complet sans le nom de fichier
Filepath = Left(File, InStrRev(File, "\"))
'Debug.Print " Filepath:" + Filepath
'on récupère le nom du fichier sans l'extension
Filename = Mid(File, Len(Filepath) + 1, Len(File) - (7 + Len(Filepath)))
'Debug.Print " FileName:" + Filename
'on récupère l'extension
Extension = Right(File, 7)
'Debug.Print " Extension:" + Extension
End Function
Function verificationLectureSeule()
'Debug.Print " Function verificationLectureSeule lancé"
'Debug.Print on vérifie si la pièce est en lecture seule
Dim PathName As String
Dim ret As Boolean
'Si le fichier est en lecture seule
If GetAttr(File) And vbReadOnly Then
'Debug.Print " Le fichier est en lecture seule"
SetAttr File, vbNormal
swModel.FileReload
ret = swModel.ReloadOrReplace(False, swModel.GetPathName, True)
swModel.FileReload
'On recharge le document dans SolidWorks
'On modifie par défaut le pasage de l'ancienne pièce ou assemblage à mettre en lecture seule
UserformOptionsMacro.CheckBoxLectureSeule.Value = 1
Else
End If
End Function
Function incrementationIndicePlan()
'Debug.Print " Function incrementationIndicePlan lancé"
'on vérifie si un indice est existant et on sauvegarde l'ancien
OldIndice = Indice
'Debug.Print "OldIndice:" & OldIndice
'Maj 2023-06-12 Si Indice = " " on force l'Indice pour avoir la valeur A
If Indice = "" Or Indice = " " Then
Indice = "A"
'Debug.Print "Indice non existant- Indice passe à:" + Indice
'Debug.Print "OldIndice:" & OldIndice
Else
Indice = Chr$(Asc(Indice) + 1)
'Debug.Print "Indice:" + Indice
'Debug.Print "OldIndice:" & OldIndice
End If
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
path = Filepath + Compteur + Indice + Extension
'Debug.Print "Path:"; path
'On vérifie que l'indice que l'on veux créer n'existe pas déjà
If Dir(path) <> "" Then
MsgBox "Le fichier " & path & " existe déjà. Création de cet Indice refusé."
End
End If
'on modifie les propriétées Indice et Nom_Fichier
Set swCustProp = swModel.Extension.CustomPropertyManager("")
bRet = swCustProp.Add3("Indice", swCustomInfoType_e.swCustomInfoText, Indice, swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd)
'Debug.Print "Propriété Indice:" & Indice
bRet = swCustProp.Add3("Nom_Fichier", swCustomInfoType_e.swCustomInfoText, Compteur + Indice, swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd)
'Debug.Print "Propriété Nom_Fichier:" & Compteur + Indice
'On enregistre la nouvelle pièce ou assemblage
swModel.SaveAs3 "" & path & "", 0, 0
'On vérifie l'existance de la MEP associé
PathMep = Filepath + Compteur
'Debug.Print Filepath + Compteur & OldIndice; ".SLDDRW"
If Dir(PathMep & OldIndice & ".SLDDRW") <> "" Then
Call fso.CopyFile(PathMep & OldIndice & ".SLDDRW", PathMep & Indice & ".SLDDRW")
Set swApp = Application.SldWorks
'On change la référence du nouveau plan par la pièce ou assemblage avec le nouvel Indice
Call swApp.ReplaceReferencedDocument(PathMep & Indice & ".SLDDRW", PathMep & OldIndice & Extension, PathMep & Indice & Extension)
Else
'Debug.Print "Pas de Mep"
End If
End Function
Function cachePartAsm()
'Debug.Print " Fonction cachePartAsm lancé"
If FileTyp = 1 Then
SetAttr PathMep & OldIndice & ".SLDPRT", vbHidden
'Debug.Print PathMep & OldIndice & ".SLDPRT" & "Attribut: " & GetAttr(PathMep & OldIndice & ".SLDPRT")
Else
SetAttr PathMep & OldIndice & ".SLDASM", vbHidden
'Debug.Print PathMep & OldIndice & ".SLDASM" & "Attribut: " & GetAttr(PathMep & OldIndice & ".SLDASM")
End If
End Function
Function cacheMEP()
'Debug.Print " Fonction cacheMEP lancé"
'On change l'attribut de la vielle MEP en caché si la MEP existe
If Dir(PathMep & OldIndice & ".SLDDRW") <> "" Then
SetAttr PathMep & OldIndice & ".SLDDRW", vbHidden
Else
'Debug.Print "Pas de Mep"
End If
End Function
Function modifdesignation()
'Debug.Print " Fonction modifdesignation lancé"
'On change la designation en ajoutant /* Remplacé par */
swModel.SummaryInfo(swSumInfoTitle) = "/*Remplacé par:" & Compteur & Indice & "*/" & Designation
Set swCustProp = swModel.Extension.CustomPropertyManager("")
bRet = swCustProp.Add3("Designation", swCustomInfoType_e.swCustomInfoText, "/*Remplacé par:" & Compteur & Indice & "*/" & Designation, swCustomPropertyAddOption_e.swCustomPropertyDeleteAndAdd)
'On change également le Titre
swModel.SummaryInfo(swSumInfoTitle) = "/*Remplacé par:" & Compteur & Indice & "*/" & Designation
'On supprime la propriété Désignation pour chaque configuration
Dim V As Variant
V = swApp.GetConfigurationNames(path)
Dim i As Long
For i = 0 To UBound(V)
'Debug.Print "Nom de configuration:" & V(i) & "-N°:" & i
bRet = swModel.DeleteCustomInfo2(V(i), "Designation")
Next i
End Function
Function couleurModif()
'On applique le changement de couleur pour chaque configuration
Dim V As Variant
' Get the names of these configurations
V = swApp.GetConfigurationNames(path)
Dim i As Long
For i = 0 To UBound(V)
'On sauvegarde la configuration active
If i = 0 Then
Dim ConfigActive As String
ConfigActive = V(i)
End If
'Debug.Print "Nom de configuration:" & V(i) & "-N°:" & i
'Si c'est une pièce
If FileTyp = 1 Then
'Debug.Print "Changement de couleur de la pièce"
Dim swPart As SldWorks.PartDoc
Dim vMatProps As Variant
'Changement de configuration
swModel.ShowConfiguration2 (V(i))
Set swPart = swModel
vMatProps = swPart.MaterialPropertyValues
vMatProps(0) = 0
vMatProps(1) = 0.501960784313725
vMatProps(2) = 0
swPart.MaterialPropertyValues = vMatProps
'Si c'est un assemblage
Else
'Debug.Print "Changement de couleur de l'assemblage"
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swAppearance As SldWorks.RenderMaterial
Dim vMat(8) As Double
Dim nDecalID As Long
Set swModelDocExt = swModel.Extension
swModel.ShowConfiguration2 (V(i))
Set swAssembly = swModel
vMat(0) = 0 * 255#
vMat(1) = 128 * 255#
vMat(2) = 0 * 255#
vMat(3) = 1
vMat(4) = 1
vMat(5) = 0.5
vMat(6) = 0.4
vMat(7) = 0
vMat(8) = 0
Set swAppearance = swModelDocExt.CreateRenderMaterial("U:\Entreprise\Service BE\1-Commun service\Solidworks\Macros\Améliorations\Fichiers en lien avec macro\indice-abc.p2m")
bRet = swAppearance.AddEntity(swModel)
bRet = swModelDocExt.AddRenderMaterial(swAppearance, nDecalID)
swModel.MaterialPropertyValues = vMat
swModel.GraphicsRedraw2
Call swModel.Rebuild(swRebuildAll)
End If
Next
End Function
Function saveOld()
'On sauvegarde la vielle pièce ou assemblage avec sa couleur
Dim ssWarnings As Long
Dim ssErrors As Long
On Error Resume Next
'If swModel Is Nothing Or swApp Is Nothing Then GoTo ExitStrategy
swModel.Save3 13, ssErrors, ssWarnings '13 = swSaveAsOptions_Silent + swSaveAsOptions_AvoidRebuildOnSave + swSaveAsOptions_SaveReferenced
'Debug.Print "Sauvegarde réalisée"
'On ferme la pièce ou assemblage
Dim swModelTitle As String
swModelTitle = swModel.GetTitle
swApp.CloseDoc swModelTitle
'Debug.Print "on est sorti de la pièce"
End Function
Function openOld()
Set swModel = swApp.OpenDoc6(PathMep & OldIndice & Extension, FileTyp, swOpenDocOptions_Silent, "", fileerror, filewarning)
End Function
Function readOnlyOld()
'On modifie l'attribut (readonly), pièce ou assemblage avec l'ancien indice:
If FileTyp = 1 Then
If GetAttr(PathMep & OldIndice & ".SLDPRT") = vbHidden Then
SetAttr PathMep & OldIndice & ".SLDPRT", vbReadOnly + vbHidden
'Debug.Print PathMep & OldIndice & ".SLDPRT" & "Attribut: " & GetAttr(PathMep & OldIndice & ".SLDPRT")
Else
SetAttr PathMep & OldIndice & ".SLDPRT", vbReadOnly
'Debug.Print PathMep & OldIndice & ".SLDPRT" & "Attribut: " & GetAttr(PathMep & OldIndice & ".SLDPRT")
End If
Else
'Debug.Print PathMep & OldIndice & ".SLDASM" & "Attribut: " & GetAttr(PathMep & OldIndice & ".SLDASM")
If GetAttr(PathMep & OldIndice & ".SLDASM") Then
SetAttr PathMep & OldIndice & ".SLDASM", vbReadOnly + vbHidden
'Debug.Print PathMep & OldIndice & ".SLDASM" & "Attribut: " & GetAttr(PathMep & OldIndice & ".SLDASM")
Else
SetAttr PathMep & OldIndice & ".SLDASM", vbReadOnly
'Debug.Print PathMep & OldIndice & ".SLDASM" & "Attribut: " & GetAttr(PathMep & OldIndice & ".SLDASM")
End If
End If
End Function
Sub tableRevision()
Const TABLE_TEMPLATE As String = "U:\Entreprise\Service BE\1-Commun service\Solidworks\SOLIDWORKS Data 2020\lang\french\standard revision block.sldrevtbt"
Dim swApp As SldWorks.SldWorks
Dim swModel As SldWorks.ModelDoc2
Dim swDraw As SldWorks.DrawingDoc
Dim swSheet As SldWorks.Sheet
Dim vViews As Variant
Dim swView As SldWorks.View
Dim swAnn As SldWorks.Annotation
Dim swRevTable As SldWorks.RevisionTableAnnotation
Dim i As Integer
Dim UserName As String
Dim DescriptionRev As String
Dim fileerror As Long
Dim filewarning As Long
Dim sName As String
Dim longstatus As Long, longwarnings As Long
Dim swDocSpecification As SldWorks.DocumentSpecification
'Indice = "B"
'Debug.Print "Indice:" & Indice
Set swApp = Application.SldWorks
'Debug.Print "Chemin MEP:" & PathMep & Indice & ".slddrw"
Set swDocSpecification = swApp.GetOpenDocSpec(PathMep & Indice & ".slddrw")
sName = swDocSpecification.Filename
swDocSpecification.DocumentType = swDocDRAWING
swDocSpecification.ReadOnly = False
swDocSpecification.Silent = False
Set swModel = swApp.OpenDoc7(swDocSpecification)
longstatus = swDocSpecification.Error
longwarnings = swDocSpecification.Warning
'Set swModel = swApp.ActiveDoc
Set swDraw = swModel
If Not swDraw Is Nothing Then
'***Maj 2022-10-25
Dim vSheetNames As Variant
Dim vSheetProps As Variant
vSheetNames = swDraw.GetSheetNames
'Debug.Print vSheetName
bRet = swDraw.ActivateSheet(vSheetNames(0)): Debug.Assert bRet
Set swSheet = swDraw.GetCurrentSheet
'On récupère la largeur/hauteur de la feuille:
vSheetProps = swSheet.GetProperties
'Debug.Print " Width = " & vSheetProps(5)
'Debug.Print " Height = " & vSheetProps(6)
'***Fin Maj 2022-10-25
Set swSheet = swDraw.GetCurrentSheet
Set swRevTable = swSheet.RevisionTable
If swRevTable Is Nothing Then
'On ajoute une table de révision
'Debug.Print "Pas de table de révision existante-> création"
'***Maj 2022-10-25
'Set swRevTable = swSheet.InsertRevisionTable(True, Empty, Empty, swBOMConfigurationAnchor_TopRight, TABLE_TEMPLATE)
Set swRevTable = swSheet.InsertRevisionTable(False, vSheetProps(5) - 0.01, vSheetProps(6) - 0.01, swBOMConfigurationAnchor_TopRight, TABLE_TEMPLATE)
'***Fin Maj 2022-10-25
If swRevTable Is Nothing Then
swApp.SendMsgToUser "L'insertion de la table à échoué."
End
End If
'***Maj 2022-10-25
'Déplace la table dans le calque spécifié
swRevTable.GetAnnotation.Layer = "Cotation"
'***Fin Maj 2022-10-25
End If
'On récupère les infos sur le nom de session windows
UserName = Environ("USERNAME")
UserName = Replace(UserName, ".", " ")
UserName = StrConv(UserName, vbProperCase)
'Debug.Print "Nom de session windows:" & UserName
'On demande la valeur de la description du nouveau indice
DescriptionRev = InputBox("Taper la description de la révision:", "Ajout de Révision")
If DescriptionRev = "" Then
DescriptionRev = " A définir"
End If
'On ajoute la ligne de révision
'Debug.Print "On ajoute une ligne à la table de révision"
AddRevision swRevTable, Indice, Array("A définir", "", DescriptionRev, "", UserName)
Else
MsgBox "Merci d'ouvrir un plan"
End If
End Sub
Sub AddRevision(swRevTable As SldWorks.RevisionTableAnnotation, revName As String, rowData As Variant)
Dim i As Integer
Dim swTableAnn As SldWorks.TableAnnotation
Set swTableAnn = swRevTable
swRevTable.AddRevision revName
For i = 0 To UBound(rowData)
If rowData(i) <> "" Then
swTableAnn.Text(swTableAnn.RowCount - 1, i) = rowData(i)
End If
Next
End Sub
Other link on this forum:
https://forum.mycad.visiativ.com/t/macro-insertion-table-de-revision-revision-solidworks/106142
3 Likes
Thank you I think it gives a good lead but suddenly.
Nothing works, I wonder if it's not my revision table that's buggy
Every time I want to insert it, it loses these revision table properties, I can't increment the indices anymore... or my SolidWorks which is HS but the weird thing is that in the office no one can get the revision table normally. Only the one that's already in the basic drawing is working pretty much normally. I just make a macro to add a line, nothing more to validate the method but I still can't do it...
If you add it by hand does it work?
If so, debugging on the macro has been done, if it doesn't work by hand pb on the table.
Another solution offers a room + MEP with table for download here for try adding a line via vba (if necessary you delete some data in the background plan to guarantee professional secrecy.)
Hello;
I use this macro to " force " the new index from our revision tables.
Note:
In our case, the properties of the new index are already filled in via Smartproperties (visiativ utility) and then the macro adds a new row on our revision table:
Public swApp As SldWorks.SldWorks
Public swDoc As SldWorks.ModelDoc2
Public SwSheet As SldWorks.DrawingDoc
Public swview As SldWorks.View
Public SwTableRev As TableAnnotation
Public swAnn As SldWorks.Annotation
Public currentsheet As Object
Public mytablerev As Object
Dim LayerMgr As SldWorks.LayerMgr
Dim draw As SldWorks.ModelDoc2
Sub Ajout_table_rev()
Set swApp = Application.SldWorks
Set swDoc = swApp.ActiveDoc
Set SwSheet = swDoc
'insertion table
'attention changer le chemin pour la table de revision
' si true alors la table se met sur le point d'ancrage des MEP sinon sur coordonné 0,0
Set currentsheet = SwSheet.GetCurrentSheet
Set mytablerev = currentsheet.InsertRevisionTable(True, 0, 0, 3, Renseigner ici l'emplacement exact de la table de Revision.sldrevtbt") '<=
Set myRevisionTable = currentsheet.RevisionTable
longstatus = myRevisionTable.AddRevision("")
'Deplace la table sur le calque "Annotation"
myRevisionTable.GetAnnotation.Layer = "Annotation"
Dim Revis As String
Revis = myRevisionTable.CurrentRevision
'Ajoute la valeur de "revision" sur la table
Dim Valeur As String
Set swModel = swApp.ActiveDoc
Valeur = swModel.DeleteCustomInfo("Revision")
Valeur = swModel.AddCustomInfo3("", "Revision", swCustomInfoText, Revis)
'force la reconstruction
Dim bRet As String
bRet = swModel.Rebuild(swRebuildOptions_e.swForceRebuildAll)
End Sub
Be careful to specify the full path of the revision table to be used (format*.sldrevtbt)
See API help for " AddCustomInfo3 " and " Add3 "(FieldName, FieldType, FieldValue, OverwriteExisting):
1 Like
Thank you all!
I found it. In fact, it works fine, but the document settings were blocking normal execution. My document template was set to " Sheet1 " in the document settings, which prevented macro adding. I had to change it to " Bound ".
1 Like