---

Sub main()
    On Error GoTo EH

    Dim swApp As Object
    Dim swTop As Object
    Dim swSel As Object
    Dim comp As Object
    Dim swSub As Object
    Dim o As Object
    Dim dd As Object
    Dim d As Object
    Dim ch As Object
    Dim pm As Object
    Dim pd As Object
    Dim cfgObj As Object

    Dim v As Variant

    Dim i As Long
    Dim cnt As Long
    Dim t As Long
    Dim e As Long
    Dim w As Long

    Dim L As Double
    Dim curL As Double
    Dim oldSubL As Double
    Dim checkOldL As Double

    Dim cfgName As String
    Dim oldSub As String
    Dim oldPart As String
    Dim oldRef As String
    Dim pcfg As String
    Dim rep As String

    Dim okSet As Boolean

    Set swApp = Application.SldWorks
    Set swTop = swApp.ActiveDoc

    If swTop Is Nothing Then
        MsgBox "NO DOC"
        Exit Sub
    End If

    If swTop.GetType <> 2 Then
        MsgBox "OPEN TOP ASSEMBLY"
        Exit Sub
    End If

    Status swTop, "STEP 1/4: reading selection..."

    Set swSel = swTop.SelectionManager
    cnt = swSel.GetSelectedObjectCount2(-1)

    If cnt < 2 Then
        MsgBox "SELECT DIMENSION TEXT + SUBASSEMBLY WITH CTRL"
        Exit Sub
    End If

    Set comp = Nothing
    L = 0

    For i = 1 To cnt

        t = swSel.GetSelectedObjectType3(i, -1)
        Set o = swSel.GetSelectedObject6(i, -1)

        If t = 20 Then

            If comp Is Nothing Then
                Set comp = o
            End If

        ElseIf t = 14 Then

            Set dd = Nothing
            Set dd = o.GetDimension

            If Not dd Is Nothing Then
                L = dd.SystemValue * 1000
            End If

        End If

    Next i

    If comp Is Nothing Then
        MsgBox "NO SUBASSEMBLY SELECTED"
        Exit Sub
    End If

    If L <= 0 Then
        MsgBox "NO DIMENSION FOUND - CLICK DIMENSION TEXT"
        Exit Sub
    End If

    Set swSub = comp.GetModelDoc2

    If swSub Is Nothing Then
        MsgBox "SUB NOT LOADED - SET LIGHTWEIGHT TO RESOLVED"
        Exit Sub
    End If

    If swSub.GetType <> 2 Then
        MsgBox "SELECT SUBASSEMBLY"
        Exit Sub
    End If

    Status swTop, "STEP 2/4: subassembly " & _
                  CStr(CLng(L)) & " mm..."

    oldSub = swSub.ConfigurationManager.ActiveConfiguration.Name

    swSub.ShowConfiguration2 oldSub

    Set d = FindLenDim(swSub)

    If d Is Nothing Then
        MsgBox "SUB D1@LENGHT NOT FOUND"
        Exit Sub
    End If

    oldSubL = d.SystemValue * 1000

    cfgName = "L_" & CStr(CLng(L))

    Set cfgObj = EnsureConfig(swSub, cfgName)

    If cfgObj Is Nothing Then
        MsgBox "CANNOT CREATE SUB CONFIG " & cfgName
        Exit Sub
    End If

    If Not SetLength(swSub, d, L, cfgName) Then

        swSub.ShowConfiguration2 oldSub

        MsgBox "CANNOT SET SUB LENGTH" & vbCrLf & _
               "CONFIG: " & cfgName & vbCrLf & _
               "DIM: " & d.FullName

        Exit Sub
    End If

    swSub.ShowConfiguration2 oldSub
    checkOldL = d.SystemValue * 1000

    If Abs(checkOldL - oldSubL) > 0.05 Then

        rep = rep & "WARNING: OLD SUB CONFIG CHANGED" & vbCrLf
        rep = rep & oldSub & " : " & _
              FormatMM(oldSubL) & " -> " & _
              FormatMM(checkOldL) & " mm" & vbCrLf & vbCrLf

    End If

    swSub.ShowConfiguration2 cfgName
    swSub.EditRebuild3

    e = 0
    w = 0
    swSub.Save3 1, e, w

    comp.ReferencedConfiguration = cfgName

    swTop.EditRebuild3

    e = 0
    w = 0
    swTop.Save3 1, e, w

    swSub.ShowConfiguration2 cfgName
    swSub.EditRebuild3

    rep = rep & "SUB : " & FormatMM(L) & _
          " mm -> " & cfgName & vbCrLf & vbCrLf

    Status swTop, "STEP 3/4: reading updated part lengths..."

    v = swSub.GetComponents(False)

    If IsArray(v) Then

        For i = 0 To UBound(v)

            Set ch = Nothing
            Set ch = v(i)

            If Not ch Is Nothing Then

                If ch.IsSuppressed Then

                    rep = rep & ch.Name2 & _
                          " : SUPPRESSED - SKIPPED" & vbCrLf

                Else

                    Set pm =


("D1@LENGHT")

    If d Is Nothing Then
        Set d = m.Parameter("D1@LENGTH")
    End If

    If d Is Nothing Then
        Set d = m.Parameter("D2@LENGHT")
    End If

    If d Is Nothing Then
        Set d = m.Parameter("D2@LENGTH")
    End If

    Err.Clear
    On Error GoTo 0

    If Not d Is Nothing Then
        Set FindLenDim = d
    End If
End Function

Private Function EnsureConfig( _
    m As Object, _
    cfg As String) As Object

    Dim c As Object

    Set EnsureConfig = Nothing
    Set c = Nothing

    On Error Resume Next

    Set c = m.GetConfigurationByName(cfg)

    If c Is Nothing Then

        Err.Clear
        Set c = m.AddConfiguration3(cfg, "", "", 0)

        If c Is Nothing Then

            Err.Clear

            Set c = _
                m.ConfigurationManager.AddConfiguration2( _
                    cfg, "", "", 0, "", "")

        End If

    End If

    Err.Clear
    On Error GoTo 0

    Set EnsureConfig = c
End Function

Private Function SetLength( _
    m As Object, _
    d As Object, _
    valMM As Double, _
    cfg As String) As Boolean

    Dim r As Long
    Dim checkMM As Double

    SetLength = False

    m.ShowConfiguration2 cfg

    On Error Resume Next

    r = d.SetSystemValue3( _
        valMM / 1000, 2, Array(cfg))

    Err.Clear
    On Error GoTo 0

    m.EditRebuild3
    m.ShowConfiguration2 cfg

    checkMM = d.SystemValue * 1000

    If Abs(checkMM - valMM) < 0.05 Then
        SetLength = True
        Exit Function
    End If

    m.ShowConfiguration2 cfg

    On Error Resume Next

    r = d.SetSystemValue3( _
        valMM / 1000, 3, Empty)

    Err.Clear
    On Error GoTo 0

    m.EditRebuild3
    m.ShowConfiguration2 cfg

    checkMM = d.SystemValue * 1000

    If Abs(checkMM - valMM) < 0.05 Then
        SetLength = True
    End If
End Function

Private Function FormatMM(v As Double) As String
    If Abs(v - CDbl(CLng(v))) < 0.01 Then
        FormatMM = CStr(CLng(v))
    Else
        FormatMM = Format(v, "0.00")
    End If
End Function

Private Sub Status(m As Object, txt As String)
    On Error Resume Next
    m.SetStatusBarText txt
    Err.Clear
    On Error GoTo 0
End Sub Noth


ing
                    Set pm = ch.GetModelDoc2

                    If pm Is Nothing Then

                        rep = rep & ch.Name2 & _
                              " : NOT LOADED - SKIPPED" & vbCrLf

                    ElseIf pm.GetType = 2 Then

                        rep = rep & ch.Name2 & _
                              " : NESTED SUBASSEMBLY - SKIPPED" & _
                              vbCrLf

                    ElseIf pm.GetType = 1 Then

                        Status swTop, "STEP 3/4: " & _
                                      ch.Name2 & "..."

                        oldPart = _
                            pm.ConfigurationManager.ActiveConfiguration.Name

                        oldRef = ch.ReferencedConfiguration

                        If Len(oldRef) > 0 Then
                            pm.ShowConfiguration2 oldRef
                        End If

                        swSub.ShowConfiguration2 cfgName
                        swSub.EditRebuild3

                        Set pd = Nothing
                        Set pd = FindLenDim(pm)

                        If pd Is Nothing Then

                            rep = rep & ch.Name2 & _
                                  " : NO D1@LENGHT - SKIPPED" & _
                                  vbCrLf

                            pm.ShowConfiguration2 oldPart

                        Else

                            curL = pd.SystemValue * 1000

                            If curL <= 0.01 Then

                                rep = rep & ch.Name2 & _
                                      " : LENGTH IS ZERO - SKIPPED" & _
                                      vbCrLf

                                pm.ShowConfiguration2 oldPart

                            Else

                                pcfg = "L_" & CStr(CLng(curL))

                                Set cfgObj = Nothing
                                Set cfgObj = EnsureConfig(pm, pcfg)

                                If cfgObj Is Nothing Then

                                    rep = rep & ch.Name2 & _
                                          " : CANNOT CREATE CONFIG " & _
                                          pcfg & vbCrLf

                                    pm.ShowConfiguration2 oldPart

                                Else

                                    okSet = SetLength( _
                                        pm, pd, curL, pcfg)

                                    pm.ShowConfiguration2 pcfg
                                    pm.EditRebuild3

                                    e = 0
                                    w = 0
                                    pm.Save3 1, e, w

                                    pm.ShowConfiguration2 oldPart

                                    ch.ReferencedConfiguration = pcfg

                                    rep = rep & ch.Name2 & _
                                          " : " & _
                                          FormatMM(curL) & _
                                          " mm -> " & pcfg

                                    If Not okSet Then
                                        rep = rep & _
                                            " [SET FAILED]"
                                    End If

                                    rep = rep & vbCrLf

                                End If

                            End If

                        End If

                    End If

                End If

            End If

        Next i

    End If

    Status swTop, "STEP 4/4: final rebuild + save..."

    swSub.ShowConfiguration2 cfgName
    swSub.EditRebuild3

    e = 0
    w = 0
    swSub.Save3 1, e, w

    swTop.EditRebuild3

    e = 0
    w = 0
    swTop.Save3 1, e, w

    swSub.ShowConfiguration2 oldSub

    Status swTop, "READY"

    MsgBox "DONE " & cfgName & vbCrLf & vbCrLf & rep

    Exit Sub

EH:
    MsgBox "ERROR: " & Err.Description
End Sub

Private Function FindLenDim(m As Object) As Object
    Dim d As Object

    Set FindLenDim = Nothing
    Set d = Nothing

    On Error Resume Next

    Set d = m.Parameter