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

liaoqt

Option Explicit
7 J2 m$ H5 m# J; m) d) yPrivate Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public Sub test()
& V$ L+ B1 s' E/ o/ F" I    Dim Boxobj  As Acad3DSolid
    Dim cylinderobj As Acad3DSolid
2 I3 ]1 S% z) g% k2 ^; V    Dim Ptcen(2) As Double
9 S6 W: i/ F4 [/ b) X4 p9 v& a, }    Dim Heigth As Double, Length As Double, Width As Double, Radius As Double
    Dim pt1(2) As Double
! u: L% C& S( M& r( _    pt1(0) = 12: pt1(1) = 0: pt1(2) = 0
* V  x4 [/ t, J0 G. D- B  z    Dim sset As AcadSelectionSet
2 q+ f- P2 A* \( G/ Q8 X& K! u$ X( m7 [    Dim Objentity As AcadEntity
    Set sset = ThisDrawing.SelectionSets.Add("NewSSet")
    sset.Select acSelectionSetAll
        For Each Objentity In sset
* u! M1 O7 U/ s" P8 j8 W$ }            Objentity.Delete
        Next
/ O0 Y7 }) I8 @* f! k. m    sset.Delete
    With ThisDrawing

        Ptcen(0) = 0: Ptcen(1) = -57: Ptcen(2) = -40:
( S8 u) J2 ~; e- `5 i9 k4 s        Length = 30: Width = 6: Heigth = 100
  ^) k7 a3 A) Z$ ?0 R7 a2 R0 P' I        Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)
        Boxobj.color = 28
        Ptcen(0) = 0: Ptcen(1) = 57: Ptcen(2) = -40:
9 w7 d# E! i% g        Length = 30: Width = 6: Heigth = 100
; Q' S) d( m1 _& U8 [5 s- X        Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)
" k4 S( {! c6 h: e- q        Boxobj.color = 28

# ^/ _: J: d0 l# K, T        Ptcen(0) = 0: Ptcen(1) = 0: Ptcen(2) = 0:
        Length = 10: Width = 10: Heigth = 10: Radius = 3
        Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)
  c# L: K9 z* h5 J  N6 ~        Set cylinderobj = .ModelSpace.AddCylinder(Ptcen, Radius, Heigth)
/ j. m3 W4 m$ M$ T* a# l$ Y  P        cylinderobj.Rotate3D Ptcen, pt1, 90 * 3.1415926 / 180
        Boxobj.Boolean acSubtraction, cylinderobj
2 p5 B* a5 W9 X$ ?& k- p- Q5 D        Boxobj.color = 1
4 ]* w+ {, q2 y  L: g( e        Radius = 2.8
        Heigth = 120
        Set cylinderobj = .ModelSpace.AddCylinder(Ptcen, Radius, Heigth)
( J3 l8 w  m, v- N' p. {        cylinderobj.Rotate3D Ptcen, pt1, 90 * 3.1415926 / 180
0 |# i+ v" M. _2 C. j        cylinderobj.color = 2

    End With
    Dim Frompt(2) As Double, Topt(2) As Double
    Frompt(0) = 0: Frompt(1) = 0: Frompt(2) = 0
    Topt(0) = 0: Topt(1) = -49: Topt(2) = 0
    Boxobj.Move Frompt, Topt
    Boxobj.Update
    Frompt(1) = -49
    Topt(1) = -48.9
    Dim num1 As Double, num As Double
% b* n7 R- i0 ]$ X. |    num1 = 1
    Do
        If Topt(1) >= 49 Then
            num = Topt(1)
$ D; ~7 z3 [9 D. S' |6 D$ F' g            Topt(1) = Frompt(1)
- B4 N' K. \1 L* w$ C            Frompt(1) = num
            num1 = -1
        ElseIf Topt(1) <= -49 Then
( }6 l# V) r1 l0 W7 N            num = Topt(1)
            Topt(1) = Frompt(1)
            Frompt(1) = num
: H9 h7 Y2 ?8 y  M            num1 = 1
        End If
+ ^$ i* A  F) c1 e( @, p* F$ u$ V# g        Frompt(1) = Frompt(1) + 0.1 * num1
& m" q+ _5 o# F4 B0 Q$ h' z        Topt(1) = Topt(1) + 0.1 * num1
, v" G: N3 t' A& E; \        Boxobj.Move Frompt, Topt
- a4 d1 V2 `# o# n0 Y        Call DelayTime(1)
# a" Y3 b/ C4 o, Z6 j3 Z2 p$ ]0 Q3 {1 p        Boxobj.Update
        If GetAsyncKeyState(27) = -32767 Then
            Exit Do
        End If
    Loop
$ o1 a. s, W/ b. ~End Sub
: ^) q9 J- ?  t1 K# K, y5 X5 ^# D, m
$ \  K& \( r" S) r2 T
, O# V: D0 T  W2 h) s" M6 J9 T* ~Public Function DelayTime(ByVal timer As Integer)  '延时函数
    Dim firsttimer As Long
0 a9 c: R4 W) y# Z( x$ B    Dim i As Integer
    firsttimer = timeGetTime
0 K$ o9 b4 P  E$ I    For i = 0 To timer
- q- n  A# W  t2 J1 W$ ^5 k$ p+ p       While timeGetTime < firsttimer + 20
+ W6 g! I+ m& C. Y7 [            DoEvents
       Wend
* R; `; E2 e% m& i% @1 \/ O       firsttimer = timeGetTime
    Next i
$ u# ]' S$ C, j& wEnd Function


; O8 J% N2 t" s9 X, d6 D& x
1 r9 `4 x+ z' A( m+ A
  i5 j$ {& I' ?# |1 j$ A

woaishuijia

timeGetTime函数没有声明

liaoqt

woaishuijia 发表于 2014-10-8 08:23 static/image/common/back.gif
. |% X4 A- ^. q  G' etimeGetTime函数没有声明

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

woaishuijia

2 U% L# W8 Z& p0 U4 T) W7 p
. }: \9 ]- D3 T: ]9 u) c5 Q把要移动的对象做成块,再插入块参照,用修改块参照对象的InsertionPoint属性的办法改变它的位置,不使用MOVE方法
看这个用什么方法使曲柄连杆机构转动？
PS:重帖下你的代码.以后发帖时请注意用"添加代码文字"的方法,否则代码中会有大量乱码,别人复制你的代码会很麻烦

1. Option Explicit
   
2. Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
   ( N& A; N6 M5 A
3. Private Declare Function timeGetTime Lib "winmm.dll" () As Long
   + t- Z  O' x9 Y( d
4. Public Sub test()
   2 u1 T" E  @- o$ f
5. Dim Boxobj As Acad3DSolid
   
6. Dim cylinderobj As Acad3DSolid
   ; H. i; W6 W* ^1 |- {# q9 g
7. Dim Ptcen(2) As Double
   4 g' I& t* g7 X9 x4 [$ z
8. Dim Heigth As Double, Length As Double, Width As Double, Radius As Double
   
9. Dim pt1(2) As Double
   
10. pt1(0) = 12: pt1(1) = 0: pt1(2) = 0
    
11. Dim sset As AcadSelectionSet
    8 g! {9 E2 |! L' J
12. Dim Objentity As AcadEntity
    ; q+ q' y8 m- b% W
13. Set sset = ThisDrawing.SelectionSets.Add("NewSSet")
    
14. sset.Select acSelectionSetAll
      W! a/ R3 h/ C9 ]. f2 a. M# @
15. For Each Objentity In sset
    
16. Objentity.Delete
    
17. Next
    
18. sset.Delete
    
19. With ThisDrawing
    
20. 
    & A1 X. U5 U2 S0 `6 m
21. Ptcen(0) = 0: Ptcen(1) = -57: Ptcen(2) = -40:
    % N6 x  m$ r% E1 j" c+ i0 b4 k
22. Length = 30: Width = 6: Heigth = 100
    
23. Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)
    
24. Boxobj.color = 28
    * d( P- H- M/ T/ h
25. Ptcen(0) = 0: Ptcen(1) = 57: Ptcen(2) = -40:
    
26. Length = 30: Width = 6: Heigth = 100
    & g- P4 |5 u% q; L$ W0 l  R) r
27. Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)
    - Y2 `: c. a3 @1 M4 C+ x- b# d
28. Boxobj.color = 28
    
29. 
    ! R& L# I7 D# p0 ]
30. Ptcen(0) = 0: Ptcen(1) = 0: Ptcen(2) = 0:
    
31. Length = 10: Width = 10: Heigth = 10: Radius = 3
    ' i# [8 o( F5 L% k( ?0 o2 F
32. Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)
    " ^4 ~. ~" R# d
33. Set cylinderobj = .ModelSpace.AddCylinder(Ptcen, Radius, Heigth)
    
34. cylinderobj.Rotate3D Ptcen, pt1, 90 * 3.1415926 / 180
      Y* W: r- j& u; I1 F
35. Boxobj.Boolean acSubtraction, cylinderobj
    ' l1 j( [: g/ b/ m
36. Boxobj.color = 1
    
37. Radius = 2.8
    
38. Heigth = 120
    
39. Set cylinderobj = .ModelSpace.AddCylinder(Ptcen, Radius, Heigth)
    ' Z2 z+ B5 X! S1 H
40. cylinderobj.Rotate3D Ptcen, pt1, 90 * 3.1415926 / 180
    & p0 k6 y0 @: j. ^, X1 {' D
41. cylinderobj.color = 2
    
42. 
    
43. End With
    & o2 n; I, P2 B  h4 f
44. Dim Frompt(2) As Double, Topt(2) As Double
    ! v3 }/ B$ M% g/ E( y, G, n% T
45. Frompt(0) = 0: Frompt(1) = 0: Frompt(2) = 0
    3 K. r4 Z4 x( _9 h6 G' t& m; _
46. Topt(0) = 0: Topt(1) = -49: Topt(2) = 0
    
47. Boxobj.Move Frompt, Topt
    * L! s) y2 ?. r: D+ b- H3 h  q, x! v
48. Boxobj.Update
    + d# n3 w. I$ {% u, x" X8 L8 U/ W
49. Frompt(1) = -49
    9 @& b+ H+ e8 P( U
50. Topt(1) = -48.9
    " X* X( T/ V1 M+ I
51. Dim num1 As Double, num As Double
    
52. num1 = 1
    
53. Do
    ) l) w8 O  m" O( _
54. If Topt(1) >= 49 Then
    + z2 D( Y% C  i
55. num = Topt(1)
    
56. Topt(1) = Frompt(1)
    
57. Frompt(1) = num
      i0 q4 V1 F( {% L' N
58. num1 = -1
    9 ?; y' l# E  u3 v) n
59. ElseIf Topt(1) <= -49 Then
    
60. num = Topt(1)
    
61. Topt(1) = Frompt(1)
      d3 @) {6 f/ r/ m& I9 ~
62. Frompt(1) = num
    7 _5 z7 a) t% `8 Y6 X! f
63. num1 = 1
    
64. End If
    
65. Frompt(1) = Frompt(1) + 0.1 * num1
    3 w$ w2 i4 {: X( Z0 j
66. Topt(1) = Topt(1) + 0.1 * num1
    # g+ H8 N( d/ T2 E) ]2 k- o; U1 C
67. Boxobj.Move Frompt, Topt
    
68. Call DelayTime(1)
    
69. Boxobj.Update
    3 d$ f% n# @$ Q# T: A
70. If GetAsyncKeyState(27) = -32767 Then
    
71. Exit Do
    ( k  ^  ^: b# n3 \+ c
72. End If
      j8 P' A8 r" ?( V
73. Loop
    
74. End Sub
    ' D4 Y3 T! @/ r. X8 k8 B
75. 
    
76. 
    & u) Y0 G, P+ T- R  d6 {7 t
77. Public Function DelayTime(ByVal timer As Integer) '延时函数
    
78. Dim firsttimer As Long
    7 v# m4 c7 k0 k& V/ |2 c
79. Dim i As Integer
    
80. firsttimer = timeGetTime
    
81. For i = 0 To timer
      m7 a. y. {0 K! i# W. ]3 q) Y
82. While timeGetTime < firsttimer + 20
    
83. DoEvents
    ; @/ o) Z4 ^6 k! c; k8 I- n
84. Wend
    
85. firsttimer = timeGetTime
    ; m8 x$ y& x2 i0 `0 u3 Y
86. Next i
    ) Z2 |8 b& G( K! @3 T
87. End Function

复制代码

liaoqt

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

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