ļAutocadӦü(2)

ͼεԶ
翴һԶŵӣȥVBAһ˴ȦĹ

Ϊ:
'by gzy
'gzy@mjtd.com
Dim Nums As Integer
Sub Numbers()
Nums = 1
Dim keyWord As String
    ThisDrawing.Utility.InitializeUserInput 0, "y n"
    keyWord = ThisDrawing.Utility.GetKeyword(vbCrLf & "ǷȦ[(N)/(Y)][N]: ")
    
    If keyWord = "" Then
      keyWord = "N"
      Call Ncircle
    Else
      Call Cir
    End If
    
    If keyWord = "N" Then Call Ncircle
End Sub 


Sub Ncircle()
RETRY:
    Dim PPck1 As Variant, PPck2 As Variant
    Dim textobject(0) As AcadObject: Dim line1 As AcadLine: Dim line2 As AcadLine
    Dim ppt(0 To 2) As Double:  Dim Numbers1 As String: Dim Inserpt(0 To 2) As Double
    
     On Error Resume Next
     PPck1 = ThisDrawing.Utility.GetPoint(, "ָ")
         If Err <> 0 Then
                Err.Clear
                ThisDrawing.Utility.Prompt " ûָ,˳"
                Exit Sub
          End If
     PPck2 = ThisDrawing.Utility.GetPoint(, "ָλã")
        If Err <> 0 Then
                Err.Clear
                ThisDrawing.Utility.Prompt " ûָλ,˳"
                Exit Sub
          End If
  Set line1 = ThisDrawing.ModelSpace.AddLine(PPck1, PPck2)
  TextHeight = ThisDrawing.GetVariable("dimtxt") 'ϵͳָ߶
  
  If pd(PPck1, PPck2) = True Then
     ppt(0) = PPck2(0) - 2 * TextHeight:   ppt(1) = PPck2(1):    ppt(2) = PPck2(2)
  Else
     ppt(0) = PPck2(0) + 2 * TextHeight:   ppt(1) = PPck2(1):    ppt(2) = PPck2(2)
  End If
  
  Set line2 = ThisDrawing.ModelSpace.AddLine(PPck2, ppt)
  line2.Lineweight = acLnWt030
  ThisDrawing.SendCommand "_LWDISPLAY" & vbCr & "on" & vbCr   'ʾ߿
      
  Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf & "(һΪ" & Nums - 1 & ")" & "[" & Nums & "]:")
  If Numbers1 = "" Then Numbers1 = Nums
  If pd(PPck1, PPck2) = True Then
      Inserpt(0) = ppt(0) + 0.5 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2)
  Else
      Inserpt(0) = ppt(0) - 1.5 * TextHeight: Inserpt(1) = ppt(1) + 0.2 * TextHeight: Inserpt(2) = ppt(2)
  End If
     Set textobject(0) = ThisDrawing.ModelSpace.AddText(Numbers1, Inserpt, TextHeight)
    Nums = Numbers1 'ʹʾһŹ
    Nums = Nums + 1
GoTo RETRY
End Sub

Sub Cir()
RETRY:
    Dim PPck1 As Variant, PPck2 As Variant
    Dim textobject(0) As AcadObject: Dim line1 As AcadLine: Dim Cirobj As AcadCircle
    Dim ppt(0 To 2) As Double:  Dim Numbers1 As String: Dim Inserpt(0 To 2) As Double
    
     On Error Resume Next
     PPck1 = ThisDrawing.Utility.GetPoint(, "ָ")
         If Err <> 0 Then
                Err.Clear
                ThisDrawing.Utility.Prompt " ûָ,˳"
                Exit Sub
          End If
     PPck2 = ThisDrawing.Utility.GetPoint(, "ָλã")
        If Err <> 0 Then
                Err.Clear
                ThisDrawing.Utility.Prompt " ûָλ,˳"
                Exit Sub
          End If
  Set line1 = ThisDrawing.ModelSpace.AddLine(PPck1, PPck2)
  TextHeight = ThisDrawing.GetVariable("dimtxt") 'ϵͳָ߶
  ppt(0) = PPck2(0) + 0.7 * TextHeight: ppt(1) = PPck2(1) - 0.5 * TextHeight: ppt(2) = PPck2(2)
  Set Cirobj = ThisDrawing.ModelSpace.AddCircle(PPck2, TextHeight)
    PPck2 = Cirobj.IntersectWith(line1, acExtendNone) '󽻵
    line1.EndPoint = PPck2   '
      
    Numbers1 = ThisDrawing.Utility.GetString(0, vbCrLf & "(һΪ" & Nums - 1 & ")" & "[" & Nums & "]:")
    If Numbers1 = "" Then Numbers1 = Nums
    If Len(Numbers1) = 2 Then
      Inserpt(0) = ppt(0) - 1.4 * TextHeight: Inserpt(1) = ppt(1) + 0.01 * TextHeight: Inserpt(2) = ppt(2)
    End If
    If Len(Numbers1) = 1 Then
     Inserpt(0) = ppt(0) - TextHeight: Inserpt(1) = ppt(1) + 0.01 * TextHeight: Inserpt(2) = ppt(2)
    End If
    
    Set textobject(0) = ThisDrawing.ModelSpace.AddText(Numbers1, Inserpt, TextHeight)
    
    Nums = Numbers1 'ʹʾһŹ
    Nums = Nums + 1
GoTo RETRY
End Sub
Function pd(p1 As Variant, p2 As Variant) As Boolean 'жбʣԱȷλ
    If p1(0) > p2(0) And p1(0) > p2(0) Then
      pd = True
    Else
      pd = False
    End If
End Function

Ҵطתģǲ֪ΪʲôͼƬûʾҼ£
