三维 动态仿真 vba编程 运行后 鼠标会闪动 请问一下 有没有好的办法解决 代码如下

liaoqt

8 _% d: V) m6 i* V& t6 Q/ U
Option Explicit
) y- T6 t8 }* ^Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
( f2 }( h# H( [  m0 y  `Public Sub test()
( b; ^1 b8 f& o1 R6 S6 ^1 {    Dim Boxobj  As Acad3DSolid
7 }! W" R  W" k: I8 `    Dim cylinderobj As Acad3DSolid
- e" g3 W7 i# P& I2 c4 Z    Dim Ptcen(2) As Double
! [6 n+ {3 O0 q& a$ c# I    Dim Heigth As Double, Length As Double, Width As Double, Radius As Double
$ m( E+ n! w/ P) X2 u    Dim pt1(2) As Double
$ Q' l, F- ?7 L7 v5 m2 e    pt1(0) = 12: pt1(1) = 0: pt1(2) = 0
    Dim sset As AcadSelectionSet
    Dim Objentity As AcadEntity
    Set sset = ThisDrawing.SelectionSets.Add("NewSSet")
    sset.Select acSelectionSetAll
$ ~3 h7 M( h# D0 D1 ^' N/ [        For Each Objentity In sset
            Objentity.Delete
        Next
    sset.Delete
    With ThisDrawing
! e) c2 G1 C- k4 c4 j' `
# A0 [$ x% o$ ]" ~, H+ n* d        Ptcen(0) = 0: Ptcen(1) = -57: Ptcen(2) = -40:
        Length = 30: Width = 6: Heigth = 100
        Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)
        Boxobj.color = 28
6 y1 @- N- I  r% ?$ [& i# t( Z        Ptcen(0) = 0: Ptcen(1) = 57: Ptcen(2) = -40:
        Length = 30: Width = 6: Heigth = 100
        Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)
        Boxobj.color = 28
- m0 H/ [' A) `8 [5 M$ G6 e, g
- Z. B, J0 `6 S3 ?" c+ Q* K        Ptcen(0) = 0: Ptcen(1) = 0: Ptcen(2) = 0:
! |2 r5 o" I2 G        Length = 10: Width = 10: Heigth = 10: Radius = 3
        Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)
3 X6 [5 h6 _% `& k        Set cylinderobj = .ModelSpace.AddCylinder(Ptcen, Radius, Heigth)
6 U$ }& J7 a1 B2 Y2 ^9 u        cylinderobj.Rotate3D Ptcen, pt1, 90 * 3.1415926 / 180
  s8 ]% E% B1 ]2 w7 k( Y$ E        Boxobj.Boolean acSubtraction, cylinderobj
1 [( G7 E! K/ B; }0 E! o# p        Boxobj.color = 1
        Radius = 2.8
, ]4 ~$ G8 M8 |; f8 g        Heigth = 120
3 S7 {# q: [5 r+ Y  J; D; P, `% j2 h        Set cylinderobj = .ModelSpace.AddCylinder(Ptcen, Radius, Heigth)
        cylinderobj.Rotate3D Ptcen, pt1, 90 * 3.1415926 / 180
, `( |8 J. R1 H8 Q6 O3 _5 a% w# G' e2 |        cylinderobj.color = 2

    End With
    Dim Frompt(2) As Double, Topt(2) As Double
9 N( \& |) D1 {) k6 p0 q( A! P    Frompt(0) = 0: Frompt(1) = 0: Frompt(2) = 0
- J' k# L% A) P! X, D- W    Topt(0) = 0: Topt(1) = -49: Topt(2) = 0
2 o0 K+ k" f, K( R' z    Boxobj.Move Frompt, Topt
    Boxobj.Update
/ l! X* f9 z# u& U# ?7 E    Frompt(1) = -49
! m. L9 w7 [0 @) K, p7 |. ?    Topt(1) = -48.9
7 u* o0 h, S6 F2 H    Dim num1 As Double, num As Double
1 x' p  k. Z, e    num1 = 1
, B9 _. x  S; t2 d" s# f( Y8 C, X& \    Do
        If Topt(1) >= 49 Then
! s3 x9 k/ J& C            num = Topt(1)
            Topt(1) = Frompt(1)
            Frompt(1) = num
            num1 = -1
& r3 k# X( Q7 Y        ElseIf Topt(1) <= -49 Then
            num = Topt(1)
+ ^4 b# t  B5 x& h6 A            Topt(1) = Frompt(1)
& N& k: t9 c! ~+ `) A$ t7 ^1 ^5 {            Frompt(1) = num
            num1 = 1
5 h+ u2 u, v" a/ M        End If
        Frompt(1) = Frompt(1) + 0.1 * num1
        Topt(1) = Topt(1) + 0.1 * num1
8 a. u" `- ]9 h2 a: @2 }3 y! e. q: ]+ o        Boxobj.Move Frompt, Topt
: [4 z3 l+ g; l        Call DelayTime(1)
5 e6 Q- s: g7 A3 A5 B- C$ O        Boxobj.Update
        If GetAsyncKeyState(27) = -32767 Then
            Exit Do
        End If
    Loop
9 T) S$ b" F4 a; H) ^$ A+ [5 C: aEnd Sub
& k$ v. g# J% |
0 N6 p9 K4 h3 d" ^
Public Function DelayTime(ByVal timer As Integer)  '延时函数
$ m  `5 x8 X5 l4 Y    Dim firsttimer As Long
    Dim i As Integer
) ?* h+ _4 U4 k$ C* C    firsttimer = timeGetTime
6 F' @0 b8 W& c) G4 Y    For i = 0 To timer
* }$ W( x5 {, ~1 ?" Z       While timeGetTime < firsttimer + 20
/ i4 t4 ?, \8 ^/ O  a+ D            DoEvents
/ L3 }/ r4 G2 ?4 o8 E       Wend
$ @% J8 a# s8 T       firsttimer = timeGetTime
* A' V  J  Q% V+ T! y1 s    Next i
End Function
# m! l4 ?. g: e+ w; C



1 X; D8 C- f0 w4 r! y$ U

woaishuijia

timeGetTime函数没有声明

liaoqt

woaishuijia 发表于 2014-10-8 08:23 static/image/common/back.gif
! `& s6 K* M7 WtimeGetTime函数没有声明

是我粘贴时后忘了   实际上是申明过了的    主要问题是鼠标会闪在运行时   

woaishuijia

4 H: v/ @2 \3 m# T) P把要移动的对象做成块,再插入块参照,用修改块参照对象的InsertionPoint属性的办法改变它的位置,不使用MOVE方法
# ]# M4 f. ]& _4 n2 [看这个用什么方法使曲柄连杆机构转动？
PS:重帖下你的代码.以后发帖时请注意用"添加代码文字"的方法,否则代码中会有大量乱码,别人复制你的代码会很麻烦

1. Option Explicit
   8 X  ~' p6 t; D5 J) E# B; ~
2. Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
   
3. Private Declare Function timeGetTime Lib "winmm.dll" () As Long
   & x1 X; R- s$ G, L/ [$ E4 u6 c4 o# q
4. Public Sub test()
   8 M5 m+ V# k4 T$ n# i2 }* {
5. Dim Boxobj As Acad3DSolid
   9 J% K# _! V2 E. Q3 c# |* A
6. Dim cylinderobj As Acad3DSolid
   
7. Dim Ptcen(2) As Double
   
8. Dim Heigth As Double, Length As Double, Width As Double, Radius As Double
   + M; x" c+ L9 n4 d& l. p1 |# h8 F
9. Dim pt1(2) As Double
   
10. pt1(0) = 12: pt1(1) = 0: pt1(2) = 0
    4 Q8 V' }7 j  e7 Q: v/ d' r* G
11. Dim sset As AcadSelectionSet
    ) k( }2 y1 z, |; k
12. Dim Objentity As AcadEntity
    ' O) p9 F% @1 M: R! z$ e
13. Set sset = ThisDrawing.SelectionSets.Add("NewSSet")
    ) q4 Y, S% u6 f
14. sset.Select acSelectionSetAll
    2 \! Y6 |2 Z7 j: Q3 A: ^
15. For Each Objentity In sset
    
16. Objentity.Delete
    " E# A8 B. o$ N4 v! G) l' S/ _
17. Next
    2 `  ]8 ~( y! b+ {9 n, {
18. sset.Delete
    
19. With ThisDrawing
    
20. 
    
21. Ptcen(0) = 0: Ptcen(1) = -57: Ptcen(2) = -40:
    8 |3 @+ u- m; \) b  q
22. Length = 30: Width = 6: Heigth = 100
    6 H' y* m9 S/ ~1 c
23. Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)
    0 t, |  s- p5 B: ]6 e' D, M
24. Boxobj.color = 28
    / N7 C) @! x+ u
25. Ptcen(0) = 0: Ptcen(1) = 57: Ptcen(2) = -40:
    5 B% o+ p8 G2 r
26. Length = 30: Width = 6: Heigth = 100
    
27. Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)
    & K% @: Z  x# K  k0 [6 v
28. Boxobj.color = 28
    
29. 
    ' ?4 |$ r3 J  R7 L; T- ^: M# z
30. Ptcen(0) = 0: Ptcen(1) = 0: Ptcen(2) = 0:
    
31. Length = 10: Width = 10: Heigth = 10: Radius = 3
    0 X6 F6 y; I' s( |9 X  v0 M6 a
32. Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)
    9 k' J* x+ @% l9 Q& @
33. Set cylinderobj = .ModelSpace.AddCylinder(Ptcen, Radius, Heigth)
    ! |0 l7 o/ ]- F% x
34. cylinderobj.Rotate3D Ptcen, pt1, 90 * 3.1415926 / 180
    . \3 b8 K/ ]# B  M, |5 ^
35. Boxobj.Boolean acSubtraction, cylinderobj
    0 r# z7 I: @2 ?  V6 l: p
36. Boxobj.color = 1
    6 W/ k" M% R! S8 \- }$ H$ _- s
37. Radius = 2.8
    $ K9 C" O. A8 u
38. Heigth = 120
    
39. Set cylinderobj = .ModelSpace.AddCylinder(Ptcen, Radius, Heigth)
    
40. cylinderobj.Rotate3D Ptcen, pt1, 90 * 3.1415926 / 180
    
41. cylinderobj.color = 2
    * L5 |( \# V8 X, R; w1 e
42. 
    
43. End With
    ) F  ?8 I! J. U+ e. T2 R6 L( Q5 ]0 S4 G9 o
44. Dim Frompt(2) As Double, Topt(2) As Double
    
45. Frompt(0) = 0: Frompt(1) = 0: Frompt(2) = 0
    8 A4 N( C7 ^( F$ H
46. Topt(0) = 0: Topt(1) = -49: Topt(2) = 0
    
47. Boxobj.Move Frompt, Topt
    
48. Boxobj.Update
    $ z3 u) N+ I" C7 \# [$ B! Z( n; Y2 @8 K
49. Frompt(1) = -49
    - }, R6 D* \9 E1 W6 s) C! l/ ]
50. Topt(1) = -48.9
    ( P6 l0 i) R7 L+ D8 V; T0 e+ s
51. Dim num1 As Double, num As Double
    : N* y; f- h) r! z  ?
52. num1 = 1
    
53. Do
    1 ?$ I* T. B) \( {8 _* v' R  P' _
54. If Topt(1) >= 49 Then
    & l2 m/ O; t# V+ S
55. num = Topt(1)
    + K& O% m! O+ ?, U1 l# K( S
56. Topt(1) = Frompt(1)
    / @6 l0 {2 v5 M. n: `
57. Frompt(1) = num
      ]! F2 r6 E2 Q5 K8 e! ~7 ^9 k5 e
58. num1 = -1
    + g5 z3 I& R6 L8 T$ ?  _
59. ElseIf Topt(1) <= -49 Then
    3 z& o# \% W5 q/ W/ \
60. num = Topt(1)
    
61. Topt(1) = Frompt(1)
    / F; Z3 G2 d- X/ U; E! n' ~  p
62. Frompt(1) = num
      {6 M* D' ]5 V! V1 \9 }9 C$ ~: Z
63. num1 = 1
    9 T3 c" W' r2 \5 C! }4 i3 l
64. End If
    ( D% ~% n% M4 Y4 n2 V% M2 I
65. Frompt(1) = Frompt(1) + 0.1 * num1
    
66. Topt(1) = Topt(1) + 0.1 * num1
    / s0 H' i& E7 \: N% w
67. Boxobj.Move Frompt, Topt
    
68. Call DelayTime(1)
    4 I' P2 q1 h& s! C* o5 I0 Q* _
69. Boxobj.Update
    
70. If GetAsyncKeyState(27) = -32767 Then
    ( v6 k" x2 m, n0 T% m. T% {
71. Exit Do
    " E8 O0 @$ |5 b
72. End If
    1 L8 T" ~. N; A
73. Loop
    
74. End Sub
    9 H, Y: @! Z1 [8 ?' o  N8 N4 {
75. 
    3 u# ~% k8 n; A1 F- I( m
76. 
    8 s3 D7 z7 o& y6 Y0 h+ C- _
77. Public Function DelayTime(ByVal timer As Integer) '延时函数
    ! z; [3 @" a4 o% X* O+ [
78. Dim firsttimer As Long
    
79. Dim i As Integer
    
80. firsttimer = timeGetTime
    
81. For i = 0 To timer
    ( K+ B1 U. O4 ?
82. While timeGetTime < firsttimer + 20
    
83. DoEvents
    
84. Wend
    0 N8 w! y1 h% x
85. firsttimer = timeGetTime
    
86. Next i
    & D6 g2 `2 C1 i8 F
87. End Function

复制代码

liaoqt

woaishuijia 发表于 2014-10-9 06:42 static/image/common/back.gif
把要移动的对象做成块,再插入块参照,用修改块参照对象的InsertionPoint属性的办法改变它的位置,不使用MOVE方 ...

非常感谢你  推荐的帖子里 有代码解释 赞一个 :lol: