Grega Kalan

macro HELP:)  open part from drawing and fill the configuration custom properties from excel database.

Discussion created by Grega Kalan on Oct 1, 2020
Latest reply on Oct 6, 2020 by Grega Kalan

Hi I need a litle help for my macro. 

1. First I want to open part from active drawing.


this is my macro that doesn't work :S

Dim swApp As Object
Dim sFileName As String
Dim Drw As Object


Sub main()
Set swApp = Application.SldWorks
Set Drw = swApp.ActiveDoc


Set fso = CreateObject("Scripting.FileSystemObject")
sFileName = Left$(Drw.GetPathName, (Len(Drw.GetPathName) - 6)) & "SLDPRT"
If fso.FileExists(sFileName) Then
    Set Part = swApp.OpenDoc(sFileName, swDocPART)
    Else: MsgBox ("Part does not exist")
End If

End Sub


2. I want to fill configuration costume properties from exel detabase. 

I would like the macro  find in Excel the corresponding properties (Description, PART NUMBER ...) according to the file name (name of part). However, they must be entered at the configuration level (cofiguration specific).  



$PRPSHEET:{Description} for Description


This is the code that works for me. but I don't know how I need to fix it to make it work at the configuration level

Dim swApp As SldWorks.SldWorks
Dim excApp As Excel.Application
Dim swModel As SldWorks.ModelDoc2
Dim swCustPrpMgr As config.CustomPropertyManager

Sub main()

Set swApp = Application.SldWorks


Set swApp = Application.SldWorks
Set excApp = GetObject(, "Excel.Application")


Set swModel = swApp.ActiveDoc


Set swCustPrpMgr = swModel.Extension.CustomPropertyManager("")


Dim excRange As range
Dim excSheet As Excel.Worksheet
Set excSheet = excApp.ActiveSheet
Set excRange = excSheet.range(excApp.Cells(1, 1), excApp.Cells(1000, 1))


Dim searchRes As range


Dim name As String

Dim index As Integer

Dim title As String

title = swModel.GetTitle()

index = InStr(title, ".")

name = Left(title, Len(title) - IIf(index = 0, 0, index + 1))

Set searchRes = excRange.Cells.Find(name)


If Not searchRes Is Nothing Then


LinkPrpToCell searchRes.row, 1, "Item No"
LinkPrpToCell searchRes.row, 2, "PART NUMBER"
LinkPrpToCell searchRes.row, 3, "Description"
LinkPrpToCell searchRes.row, 4, "SAP Number"


End If


End Sub

Sub LinkPrpToCell(row As Integer, col As Integer, prpName As String)

Dim value As String
Dim field As String




field = prpName
value = excApp.Cells(row, col).value


swCustPrpMgr.Add2 field, swCustomInfoType_e.swCustomInfoText, value
swCustPrpMgr.Set field, value

End Sub


Excel, test parts, macro..... everything is attached in "macro.rar"


Some code is based on already written macros from Deepak Gupta. I hope he doesn't mind.