[VBA程序]：求教 多次执行循环跳出问题

星际尘埃

代码说明：这段小代码我是写在vbaide的模块中的，想实现在vbaide界面点F5后可以进入CAD,点一个有长度属性的obj（假定点直线），然后点一个文字，把直线的长度值(小数点后保留3位)赋值给这个text，并且可以循环多次直到按esc键

问题： 在loop 后添加

            Until Checkkey(vk_escape) = True  后只执行一次就跳出循环了，不要这个语句又跳不出循环

请帮忙指正一下，卡在这儿不知道怎么做了 谢谢了

附代码如下：

Public Const vk_escape = &H1B
Public Declare Function Getasynckeystate Lib "user32" (ByVal vkey As Long) As Integer

Public Function Checkkey(lngkey As Long) As Boolean
If Getasynckeystate(lngkey) Then
Checkkey = True
Else
Checkkey = False
End If
End Function

Sub CHANGDU()
Dim Sourceobj As AcadObject     '有长度属性的obj
Dim Basepnt As Variant      
Dim Destobj As AcadText    '文字
Dim value1  As Single          '长度值
Dim Value2 As Single           '长度值 保留位数之后的
Dim Objselected As Integer   '循环需要
Dim unit As Long
Dim ws As Integer                    '需要保留的小数点后位数

On Error Resume Next
Objselected = 1

Do  '进入循环
Retry:
    ThisDrawing.Utility.GetEntity Sourceobj, Basepnt, "选择线（有长度属性的，圆弧则应该转换成多段线后在用本程序）"
    '选择有长度属性的obj 主要是直线或则多段线
      
       If Sourceobj Is Nothing Then     '如果没有选择则重新选则
       GoTo Retry
       Else
       End If
        
    ws = 3
    unit = acDecimal
    value1 = Sourceobj.Length
    Value2 = ThisDrawing.Utility.RealToString(value1, unit, ws)  '保留3位有效小数位
   
Gettext:
    ThisDrawing.Utility.GetEntity Destobj, Basepnt, "选择文字"
      
       If Destobj Is Nothing Then    '如果没有选择则重新选则
       GoTo Gettext
       Else
       End If

     Destobj.TextString = Value2

Loop Until Checkkey(vk_escape) = True    '问题语句 位置*-*3
ExitSub:
End Sub

雪山飞狐(lzh)

用错误机制
按下Esc会引发错误的，

星际尘埃

先谢谢斑竹   我加了Until Checkkey(vk_escape) = True后跳出并不是因为按了esc
我我希望能够运行一次就可以 点一个直线，赋值给一个文字，再点一个直线，赋值给一个文字
这样重复做很多次直到我不需要这么做了，然后按esc跳出来，现在问题是我用这段代码可以执行一次赋值，之后没有按esc键就返回vbaide界面了，不能重复做
(那段关于esc的函数是从书上抄的)
如果我不用 Until Checkkey(vk_escape) = True  
的话该怎么在我想跳出时跳出运行啊 谢谢

雪山飞狐(lzh)

Sub CHANGDU()
On Error GoTo ErrHandle
Dim Sourceobj As AcadObject '有长度属性的obj
Dim Basepnt As Variant
Dim Destobj As AcadText '文字
Dim value1 As Single '长度值
Dim Value2 As Single '长度值 保留位数之后的
Dim Objselected As Integer '循环需要
Dim unit As Long
Dim ws As Integer '需要保留的小数点后位数

Objselected = 1

Do While True '进入循环

ThisDrawing.Utility.GetEntity Sourceobj, Basepnt, "选择线（有长度属性的，圆弧则应该转换成多段线后在用本程序）"
'选择有长度属性的obj 主要是直线或则多段线


ws = 3
unit = acDecimal
value1 = Sourceobj.length
Value2 = ThisDrawing.Utility.RealToString(value1, unit, ws) '保留3位有效小数位

ThisDrawing.Utility.GetEntity Destobj, Basepnt, "选择文字"

Destobj.TextString = Value2

Loop '问题语句 位置
ErrHandle:
End Sub

星际尘埃

谢谢版主的无私帮助
能用了
不过选东西的时候如果没有选到就会停止运行了，只能小心点了
感谢


在我第一楼的代码中的dim语句完了后使用msgbos发现 Checkkey(vk_escape) 从程序运行开始就是true (为什么我没有按esc键而Checkkey(vk_escape)＝true到现在为止我还不知道原因)
在参考的那个使用api函数判断esc键的程序里面找了半天，找到一句 err.clear
加了进去程序好像就可以用了
       If Sourceobj Is Nothing Then
       Err.Clear
       GoTo Retry
       Else
       End If
难道err会影响esc键值的判断吗？