2 Replies Latest reply on Sep 24, 2018 9:29 AM by Luigi Piron

    macro corrupted help!!

    Luigi Piron

      could Anyone help me to open the macro and resend me the code inside ??

      thankyou

        • Re: macro corrupted help!!
          Jerome De San Nicolás

          Here you go :

          (EDITED for typo)

           

          Dim SWFeature As SldWorks.Feature
          Dim swRifent As SldWorks.Feature
          Dim normaleColo As SldWorks.Feature
          Dim rifPlane As SldWorks.Feature
          Dim W500 As String
          Dim W502 As String
          Dim W503 As String
          Dim W501 As String
          Dim DestFile, Cartella, FileNum, Nomefile As String
          
          Sub ColonneBugged(nomecolonna As String)
          
              Nomefile = nomecolonna & ".VRP"
              Cartella = "C:\Users\LuigiP" & "\Desktop\"
              DestFile = Cartella & Nomefile
              FileNum = FreeFile()
              
          End Sub
          Sub CreaArchivio(ByRef nomecolonna As String, ByVal pos As String, ByRef spec As String, ByVal spiR As String, ByRef Comm As String)
          
                  Call ColonneBugged(nomecolonna)
                  Open DestFile For Append As #FileNum
                  Print #FileNum, "; g1"
                  Print #FileNum, "W500 = " & pos
                  Print #FileNum, "W501 = " & spec
                  Print #FileNum, "W502 = " & spiR
                  Print #FileNum, "W503 = " & Comm
                  Close #FileNum
          
          End Sub
          Sub distanze(ByRef nomecolonna As String, ByVal k As Integer, ByRef arr() As Double)
          
                  Call ColonneBugged(nomecolonna)
                  Open DestFile For Append As #FileNum
                  Print #FileNum, "D" & 100 + k; " = " & arr(k)
                  Close #FileNum
          
          End Sub
          Sub Colonnafallata(ByRef nomecolonna As String, avviso As String)
          
                  Call ColonneBugged(nomecolonna)
                  Open DestFile For Append As #FileNum
                  Print #FileNum, "COLONNA FALLATA    " & avviso
                  Close #FileNum
          
          End Sub
          
          Sub distanza()
          
          Dim swApp As Object
          Dim theFeature As Feature
          Dim featCount As Long
          Dim featName As String
          Dim i As Long
          Dim boolstatus As Boolean
          Dim longstatus As Long
          Dim longwarnings As Long
          Dim swFeatMgr As SldWorks.FeatureManager
          Dim varComp As Variant
          Dim NumComp As Variant
          Dim varCompNum As Long
          Dim swComp As SldWorks.Component2
          Dim j As Long
          Dim swFeat As SldWorks.Feature
          Dim Feature As SldWorks.Feature
          'Dim swRifent As SldWorks.Feature
          Dim swCompModel  As SldWorks.ModelDoc2
          Dim swModel As SldWorks.ModelDoc2
          Dim swAssDoc As SldWorks.AssemblyDoc
          Dim FeatureName As String
          Dim message As String
          Dim subFeat As SldWorks.Feature
          Dim SubFeatureName As String
          Dim swModelDocExt As ModelDocExtension
          Dim vPropNames As Variant
          Dim valOut              As String
          Dim resolvedValOut      As String
          Dim custPropType        As Long
          Dim s As Integer
          Dim nNbrProps           As Long
          Dim swCustPropMgr As SldWorks.CustomPropertyManager
          Dim swConfigMgr         As SldWorks.ConfigurationManager
          Dim swConfig            As SldWorks.Configuration
          Dim swNameDoc As String
          Dim percorso As String
          Dim Part As Object
          Dim filename As String
          Dim runMacroError As Long
          Dim ModelDocExtension As ModelDocExtension
          Dim Value As Integer
          Dim swSelMgr As SldWorks.SelectionMgr
          Dim A As Double
          Dim Measure As SldWorks.Measure
          Dim swConf  As SldWorks.Configuration
          Dim vConfigNameArr  As Variant
          Dim nRetVal As Long
          Dim swDerivConf As SldWorks.Configuration
          Dim specialeColo As SldWorks.Feature
          Dim specialeColo1 As SldWorks.Feature
          Dim swRif As Entity
          Dim swplani As SldWorks.Entity
          Dim swAssem As SldWorks.AssemblyDoc
          Dim vComponents As Variant
          Dim vComp As Variant
          Dim swCol As String
          Dim searchString As String
          Dim cicciofeat As SldWorks.Feature
          Dim res1 As Double
          Dim swMathUtils As SldWorks.MathUtility
          Dim swMathVec As SldWorks.MathVector
          Dim arr() As Double
          'Dim Posizionenumspir As Integer
          'Dim PosizionenumGamb As Integer
          'Dim PosizionenumComm As Integer
          'Dim NumSpir As String
          'Dim numGamb As String
          'Dim numComm As String
          Dim nomefilevrp As String
          
          Set swApp = Application.SldWorks
          Set swModel = swApp.ActiveDoc
          
          Set swSelMgr = swModel.SelectionManager
          Set swConfigMgr = swModel.ConfigurationManager
          Set swConfig = swConfigMgr.ActiveConfiguration
          Set swCustPropMgr = swConfig.CustomPropertyManager
          swCustPropMgr.Get2 "CODICE", valOut, resolvedValOut
          Debug.Print "CODICE" & ", " & resolvedValOut
          nomefilevrp = resolvedValOut
          Call ColonneBugged(nomefilevrp)
          
          Debug.Print swModel.GetTitle
          
          Set swAssDoc = swModel
          Set normaleColo = swAssDoc.FeatureByName("Piano superiore")
          
          varCompNum = swAssDoc.GetComponentCount(False)
          Debug.Print varCompNum
          varComp = swAssDoc.GetComponents(True)
          
          For j = LBound(varComp) To UBound(varComp)
              Set swComp = varComp(j)
                 Debug.Print swComp.Name2
                 
                    If (swComp.IsSuppressed) Then
                      GoTo Line1
                    End If
                    
          Set swCompModel = swComp.GetModelDoc2
                                              
                                              'prova per vedere se riesco a inserire la quota delle speciali
                                              Set swConfigMgr = swCompModel.ConfigurationManager
                                              Set swConfig = swConfigMgr.ActiveConfiguration
                                              Set swCustPropMgr = swConfig.CustomPropertyManager
                                              swCustPropMgr.Get2 "CODICE", valOut, resolvedValOut
                                              Debug.Print "CODICE" & ", " & resolvedValOut
                                              
                                              If (InStr(1, resolvedValOut, "MAP", 1)) = 1 Then
                                                                    Set SWFeature = swCompModel.FeatureByName("Piano Taglio Inf")
                                                                    Set swRifent = swComp.GetCorresponding(SWFeature)
                                                                    bRet = swRifent.Select4(True, Nothing)
                                                                    If bRet = False Then
                                                                    
                                                                    
                                                                    Dim NoSpeciale As Boolean
                                                                    NoSpeciale = IsSuspended
                                                                    Debug.Print "la colonna è normale?"; NoSpeciale
                                                                    
                                                                              If NoSpeciale = False Then
                                                                              
                                                                                 Set SWFeature = swCompModel.FeatureByName("Piano Taglio Inf")
                                                                                 Set swRifent = swComp.GetCorresponding(SWFeature)
                                                                                 'bRet = swRifent.Select4(True, Nothing)
                                                                              Set rifPlane = swRifent
                                                                                 W501 = 0
                                                                                 
                                                                              Else
                                                                              swModel.ClearSelection
                                                                              Set swModel = swApp.ActiveDoc
                                                                                 Set swAssDoc = swModel
                                                                                 Set normaleColo = swAssDoc.FeatureByName("Piano superiore")
                                                                              Set rifPlane = normaleColo
                                                                                 W501 = 1
                                                                              End If
                 
                                                                    swModel.ClearSelection
                                                                    Exit For
                                              Else
                                              GoTo Line1
                                              End If
                                               
          swModel.ClearSelection
                             
          Line1:
          Next j
          
          i = 0
          Set swApp = Application.SldWorks
          Set swModel = swApp.ActiveDoc
          Set swConfigMgr = swModel.ConfigurationManager
          Set swConfig = swConfigMgr.ActiveConfiguration
          Set swCustPropMgr = swConfig.CustomPropertyManager
          swCustPropMgr.Get2 "CODICE", valOut, resolvedValOut
          Debug.Print "CODICE" & ", " & resolvedValOut
          Call CercaCommessa(resolvedValOut)
          Call CreaArchivio(nomefilevrp, W500, W501, W502, W503)
          Debug.Print swModel.GetTitle
          swCol = Strings.Left(swModel.GetTitle, 11)
          
          Debug.Print swCol
          Set swAssem = swModel
          Set cicciofeat = swAssem.FeatureByName("Piano superiore")
          vComponents = swAssem.GetComponents(True)
          swModel.ClearSelection2 True
             'searchString = InputBox("Please enter search term")
          
                 For Each vComp In vComponents
                      Set swComp = vComp
                      If InStr(swComp.Name2, "TCP00513818") > 0 Then
                      'Debug.Print swComp.Name2
                                              'i = 0
                                              
                                              Dim swEdge As Entity
                                              Dim swEnt As SldWorks.Entity
                                              swComp.Select4 True, Nothing, False
                                                       
                                              'boolstatus = swComp.Select4(True, Nothing)
                                              Set swSelMgr = swModel.SelectionManager
                                              Set swComp = swSelMgr.GetSelectedObject6(1, -1)
                                                            Set swMathUtils = swApp.GetMathUtility
                                                            Dim dVec(2) As Double
                                                            dVec(0) = 0: dVec(1) = 0: dVec(2) = 1
                                                            Set swMathVec = swMathUtils.CreateVector(dVec)
                                                            Set swMathVec = swMathVec.MultiplyTransform(swComp.Transform2)
                                                          Dim vVecData As Variant
                                                          vVecData = swMathVec.ArrayData
                                                          Debug.Print vVecData(0) & "; " & vVecData(1) & "; " & vVecData(2)
                                                          swModel.ClearSelection2 True
          
                                              If vVecData(2) = -1 Then
                                                       
                                              Set swCompModel = swComp.GetModelDoc2
                                              Set swEnt = swCompModel.GetEntityByName("gigi", swSelectType_e.swSelEDGES)
                                              Set swEdge = swComp.GetCorrespondingEntity(swEnt)
                                              boolstatus = swEdge.Select4(True, Nothing)
                      
          
                           'boolstatus = cicciofeat.Select2(True, 0)
                           boolstatus = rifPlane.Select2(True, 0)
                      
                           Set Measure = swModel.Extension.CreateMeasure
                                   Measure.ArcOption = 1
                                   boolstatus = Measure.Calculate(Nothing)
                                        If (boolstatus) Then
                                           If (Not (Measure.NormalDistance = -1)) Then
                                        'Debug.Print Measure.NormalDistance * 1000
                                        res1 = Round(Measure.NormalDistance * 1000, 2)
                                        'Debug.Print res1
                                        ReDim Preserve arr(i)
                                        arr(i) = res1
                                        'Call distanze(nomefilevrp, arr(i))
                                        'Debug.Print arr(i)
                                        i = i + 1
                                       
                                       
                                           End If
                                      
                                        End If
                      swModel.ClearSelection
                      Else
                      'swComp.Select4 True, Nothing, False
                      End If
                      End If
                      
                 Next
                 
                 For i = 0 To UBound(arr)
                 Debug.Print i & "-" & arr(i)
                 Next
                 
                 Call BubbleSort(arr)
                 
                 For i = 0 To UBound(arr)
                 Debug.Print i & "-" & arr(i)
                 Call distanze(nomefilevrp, i, arr())
                 Next
          
          'bRet = swRifent.Select4(True, Nothing)
          'Call
          'Call CreaArchivio(nomefilevrp, W500, W501, W502, W503)
          End Sub
          Function IsSuspended() As Boolean
          
              Dim swApp As SldWorks.SldWorks
              Dim swModel As SldWorks.ModelDoc2
              Dim swSelMgr As SldWorks.SelectionMgr
              Dim swFeat As SldWorks.Feature
              Dim vConfNameArr As Variant
              Dim vSuppStateArr As Variant
              Dim i As Long
              Dim bRet As Boolean
              
              Set swApp = Application.SldWorks
              Set swModel = swApp.ActiveDoc
              Set swSelMgr = swModel.SelectionManager
              Set swFeat = swSelMgr.GetSelectedObject6(1, -1)
              
              vConfNameArr = swModel.GetConfigurationNames
              vSuppStateArr = swFeat.IsSuppressed2(swThisConfiguration, vConfNameArr)
              Debug.Print "File = " & swModel.GetPathName
              Debug.Print "  " & swFeat.Name
              For i = 0 To UBound(vConfNameArr)
                  Dim normale As Boolean
                  Debug.Print "    " & vConfNameArr(i) & " ---> " & vSuppStateArr(i)
                  normale = vSuppStateArr(i)
              Next i
              IsSuspended = normale
              
          End Function
          
          
          Sub BubbleSort(arr)
            Dim strTemp As String
            Dim i As Long
            Dim j As Long
            Dim lngMin As Long
            Dim lngMax As Long
            lngMin = LBound(arr)
            lngMax = UBound(arr)
            For i = lngMin To lngMax - 1
              For j = i + 1 To lngMax
                If arr(i) > arr(j) Then
                  strTemp = arr(i)
                  arr(i) = arr(j)
                  arr(j) = strTemp
                End If
              Next j
            Next i
          End Sub
                 
          Function CercaCommessa(ByVal Codice As String) As String
          
          Dim cn As ADODB.Connection
          Dim rs As ADODB.Recordset
          Dim r As Integer
          Dim t As Integer
          Dim count As ADO_LONGPTR
          Dim n As Integer
          Dim h As Integer
          Dim A As String
          Dim nStart As Single
          Dim temp As String
          Dim descDaModif As String
          Dim TestNumber As Integer
          Dim NewDesc As String
          Dim Strdesc As String
          Dim Posizionenumspir As Integer
          Dim PosizionenumGamb As Integer
          Dim PosizionenumComm As Integer
          Dim NumSpir As String
          Dim numGamb As String
          Dim numComm As String
          
          Set cn = New ADODB.Connection
          cn.ConnectionString = "Provider=sqloledb; data source=srvsolid02;user id=sa;password=P@ssw0rd; initial catalog=DBCENT_TECNOPOOL_MAINDB"
          'cn.ConnectionString = "Provider=sqloledb; data source=TPWS10\DBCENT;user id=sa;password=P@ssw0rd; initial catalog=DBCENT_TECNOPOOL_MAINDB"
          cn.Open
          Set rs = New ADODB.Recordset
          rs.ActiveConnection = cn
          rs.Open "select CODE,R_TYPE,DESC1 from DOC", cn, adOpenDynamic, adLockOptimistic
          
          'Debug.Print t & rs![UID]; "----"; rs![CODE]; "----"; rs![R_TYPE]; "----"; rs![RELATIVE_PATH]; "----"; rs![FILE_NAME]; "----"; rs![DESC1]
          
          nStart = Timer
          rs.MoveLast 'ESSENDO DI DEFAULT ADOPENINGFORWARDONLY NON POSSO TORNARE INDIETRO
          
          Do Until rs.BOF 'And rs!R_TYPE = "SLDASM"
          rs.Find "CODE=" & "'" & Codice & "'", , adSearchBackward
          If rs.BOF Then
          Debug.Print "non trovato"
          Exit Do
          Else
          Debug.Print rs![CODE]; "----"; rs!R_TYPE; "----"; rs![DESC1]
          If rs![R_TYPE] <> "SLDASM" Then
          rs.MovePrevious
          Else
          descDaModif = rs![DESC1]
          
          Debug.Print rs![CODE]; "----"; rs!R_TYPE; "----"; rs![DESC1]
          Strdesc = rs![DESC1]
          
          Posizionenumspir = InStr(23, rs![DESC1], "<")
          Debug.Print Posizionenumspir
          NumSpir = Mid(rs![DESC1], Posizionenumspir + 1, 2)
          'Dim W502 As String
          W502 = NumSpir
          Debug.Print W502
          
          PosizionenumGamb = InStr(33, rs![DESC1], "<")
          Debug.Print PosizionenumGamb
          numGamb = Mid(rs![DESC1], PosizionenumGamb + 1, 2)
          'Dim W500 As String
          W500 = numGamb
          Debug.Print W500
          
          PosizionenumComm = InStr(44, rs![DESC1], "<")
          Debug.Print PosizionenumComm
          numComm = Mid(rs![DESC1], PosizionenumComm + 1, 4)
          'Dim W503 As String
          W503 = numComm
          Debug.Print W503
          
          Exit Do
          End If
          End If
          Debug.Print "    Time       = " & Timer - nStart & " s"
          Loop
          rs.Close
          Set rs = Nothing
          Set cn = Nothing
          
          End Function
          
          Sub Printdocument()
          
          Dim swApp As Object
          Dim swModelDocExt As ModelDocExtension
          Set swApp = Application.SldWorks
          'drawing = "C:\Program Files\SolidWorks Corp\SolidWorks\samples\tutorial\advdrawings\foodprocessor.slddrw"
          Set swModel = swApp.ActiveDoc()
          ' Set up page
          Set swPageSetup = swModel.PageSetup
          swPageSetup.Orientation = 2   ' 1=Portrait  '2 = Landscape
          ' Print all pages
          sheets(0) = 0
          ' Print all of the sheets to the specified printer and convert to high quality
          Set swModelDocExt = swModel.Extension
          'swModelDocExt.PrintOut3 sheets, 1, False, "RICOH MP C4503 PCL 6 - Tecnico", "", True
          'swModelDocExt.PrintOut3 sheets, 1, False, "RICOH MP C4503 PCL 6 - Strutture", "", True
          swModelDocExt.PrintOut3 sheets, 1, False, "RICOH MP C5504ex PCL 6 - Strutture su SrvFS01", "", True
          End Sub