如何用vba在cad中实时显示角度的变化？

12QQQ

如题，在cad中画一个 ∠ ，旁边有文字显示角度值，如果选中角的顶点并移动鼠标，如何让文字实时的显示角度呢？

sealive_leafage

- h, H8 B- b+ n$ q1 B7 G$ {
1 H! |- h+ n* P* w问题的难点在于在CAD中如何动态实时获得鼠标点的坐标，网上收集了些资料楼主可以体会一下；获得坐标值后则可以实现楼主要求的效果；详细参考：http://tiancao.net/blogview.asp?logID=214
CAD VBA实现橡皮筋直线、圆

首先是计时控件，然后是实时捕捉鼠标的屏幕位置，然后是转换获得CAD当前试图鼠标所在的位置坐标，然后才是实时绘制直线或圆。
VBA中不可直接使用vb的timer控件，我们可以调用独立的xTimer控件。
控件下载：
http://www.tiancao.net/flashget.asp?dizhi=http://www.tiancao.net/attachments/month_0707/qnft_XTimers.rar
. n* _4 h& m# `0 W
% O# t, e# f+ \) ^2 {, s/ T然后是使用API函数GetCursorPos获得当前鼠标的屏幕坐标。
6 e7 v: T* S& n" f* j然后通过读取CAD系统变量viewSize荷Screensize分别得到当前试图的CAD高度和当前视口的屏幕尺寸(屏幕分辨率的像素).然后得到CAD实际尺寸和屏幕像素的比值。
精确度于鼠标的频率快慢有关系
) L" A) X& F" V
'获取CAD坐标系统和屏幕像素的比值
. k6 k$ Z: J! K! O  j, E! MFunction ViewScreen() As Double
* W* V. O1 y6 G7 b  u+ P$ e. \    Dim ScreenSize As Variant
    ScreenSize = ThisDrawing.GetVariable("screensize") '当前视口的屏幕宽度和高度
    Dim H As Variant
, }: g4 ^+ O/ I0 W; L: _' \7 `    H = ThisDrawing.GetVariable("viewsize") '当前视图图形的实际高度
0 d3 Z# Q% V4 t* ]$ z+ }/ E1 z    ViewScreen = Abs(H / ScreenSize(1))
End Function
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
6 O6 V8 _; O* c6 _% M% l
5 M: k' b- [6 D, I' Y  g实时获得鼠标的屏幕坐标，然后通过屏幕尺寸和cad实际尺寸的比值，计算出鼠标当前的cad坐标。
" D8 Q8 v! v' Z% S然后在基点和鼠标坐标之间绘制直线或圆。
( m7 P4 k9 G: N0 A值得注意的是，屏幕坐标的是以屏幕的左上角为原点的。而cad的世界坐标是以右下角为原点的。

'得到鼠标屏幕坐标

, ]/ d8 |# u# A. t4 v, xPrivate Type POINTAPI
* u5 D+ [1 H+ l2 `# Y: s/ _) m    x As Long
# Q: G8 `4 c1 j3 D5 u2 k6 s0 k5 z    Y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Dim CAD_Point1 As Variant
Dim CAD_Point2 As Variant
Dim ScreenPoint1 As POINTAPI
Dim ScreenPoint2(1) As Long
Dim BiLi As Double
'获取CAD坐标系统和屏幕像素的比值
Function ViewScreen() As Double
    Dim ScreenSize As Variant
3 s0 _4 X9 H! C& B' M! b    ScreenSize = ThisDrawing.GetVariable("screensize") '当前视口的屏幕宽度和高度
$ W3 y' Z- R& @7 i! N) s    Dim H As Variant
& L6 \0 Z1 e" z6 E' H+ c! q3 q    H = ThisDrawing.GetVariable("viewsize") '当前视图图形的实际高度
    ViewScreen = Abs(H / ScreenSize(1))
. m& ?/ k8 n! m8 @4 n5 j7 {End Function
$ }/ _" y' Z3 Q+ C! `'通过CAD坐标计算屏幕坐标
Sub GetScreenPoint()
    BiLi = ViewScreen
( l* i0 G6 W/ L    CAD_Point1 = ThisDrawing.Utility.GetPoint(, "先指定一个点:") '获得鼠标所在位置的CAD坐标
- m6 V" A' e. M8 p3 V* Z. D    ThisDrawing.ModelSpace.AddPoint CAD_Point1
5 @; b! k  l6 N2 Y4 V- t    GetCursorPos ScreenPoint1   '通过api直接获得鼠标所在位置的屏幕坐标
' F6 V2 x6 {  D  F) ]( j8 q    MsgBox "屏幕坐标：" & ScreenPoint1.x & " / " & ScreenPoint1.Y
    MsgBox "对应的CAD坐标：" & CAD_Point1(0) & " / " & CAD_Point1(1)
. D( }1 V2 n( N! R/ y    '以上获得了CAD坐标和屏幕坐标的对应关系,下面就可以计算了
$ u$ Q' |8 V9 U. |5 v$ e   
' s$ W. [* |1 D1 B& g6 m, ?* h+ X2 \    CAD_Point2 = ThisDrawing.Utility.GetPoint(CAD_Point1, "指定下一点,这个点将通过计算得到屏幕坐标:")
   
! O/ m0 K$ g1 }& f    ScreenPoint2(0) = Int(ScreenPoint1.x + (CAD_Point2(0) - CAD_Point1(0)) / BiLi)
3 R, Y" G3 f0 z: M& a    ScreenPoint2(1) = Int(ScreenPoint1.Y - (CAD_Point2(1) - CAD_Point1(1)) / BiLi)
: Z/ |" t) W1 n: R    MsgBox "屏幕坐标：" & ScreenPoint2(0) & " / " & ScreenPoint2(1)
* x5 t* w( \. I7 b  ^- j/ `+ I    '为了验证计算坐标，将CAD窗口在屏幕上移动到该点，看看效果吧。
/ O/ W, R" V/ x# \    ThisDrawing.Application.WindowState = acNorm
# k9 H6 P: M. {1 \5 X7 g) d- N) l    ThisDrawing.Application.WindowLeft = ScreenPoint2(0)
    ThisDrawing.Application.WindowTop = ScreenPoint2(1)
   
  l. l  o; P1 v; K) z+ V# k$ G   
End Sub
& D& D: _2 ^& a'   通过屏幕坐标计算CAD坐标
Sub GetCAD_Point()
+ Z' S. n" ?7 p, l) T: [1 z. L    BiLi = ViewScreen
0 @5 I2 o$ L* C, v4 b4 Y    CAD_Point1 = ThisDrawing.Utility.GetPoint(, "先指定一个点:") '获得鼠标所在位置的CAD坐标
* v" j% r9 J. \0 b/ D( p3 p    ThisDrawing.ModelSpace.AddPoint CAD_Point1
) @1 Y9 h/ {  T9 G# V; r8 Y    GetCursorPos ScreenPoint1   '通过api直接获得鼠标所在位置的屏幕坐标
( I9 v' m# \9 ^3 r; l+ B    MsgBox "屏幕坐标：" & ScreenPoint1.x & " / " & ScreenPoint1.Y
% H; R) L! T9 ?. |6 {    MsgBox "对应的CAD坐标：" & CAD_Point1(0) & " / " & CAD_Point1(1)
! L3 Q& C( E$ X) |) G5 d) U# L8 F    '以上获得了CAD坐标和屏幕坐标的对应关系,下面就可以计算了
   
    Dim ScreenPoint3 As POINTAPI
    GetCursorPos ScreenPoint3
' @' [" e' b' }, I   
    Dim CAD_Point3(2) As Double
    '计算cad坐标
    CAD_Point3(0) = CAD_Point1(0) + BiLi * (ScreenPoint3.x - ScreenPoint1.x)
* A' k; d; p* J    CAD_Point3(1) = CAD_Point1(1) - BiLi * (ScreenPoint3.Y - ScreenPoint1.Y)
    CAD_Point3(2) = 0
( Z5 A+ y, ?  K5 j    MsgBox "屏幕坐标：" & CAD_Point3(0) & " / " & CAD_Point3(1)
    '为了验证计算坐标，将画一条直线，看看效果吧。
    ThisDrawing.ModelSpace.AddLine CAD_Point1, CAD_Point3
End Sub

12QQQ

非常感谢你！我要把你讲的好好消化消化！！