如何在工程图中体现比例和重量

dengdese

如何在工程图中体现比例和重量

'用来实现工程图中重量自动计算的程序
'    1、修改工程图模板，在模板中增加自定义特性--重量
'    2、修改工程图中标题栏定义，在标题栏中添加一个与自定义特性重量关联的变量文本
'    3、将本程序加入工程图模板
'
Public Sub AutoSave()
    ' Set a reference to the part document.
    ' This assumes a part document is active.
    Dim oDrawingDoc As DrawingDocument
    Set oDrawingDoc = ThisApplication.ActiveDocument
   
    '==============================================
    '自动计算重量
   ' Set a reference to the mass properties object.
    Dim oMassProps As MassProperties
    Dim oDocuments As DocumentsEnumerator
   
    Set oDocuments = oDrawingDoc.ReferencedFiles
   
    If oDocuments.Count = 0 Then
        '修改自定义特征
        Dim oPropSet1 As PropertySet
        Set oPropSet1 = oDrawingDoc.PropertySets.Item("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
        Dim oProp1 As Property
        Set oProp1 = oPropSet1.Item("重量")
        oProp1.Value = ""
      Exit Sub
    End If
   
    Dim oDocument As Document
    Set oDocument = oDocuments.Item(1)
   
    Debug.Print "====================================="
    If oDocument.DocumentType = kAssemblyDocumentObject Then
      Dim oAssDoc As AssemblyDocument
      Set oAssDoc = oDocument
      Set oMassProps = oAssDoc.ComponentDefinition.MassProperties
    Else
      If oDocument.DocumentType = kPartDocumentObject Then
        Dim oParDoc As PartDocument
        Set oParDoc = oDocument
        Set oMassProps = oParDoc.ComponentDefinition.MassProperties
      Else
         Exit Sub
      End If
    End If
   
    'Set oMassProps = oPresDoc '.ComponentDefinition.MassProperties
   
    ' Set the accuracy to medium.
    oMassProps.Accuracy = k_Medium
   
    Dim massdt As String
    Dim massd As Double
   
    massd = oMassProps.Mass
    massdt = Format(massd, "0.000")
    'MsgBox "总重: " & oMassProps.Mass
   
    '修改自定义特征
    Dim oPropSet As PropertySet
    Set oPropSet = oDrawingDoc.PropertySets.Item("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}")
    Dim oProp As Property
    Set oProp = oPropSet.Item("重量")
    oProp.Value = massdt
    '=========================================================
    '自动计算比例
    Dim oSheet As Sheet
    Set oSheet = oDrawingDoc.ActiveSheet
   
    If oSheet.DrawingViews.Count < 1 Then
      Exit Sub
    End If
      
    Dim oDrawingView As DrawingView
    Set oDrawingView = oSheet.DrawingViews.Item(1)
   
    Dim dScale As Double
    dScale = oDrawingView.Scale
   
    Dim dRatio As Double
    Dim strRatio As String
    If dScale < 1 Then
      dRatio = 1# / dScale
      dRatio = Format(dRatio, "0")
      strRatio = "1:" & dRatio
    Else
     dScale = Format(dScale, "0")
     strRatio = dScale & ":1"
    End If
    'MsgBox "比例：" & strRatio
    oDrawingDoc.PropertySets.Item("{D5CDD505-2E9C-101B-9397-08002B2CF9AE}").Item("比例").Value = strRatio
   
End Sub