[VBA程序]：公差编辑工具

guanzhangyang

参考一本机械方面的期刊（李忠群）做来的。
Private Sub ComboBox1_Change()
  Select Case UserForm.ComboBox1.value
  Case "无公差"
  UserForm.TextBox1.Enabled = False
  UserForm.TextBox2.Enabled = False
  UserForm.TextBox3.Enabled = False
  UserForm.TextBox3.BackColor = UserForm.BackColor
  UserForm.TextBox1.BackColor = UserForm.BackColor
  UserForm.TextBox2.BackColor = UserForm.BackColor
  Case "对称公差"
  UserForm.TextBox1.Enabled = False
  UserForm.TextBox1.BackColor = UserForm.BackColor
  UserForm.TextBox2.Enabled = True
  UserForm.TextBox2.BackColor = UserForm.TextBox5.BackColor
  UserForm.TextBox3.Enabled = False
  UserForm.TextBox3.BackColor = UserForm.BackColor
   Case "极限偏差"
  UserForm.TextBox1.Enabled = False
  UserForm.TextBox1.BackColor = UserForm.BackColor
  UserForm.TextBox2.Enabled = True
  UserForm.TextBox2.BackColor = UserForm.TextBox5.BackColor
  UserForm.TextBox3.Enabled = True
  UserForm.TextBox3.BackColor = UserForm.TextBox5.BackColor
  Case "极限尺寸"
  UserForm.TextBox1.Enabled = False
  UserForm.TextBox1.BackColor = UserForm.BackColor
  UserForm.TextBox2.Enabled = True
  UserForm.TextBox2.BackColor = UserForm.TextBox5.BackColor
  UserForm.TextBox3.Enabled = True
  UserForm.TextBox3.BackColor = UserForm.TextBox5.BackColor
  Case "基本偏差"
  UserForm.TextBox1.Enabled = False
  UserForm.TextBox1.BackColor = UserForm.BackColor
  UserForm.TextBox2.Enabled = False
  UserForm.TextBox2.BackColor = UserForm.BackColor
  UserForm.TextBox3.Enabled = False
  UserForm.TextBox3.BackColor = UserForm.BackColor
  Case "用户定义"
  UserForm.TextBox1.Enabled = True
  UserForm.TextBox1.BackColor = UserForm.TextBox5.BackColor
  UserForm.TextBox2.Enabled = True
  UserForm.TextBox2.BackColor = UserForm.TextBox5.BackColor
  UserForm.TextBox3.Enabled = True
  UserForm.TextBox3.BackColor = UserForm.TextBox5.BackColor
  End Select
  End Sub
Private Sub CommandButton1_Click() '编辑完毕
UserForm.hide
End Sub

Private Sub CommandButton2_Click()
End
End Sub

Private Sub UserForm_initialize() '对话框初始化
UserForm.ComboBox1.AddItem "无公差", 0
UserForm.ComboBox1.AddItem "对称公差", 1
UserForm.ComboBox1.AddItem "极限偏差", 2
UserForm.ComboBox1.AddItem "极限尺寸", 3
UserForm.ComboBox1.AddItem "基本尺寸", 4
UserForm.ComboBox1.AddItem "用户定义", 5
UserForm.ComboBox1.value = "无公差"
UserForm.TextBox1.Enabled = False
UserForm.TextBox1.BackColor = UserForm.BackColor
UserForm.TextBox2.Enabled = False
UserForm.TextBox2.BackColor = UserForm.BackColor
UserForm.TextBox3.Enabled = False
UserForm.TextBox3.BackColor = UserForm.BackColor
End Sub

Public Function simplify(dimtext, dstyle) '按系统设置的精度要求，对标注尺寸进行处理
  If dstyle = 4 Then
    dimdec = ThisDrawing.GetVariable("dimadec")
  Else
    dimdec = ThisDrawing.GetVariable("dimdec")
  End If
  seyle = "."
   If dimdec > 0 Then
      Do While dimdec > 0
        style = style + "#"
        dimdec = dimdec - 1
      Loop
      simplify = Format(dimtext, style)
    Else
       simplify = CInt(dimtext)
   End If
End Function
Public Function detol(dimnm, dimtp, dimtm, textpre, textsuf) '分解公差各部分
  dimnm = Left(dimnm, Len(dimnm) - Len(textsuf))
  dimnm = Right(dimnm, Len(dimnm) - Len(textsuf))
If InStr(dimnm, "%%p") <> 0 Then   '采用对称公差标注时
    dimnum = Left(dimnm, InStr(dimnm, "%%p") - 1)
    Else
      pos1 = InStr(dimnm, "{")
      If pos1 > 0 Then
         dimnm = Left(dimnm, pos1 - 1)
      End If
End If
      detol = dimnm
End Function
Public Function gentol(Text, tp, tm, prefix, profix, code) '将名义尺寸、上、下偏差等组合出公差
Dim obj1 As AcadEntity
textsize = ThisDrawing.GetVariable("dimtxt")
tolsize = 0.6 * textsize
Text = prefix + Text
If Abs(tp) = Abs(tm) Then
   If tp = 0 Then  '没有公差时
     gentol = Text
    Else
      If Abs(tp) < 1 Then
      gentol = Text + "%%p0" + Trim(Str(Abs(tp)))
      Else: gentol = Text + "%%p" + Trim(Str(Abs(tp)))
    End If
  End If
Else
   Select Case tp
     Case ls > 0
     If tp < 1 Then
       tp = "+0" + Trim(Str(tp))
      Else: tp = "" + Trim(Str(tp))
      End If
      Case ls = 0
        tp = "0"
      Case ls < 0
        If Abs(tp) < 1 Then
          tp = Trim(Str(Abs(tp)))
          tp = "-0" + tp
          Else: tp = Trim(Str(tp))
          End If
          End Select
Select Case tm
   Case ls > 0
     If tm < 1 Then
        tm = "+0" + Trim(Str(tm))
     Else: tm = "+" + Trim(Str(tm))
     End If
     Case ls = 0
       tm = "0"
       Case ls < 0
        If Abs(tm) < 1 Then
          tm = Trim(Trim(Abs(tm)))
          tm = "-0" + tm
        Else: tm = Trim(Str(tm))
        End If
        End Select
        gentol = Text + "{\h" + tolsize + ";\s" + tp + "" + tm + ";}" + profix
    End If
    End Function
    Public Sub dimedit() '公差编辑
      Dim obj1 As AcadEntity
      Dim curobj As AcadDimension
      Do While code = 0
        On Error Resume Next
        ThisDrawing.Utility.GetEntity obj1, pnt1, "请选择要标注的尺寸"
          If Err.Number = 0 Then
          Select Case obj1.ObjectName ' 判断标注类型
            Case "AcDbRotatedDimension"
              code = 1
            Case "AcDbAlignedDimension"
              code = 1
            Case "AcDbLinearDimension"
              code = 1
            Case "AcDbDiametricDimension"
              code = 2
            Case "AcDbRadialDimension"
              code = 3
           Case "AcDb2LineAngularDimension", "AcDb3PointAngularDimension"
              code = 4
          End Select
          Else
            Err.Clear
          End If
          Loop
          Set curobj = obj1
          UserForm.TextBox1.Text = simplify(curobj.Measurement, code)
          Select Case curobj.ToleranceDisplay
          Case "actolnone"
             UserForm.ComboBox1.value = "无公差"
          Case "actolactollimitsdeviation"
             UserForm.ComboBox1.value = "极限偏差"
          Case "actoactolimits"
             UserForm.ComboBox1.value = "极限尺寸"
          Case "actolsymmetrical"
             UserForm.ComboBox1.value = "对称公差"
          Case "actolbasic"
             UserForm.ComboBox1.value = "基本尺寸"
          End Select
  UserForm.TextBox2.Text = Format(curobj.ToleranceUpperLimit, "0.#")
  UserForm.TextBox3.Text = Format(curobj.ToleranceLowerLimit, "0.#")
       UserForm.TextBox4.Text = curobj.TextPrefix
       UserForm.TextBox5.Text = curobj.TextSuffix
       If curobj.TextOverride = "" Then '未使用文字替代时，从测量标注测量值获得对话框初始值
       UserForm.TextBox1.Text = simplify(curobj.Measurement, code)
       If code = 4 Then UserForm.TextBox1.Text = simplify(curobj.Measurement * 180 / pi, code)
         Else '使用文字替代时，从替代字符串中分解出对话框初始值
          UserForm.ComboBox1.value = "用户定义"
          temp = UCase(Trim(cruobj.TextOverride))
           UserForm.TextBox1.Text = detol(temp, UserForm.TextBox2.Text, UserForm.TextBox3. _
           Text, UserForm.TextBox4.Text, UserForm.TextBox5.Text)
       End If
       UserForm.Show
       If UserForm.TextBox4.Text = "" Then '去掉前缀和后缀
        curobj.TextPrefix = ""
        End If
      If UserForm.TextBox5.Text = "" Then
        curobj.TextSuffix = ""
        End If
       curobj.TextPrefix = UserForm.TextBox4.Text
       curobj.TextSuffix = UserForm.TextBox5.Text
       curobj.ToleranceUpperLimit = UserForm.TextBox2.Text
       curobj.ToleranceLowerLimit = UserForm.TextBox3.Text
       curobj.TextOverride = ""
       Select Case UserForm.ComboBox1.value
       Case "无公差"
         curobj.ToleranceDisplay = acTolNone
       Case "极限偏差"
         curobj.ToleranceDisplay = acTolDeviation
       Case "极限尺寸"
         curobj.ToleranceDisplay = acTolLimits
       Case "对称公差"
         curobj.ToleranceDisplay = acTolSymmetrical
       Case "基本尺寸"
         curobj.ToleranceDisplay = acTolvasic
       Case "用户定义"
         curobj.TextOverride = gentol(UserForm.TextBox1.Text, _
         UserForm.TextBox2.Text, UserForm.TextBox3.Text, _
         UserForm.TextBox4.Text, UserForm.TextBox5.Text, code)
       End Select
       curobj.Update
       curobj.Visible = True
  End Sub