AnsweredAssumed Answered

Design table not updating with VBA opened Excel Workbook

Question asked by Mike Smith on Mar 25, 2016

I have a part with an internal design table and the cells in said design table reference an external Excel spreadsheet. I have a macro that will open the design table and update the links. One thing that I discovered tho is that the design table will not actually update unless the external spreadsheet is open my problem is that when I try to use the macro to open the spreadsheet the design table does not update....only if I open the spreadsheet either through Excel or opening it from a browser window. I am using Application.FileDialog to select the file and put it in a variable then open it using Workbooks.open(). I know that FileDialog doesn't oopen a file but only allows it to be selected. I tried to use GetOpenFilename but I was unable to change the directory that the browser window opens in even when I used ChDrive and then ChDir. I am just learning VBA so please forgive my ignorance. Any help would be appreciated. Here is my code for reference

 

Option Explicit

 

 

Dim swApp           As SldWorks.SldWorks

Dim Part            As SldWorks.ModelDoc2

Dim newLink         As Variant

Dim currentLink     As Variant

Dim designTable     As SldWorks.designTable

Dim xlApp           As Excel.Application

Dim LayoutApp       As Excel.Application

Dim xlWS            As Excel.Worksheet

Dim xlWB            As Excel.Workbook

Dim Layout          As Excel.Workbook

Dim link            As String

Dim fileName        As String

Dim workingDir      As String

Dim swFrame         As SldWorks.Frame

Dim vWindows        As Variant

Dim swDocXt         As SldWorks.ModelDocExtension

Dim SelectedFile    As String

 

Sub main()

Set swApp = _

Application.SldWorks

 

Set xlApp = _

New Excel.Application

 

Set LayoutApp = _

New Excel.Application

 

LayoutApp.Visible = True

'Get current working directory

workingDir = CurDir$

 

With LayoutApp.Application.FileDialog(msoFileDialogFilePicker)

    .InitialFileName = workingDir

    .AllowMultiSelect = False

    .Title = "Select Spreadsheet to Open"

    .Filters.Add "Excel Files Only", "*.xlsx"

   

    If .Show = -1 Then

        'ok clicked

        SelectedFile = .SelectedItems(1)

        Set Layout = LayoutApp.Workbooks.Open(SelectedFile)

        Layout.Activate       

        'MsgBox SelectedFile

    Else

        'cancel clicked

    End If

 

End With

 

'If SelectedFile = "" Then

'    End Sub

'Else

    Set swFrame = swApp.Frame

    vWindows = swFrame.ModelWindows

    If Not IsEmpty(vWindows) Then

        Dim i As Integer

            For i = 0 To UBound(vWindows)

                Dim win As ModelWindow

                Set win = vWindows(i)

                Set Part = swApp.ActiveDoc

                Set swDocXt = Part.Extension

                If swDocXt.HasDesignTable = False Then

                    Part.Save

                    swApp.CloseDoc Part.GetTitle()

                Else

                    Set designTable = Part.GetDesignTable

                    designTable.EditFeature

                    designTable.LinkToFile = False

                    designTable.UpdateFeature

                    designTable.Attach

                    Set xlWS = designTable.Worksheet

                    Set xlWB = designTable.Worksheet.Parent

 

                    'Get current links to external Excel Spreadsheet

                    currentLink = xlWB.LinkSources(xlExcelLinks)

                    link = Join(currentLink)

                    fileName = Mid(link, InStrRev(link, "\"))

 

                    'Get the current working directory and add the filename the link will be updated to

                    newLink = workingDir & fileName

                    If StrComp(link, newLink, vbTextCompare) = 0 Then

                        'MsgBox "Link Source is up to date"

                    Else

                        'Update Design Table link to external spreadsheet

                        xlWB.ChangeLink link, newLink, xlLinkTypeExcelLinks

                    End If

                    Part.CloseFamilyTable

                    Part.Save

                    swApp.CloseDoc Part.GetTitle()

                End If

            Next

    End If

'End If  

End Sub

Outcomes