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).  

 

like:

$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
Dim PARTNUMBER As Object


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.

 

thanks

Attachments

Outcomes