3 Replies Latest reply on May 14, 2015 10:56 AM by Deepak Gupta

    Check if excel file is open

    Jonny Levelius

      I am writing a macro that when the button is clicked it sends the custom properties of the particular part or assembly to an excel file and lists the properties horizontally.  It then grabs a new part number associated with that row and copies it the clipboard to be pasted into the SaveAs file dialog box.  Then it saves and closes the excel file.  I have it set up where the excel file doesn't even show up.  I need the macro to first check if the master part excel file is already open.  If it is open it will pop up a msgbox saying it is open by username and then exit sub.  I have found much code to do the file check but I can't get it to work with my macro for some reason.  My issue is that when it runs the check it thinks the file is open already when it isn't.  Does anyone have a good file check with username they can show me?

        • Re: Check if excel file is open
          Deepak Gupta

          What you mean by username? Can you share the codes snippet with username you're trying to use?

            • Re: Check if excel file is open
              Jonny Levelius

              I was hoping to get a msgbox to pop up saying for example "File is already being used by JLevelius".  This is so if somebody is camping in the file we can let them know that we need to get a part number out of it.  My current code doesn't contain the username part of the code yet.

              Here is my entire code.  I am new to VBA and API so it may be a little crude and contain some redundant calls.

               

              Option Explicit

               

               

              Dim swApp               As SldWorks.SldWorks

              Dim swModel            As SldWorks.ModelDoc2

              Dim longstatus          As Long, longwarnings As Long

              Dim xlApp                  As Excel.Application

              Dim xlWb                   As Excel.Workbook

              Dim xlWbs                 As Excel.Workbooks

              Dim xlPath                 As String

              Dim xlFN                    As String

              Dim PARTdescr         As String

              Dim VERIFYpart        As Integer

              Dim str                       As String

              Dim RET

               

              Sub main()

              On Error Resume Next

              Set swApp = Application.SldWorks

              Set swModel = swApp.ActiveDoc

              Set xlApp = Excel.Application

              Set xlWbs = Excel.Workbooks

              Set xlWb = xlApp.Workbooks.Open("C:\Users\jlevelius\Desktop\TEST NUMBERING.xlsm")

              '=========================================CHECK IF FILE IS ALREADY IN USE

              RET = IsWorkBookOpen("C:\Users\jlevelius\Desktop\TEST NUMBERING.xlsm")

                  If RET = True Then

                  MsgBox "File is already being used!" '==========IF IN USE THEN EXIT SUB

                  Exit Sub

              '=========================================CHECK IF CORRECT FILE IS BEING SENT TO GET A PART NUMBER

                  Else

                      str = GetMaterialName(swModel)

                      PARTdescr = swModel.CustomInfo("Description") + ", " + swModel.CustomInfo("Sub-Description") + " | " + str

                      VERIFYpart = MsgBox(PROMPT:="Is this the correct part?" & vbNewLine & PARTdescr, Buttons:=vbYesNo)

                      If VERIFYpart = vbNo Then '===============IF WRONG FILE THEN EXIT SUB

                          Exit Sub

                      ElseIf VERIFYpart = vbYes Then '===========IF CORRECT PART THEN CHECK IF PART OR ASSEMBLY AND SEND TO EXCEL FILE

                          Workbooks.Open ("C:\Users\jlevelius\Desktop\TEST NUMBERING.xlsm")

                          If swModel.GetType = swDocPART Then

                              xlPath = Environ("USERPROFILE") & "\Desktop\"

                              xlFN = "Properties Details" & ".xlsx"

                              If Dir(xlPath & xlFN) <> "" Then

                              Kill xlPath & xlFN

                              End If

                                  Workbooks("TEST NUMBERING.xlsm").Activate

                                  Workbooks("TEST NUMBERING.xlsm").Sheets("PART").Activate

                                  ActiveWorkbook.Worksheets("PART").Range("A1560").Select

                                  Selection.End(xlDown).Select

                                      ActiveCell.Offset(1, 0).Select

                                          ActiveWorkbook.Worksheets("PART").Range("B" & ActiveCell.Row).Value = swModel.CustomInfo("Description")

                                          ActiveWorkbook.Worksheets("PART").Range("C" & ActiveCell.Row).Value = swModel.CustomInfo("Sub-Description")

                                          ActiveWorkbook.Worksheets("PART").Range("D" & ActiveCell.Row).Value = str

                                          ActiveWorkbook.Worksheets("PART").Range("E" & ActiveCell.Row).Value = swModel.CustomInfo("Job Number")

                                          ActiveWorkbook.Worksheets("PART").Range("F" & ActiveCell.Row).Value = swModel.CustomInfo("Client")

                                          ActiveWorkbook.Worksheets("PART").Range("G" & ActiveCell.Row).Value = swModel.CustomInfo("Location")

                                          ActiveWorkbook.Worksheets("PART").Range("I" & ActiveCell.Row).Value = swModel.CustomInfo("Author")

                                          ActiveWorkbook.Worksheets("PART").Range("J" & ActiveCell.Row).Value = swModel.CustomInfo("Vendor")

                                          ActiveWorkbook.Worksheets("PART").Range("K" & ActiveCell.Row).Value = swModel.CustomInfo("Vendor Part Number")

                                  ActiveCell.Copy

                          ElseIf swModel.GetType = swDocASSEMBLY Then

                              xlPath = Environ("USERPROFILE") & "\Desktop\"

                              xlFN = "Properties Details" & ".xlsx"

                              If Dir(xlPath & xlFN) <> "" Then

                              Kill xlPath & xlFN

                              End If

                                  Workbooks("TEST NUMBERING.xlsm").Activate

                                  Workbooks("TEST NUMBERING.xlsm").Sheets("ASSEMBLY").Activate

                                  ActiveWorkbook.Worksheets("ASSEMBLY").Range("A156").Select

                                  Selection.End(xlDown).Select

                                      ActiveCell.Offset(1, 0).Select

                                          ActiveWorkbook.Worksheets("ASSEMBLY").Range("B" & ActiveCell.Row).Value = swModel.CustomInfo("Description")

                                          ActiveWorkbook.Worksheets("ASSEMBLY").Range("C" & ActiveCell.Row).Value = swModel.CustomInfo("Sub-Description")

                                          ActiveWorkbook.Worksheets("ASSEMBLY").Range("D" & ActiveCell.Row).Value = ""

                                          ActiveWorkbook.Worksheets("ASSEMBLY").Range("E" & ActiveCell.Row).Value = swModel.CustomInfo("Job Number")

                                          ActiveWorkbook.Worksheets("ASSEMBLY").Range("F" & ActiveCell.Row).Value = swModel.CustomInfo("Client")

                                          ActiveWorkbook.Worksheets("ASSEMBLY").Range("G" & ActiveCell.Row).Value = swModel.CustomInfo("Location")

                                          ActiveWorkbook.Worksheets("ASSEMBLY").Range("I" & ActiveCell.Row).Value = swModel.CustomInfo("Author")

                                          ActiveWorkbook.Worksheets("ASSEMBLY").Range("J" & ActiveCell.Row).Value = swModel.CustomInfo("Vendor")

                                          ActiveWorkbook.Worksheets("ASSEMBLY").Range("K" & ActiveCell.Row).Value = swModel.CustomInfo("Vendor Part Number")

                                  ActiveCell.Copy

                          End If

                      End If

                      Workbooks("TEST NUMBERING").Close savechanges:=True

                  End If

              End Sub

              Function GetMaterialName(ByVal ModelToCheck As SldWorks.ModelDoc) As String

              Dim sMaterialName As String

              Dim StartI As Integer

              Dim LastI As Integer

               

              GetMaterialName = ""

              sMaterialName = ""

               

              If ModelToCheck Is Nothing Then

                 Exit Function

              End If

               

              sMaterialName = ModelToCheck.MaterialIdName

              StartI = InStr(sMaterialName, "|")

              LastI = InStrRev(sMaterialName, "|")

               

              If StartI > 0 And LastI > 0 Then

                 If StartI = LastI Then

                    sMaterialName = Right(sMaterialName, Len(sMaterialName) - StartI)

                    GetMaterialName = sMaterialName

                 Else

                    sMaterialName = Mid(sMaterialName, StartI + 1, LastI - StartI - 1)

                    GetMaterialName = sMaterialName

                 End If

              End If

               

              End Function

              Function IsWorkBookOpen(FileName As String)

                  Dim ff As Long, ErrNo As Long

               

               

                  On Error Resume Next

                  ff = FreeFile()

                  Open FileName For Input Lock Read As #ff

                  Close ff

                  ErrNo = Err

                  On Error GoTo 0

               

               

                  Select Case ErrNo

                  Case 0:    IsWorkBookOpen = False

                  Case 70:   IsWorkBookOpen = True

                  Case Else: Error ErrNo

                  End Select

              End Function