BOM Scaling

Lets you scale the BOM size. Available only after you click the pan icon  in the upper left corner of an existing bill of materials in a part or assembly.

******************************************************************

no find API code of bom scaling. follow code is replace code.

********************************************************************

Private Sub eAsmFile()

    Dim Xls As Excel.Application, Rng As Range, oRng As Range

        Set Xls = GetObject(, "Excel.Application")

    Dim Path

        Path = Xls.ActiveWorkbook.Path & "\PDF\"

        ''

    Dim Sht As Worksheet, Str

        Set Sht = Xls.Worksheets("JB4715")

        Set Rng = Sht.Cells(1, "BH").CurrentRegion

    Dim SwApp As SldWorks.SldWorks, SwModel As ModelDoc2

        Set SwApp = Application.SldWorks

        Set SwModel = SwApp.ActiveDoc

    Dim sFileName

        ''

        SwApp.SetUserPreferenceIntegerValue swEdrawingsSaveAsSelectionOption, swEdrawingSaveSelected

    Dim nErrors As Long, nWarnings As Long

     ''

     'Dim fileConfig As String, fileDispName As String, fileOptions As Long

        ''

        For jj = 1 To Rng.Columns.Count

             Set oRng = Xls.Range(Rng(2, jj).Formula)

             Debug.Print oRng.Address

             Str = ""

             For ii = 1 To oRng.Rows.Count

                 Str = oRng(ii, 1) & Chr(10) & Str

             Next ii

             sFileName = Rng(1, jj) & ".eAsm"

             sFileName = Path & sFileName

''             Stop

             Debug.Print sFileName

             SwApp.SetUserPreferenceStringListValue swUserPreferenceStringListValue_e.swEmodelSelectionList, Str

             SwModel.Extension.SaveAs sFileName, swSaveAsCurrentVersion, swSaveAsOptions_Silent, Nothing, nErrors, nWarnings

        Next jj

End Sub

''

''

Private Sub del20160707()

   Dim Xls As Excel.Application, Rng As Range

       Set Xls = GetObject(, "Excel.Application")

   Dim Sht As Worksheet

       Set Sht = Xls.Worksheets("GeneralTable")

       Set Rng = Sht.Cells(5, "AK")

       ''Debug.Print Rng.Parent.Name

   Dim Str, tmp, ii, jj, Xx, Yy, Row

       Str = "材料明细表"

   Dim SwApp As SldWorks.SldWorks, SwModel As ModelDoc2, SwDraw As DrawingDoc

       Set SwApp = Application.SldWorks

       Set SwModel = SwApp.ActiveDoc

   Dim SwSelMgr As SelectionMgr

       Set SwSelMgr = SwModel.SelectionManager

   Dim sConfNames(0) As String, bVisible(0) As Boolean

   Dim SwAnn As Annotation, Pp

   Dim SwTextFormat As TextFormat

   Dim ConfArr, swConf As Configuration

       ConfArr = SwModel.GetConfigurationNames

   Dim SwBomFeat As BomFeature, SwTabAnn As TableAnnotation

   Dim SwBomTab As BomTableAnnotation, BomTab As BomTable

       ''

       'For ii = UBound(ConfArr) - 1 To UBound(ConfArr) - 1

       For ii = 0 To UBound(ConfArr)

           SwModel.ShowConfiguration2 ConfArr(ii)

           Set swConf = SwModel.GetActiveConfiguration

           tmp = SwModel.Extension.SelectByID2(Str, "BOMFEATURE", 0, 0, 0, False, 0, Nothing, 0)

           Set SwBomFeat = SwSelMgr.GetSelectedObject5(1)

           SwBomFeat.Configuration = swConf.Name

           ''

           sConfNames(0) = ConfArr(ii) 'ConfName

           bVisible(0) = True

           ConfNames = sConfNames

           SwBomFeat.SetConfigurations False, bVisible, ConfNames

           ''Debug.Print ii, SwBomFeat.Configuration, swConf.Name, SwBomFeat.Configuration = swConf.Name

           'Set SwBomTab = SwBomFeat

           Set SwBomTab = SwBomFeat.GetTableAnnotations(0)

           Set SwTabAnn = SwBomTab

           With SwTabAnn

               ''Debug.Print .Type, .Type

               For jj = 0 To .ColumnCount - 1

                    .Text(0, jj) = Rng(1, jj + 1)

                    'Rng(0, jj + 1) = Int(.GetColumnWidth(jj) * 1000)

                    .SetColumnWidth jj, Rng(0, jj + 1) / 1000, 0

               Next jj

               Set SwAnn = .GetAnnotation

               ''

               Xx = Rng(2, 1) / 1000

               Yy = Rng(2, 2) / 1000

               ''

               SwAnn.SetPosition Xx, Yy, 0

               ''

               For Row = 0 To .RowCount - 1

                    .SetRowHeight Row, 180 / 1000, 0

               Next Row

           End With

           Set SwTextFormat = SwAnn.GetTextFormat(0)

           With SwTextFormat

               '.CharHeight = 0.2 '200 / 1000

               '.TypeFaceName = "黑体"

           End With

           'SwAnn.SetTextFormat 0, False, swtextfomrat

           DigitsSwAnn SwTabAnn '

           'SwModel.EditRebuild3

       Next ii

End Sub

'*********************************