[分享] 粗糙度标注程序

gzy

欢迎提出意见！
’gzy@mjtd.com
Private Sub UserForm_Initialize()       ‘ 界面初始化
    FF.AddItem "用任何方法加工"
    FF.AddItem "  经过切削加工"
    FF.AddItem "不经过切削加工"
    FF.Value = "  经过切削加工"
    JD.AddItem "0.2"
    JD.AddItem "0.4"
    JD.AddItem "0.8"
    JD.AddItem "1.6"
    JD.AddItem "3.2"
    JD.AddItem "6.3"
    JD.AddItem "12.5"
    JD.AddItem "25"
    JD.AddItem "50"
    JD.Value = "6.3"
    QY.AddItem ""
    QY.AddItem "其余"
    QY.AddItem "全部"
    QY.Value = ""
    SJ.Text = "6.3"                              
End Sub

Private Sub JD_Change()      ' 粗糙度
  SJ.Text = JD.Value
End Sub

Private Sub QY_Change()      ' 附加文本
  WZ.Text = QY.Value
End Sub

Private Sub FF_Change()
    If FF.Value = "  经过切削加工" Then
       Image1.Picture = LoadPicture("d:\bzj\tu\czd\b.bmp"): n = 2
    ElseIf FF.Value = "用任何方法加工" Then
       Image1.Picture = LoadPicture("d:\bzj\tu\czd\a.bmp"): n = 1
    ElseIf FF.Value = "不经过切削加工" Then
       Image1.Picture = LoadPicture("d:\bzj\tu\czd\c.bmp"): n = 3
    End If
End Sub

‘点击按键1后即开始计算相关尺寸，形成相应的块。当程序运行到插入指令时，在作图区中可以隐隐约约看到该块隨鼠标移动着，当用户用鼠标指定标注位置及旋转角度时，即完成该块的插入。

Private Sub CommandButton1_Click()
    JD = Val(JD.Value)
    CZD.Hide
    ThisDrawing.SendCommand "filedia 0 "
    Call CR
    ThisDrawing.SendCommand "filedia 1 "
End Sub

Private Sub CR()                  ‘ 粗糙度智能标注模块
    Dim pt0(0 To 2) As Double
    Dim pt1(0 To 2) As Double
    Dim pt2(0 To 2) As Double
    Dim pt3(0 To 2) As Double
    Dim pt4(0 To 2) As Double
    Dim l1 As AcadLine
    Dim l2 As AcadLine
    Dim l3 As AcadLine
    Dim c As AcadCircle
    Set q1 = ThisDrawing.Blocks.Add(pt0, "b2")
    pt0(0) = 0
    pt0(1) = 0
    pt1(0) = 14 * Cos(120 * con)
    pt1(1) = 14 * Sin(120 * con)
    pt2(0) = 14 * Cos(60 * con)
    pt2(1) = 14 * Sin(60 * con)
    pt3(0) = 28 * Cos(60 * con)
    pt3(1) = 28 * Sin(60 * con)
    pt4(0) = 0
    pt4(1) = 2 * pt1(1) / 3
    ThisDrawing.SendCommand "-layer S  0" + vbCrLf
    Set l1 = q1.AddLine(pt0, pt1)
    Set l3 = q1.AddLine(pt0, pt3)
    If n = 2 Then
        Set l2 = q1.AddLine(pt1, pt2)
    ElseIf n = 3 Then
        Set c = q1.AddCircle(pt4, 4)
    End If
    ThisDrawing.SendCommand "-insert b2" + vbCrLf _
                            + "s" + vbCrLf + "1" + vbCrLf      ' 插入块
    Dim x0, y0, a                                ' 记录插入点及旋转角度
    Open "p.scr" For Output As #1
        Print #1, "(setq e1 (entlast))"
        Print #1, "(setq elist (entget e1))"
        Print #1, "(setq p0 (assoc 10 elist))"
        Print #1, "(setq x0 (cadr p0))"
        Print #1, "(setq y0 (caddr p0))"
        Print #1, "(setq a (cdr (assoc 50 elist)))"
        Print #1, "(setq x0 (rtos x0 2 3))"
        Print #1, "(setq y0 (rtos y0 2 3))"
        Print #1, "(setq a (rtos a 2 6))"
        Print #1, "(setq f (Open " + Chr(34) + "pp.txt" + Chr(34) _
+ " " + Chr(34) + "w" + Chr(34) + "))"
        Print #1, "(write-line x0 f)"
        Print #1, "(write-line y0 f)"
        Print #1, "(write-line a f)"
        Print #1, "(Close f)"
    Close #1
    ThisDrawing.SendCommand "script p" + Chr(13)
    ThisDrawing.SendCommand "explode " _
                             + "last" + vbCrLf + vbCrLf   ' 炸开块
    ThisDrawing.SendCommand "-purge " _
                             + "b " _
                             + "b2" + vbCrLf _
                             + "Y "                     ' 删除块
   
' 文本标注部分
    Open "pp.txt" For Input As #1                         ' 读出数据
        Input #1, x0
        Input #1, y0
        Input #1, a
    Close #1
    a = a / con
    Open "p.scr" For Output As #1
        If (a <= 90 Or a > 330) Then
            x0 = LTrim(Str(x0 + 16 * Cos((a + 110) * con)))
            y0 = LTrim(Str(y0 + 16 * Sin((a + 110) * con)))
            a = LTrim(Str(a))
        ElseIf (a > 90 And a <= 150) Or (a > 270 And a <= 330) Then
            Dim rc
            rc = MsgBox("此处不能直接标注", 48, " 系统提示您")
            Close
            For i = 1 To 5
            ThisDrawing.SendCommand "u "
            Next i
            Exit Sub
        ElseIf (a > 150 Or a <= 270) Then
            x0 = LTrim(Str(x0 + 20 * Cos((a + 80) * con)))
            y0 = LTrim(Str(y0 + 20 * Sin((a + 80) * con)))
            a = LTrim(Str(a + 180))
        End If
        Print #1, "text"
        Print #1, "S"
        Print #1, "1"
        Print #1, x0; ","; y0
        Print #1, "5"
        Print #1, a
        Print #1, JD
        If QY <> "" Then
            x0 = LTrim(Str(x0 + 36 * Cos((a + 200) * con)))
            y0 = LTrim(Str(y0 + 36 * Sin((a + 200) * con)))
            Print #1, "text"
            Print #1, "S"
            Print #1, "2"
            Print #1, x0; ","; y0
            Print #1, "10"
            Print #1, a
            Print #1, QY
        End If
    Close #1
    ThisDrawing.SendCommand "script p" + Chr(13)
End Sub

vincentver

运行不了啊

qianglcq

运行不了啊

FANGZHENG158

运行不了啊

xiaoshi112

运行不了啊。。。。为什么？？？？？

bill.pu

看不到東西;为什么？？？？？

xiaoshi112

为什么看不到啊