源程序

Form1( 菜单.frm)

Option Explicit

Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long

Private Declare Function GetTickCount Lib "kernel32" () As Long

Const DT_BOTTOM As Long = &H8

Const DT_CALCRECT As Long = &H400

Const DT_CENTER As Long = &H1

Const DT_EXPANDTABS As Long = &H40

Const DT_EXTERNALLEADING As Long = &H200

Const DT_LEFT As Long = &H0

Const DT_NOCLIP As Long = &H100

Const DT_NOPREFIX As Long = &H800

Const DT_RIGHT As Long = &H2

Const DT_SINGLELINE As Long = &H20

Const DT_TABSTOP As Long = &H80

Const DT_TOP As Long = &H0

Const DT_VCENTER As Long = &H4

Const DT_WORDBREAK As Long = &H10

Private Type RECT

Left As Long

Top As Long

Right As Long

Bottom As Long

End Type

Const ScrollText As String = "设计题目：送瓶机" & vbCrLf & _

vbCrLf & "工作原理及工艺动作过程：" & _ vbCrLf & "为了清洗圆形瓶子外面" & _

vbCrLf & "需将瓶子推到上" & _

vbCrLf & "同向转动的导辊" & vbCrLf & _ vbCrLf & "送瓶机的主要动作：" & _

vbCrLf & "将到位的瓶子沿着导轨推动" & _ vbCrLf & " 然后通过另一个曲柄滑块" & _ vbCrLf & "将瓶子的送到转动的导辊上" & _ vbCrLf & "导辊带动瓶子旋转" & _

vbCrLf & "推动瓶子沿导辊前进" & _

vbCrLf & "转动的刷子就将瓶子洗净" & _ vbCrLf & "这里我只设计了" & _

vbCrLf & "前半部分的送瓶机构" & _

vbCrLf & "后面的洗瓶机构" & _

vbCrLf & "还有出瓶机构" & _

vbCrLf & "都没有设计出来" & _

vbCrLf & "洗瓶机构已经有人设计出来了" & _

vbCrLf & "出瓶机构有点困难" & _

vbCrLf & "具体的说明我会写在课程设计说明书中" & _

vbCrLf & "大家可以进行参考设计"

Dim EndingFlag As Boolean

Const pi = 3.1415926

Public t, l1, l2, l3, l4, x0, y0, x1, y1, x2, y2, a0, b0, a1, b1, a2, b2, w As Double

Private Sub label5_Click()

Timer1.Enabled = True

Label1.Visible = True

Picture2.Scale (0, 0)-(11000, 11000)

End Sub

Private Sub label6_Click()

Timer1.Enabled = False

Picture2.Scale (0, 0)-(11000, 11000)

End Sub

Private Sub Form_Load()

Top = 0

Left = 0

Form1.Height = Screen.Height

Form1.Width = Screen.Width

Timer1.Enabled = False

picScroll.ForeColor = vbWhite

picScroll.FontSize = 14

picScroll.DrawWidth = 4

picScroll.Font = "华文行楷"

Label1.Visible = False

End Sub

Private Sub label7_Click()

MsgBox "谢谢欣赏我的程序"

End

End Sub

Private Sub mnui参考资料_Click()

Form14.Show

End Sub

Private Sub mnui设计要求_Click()

Form15.Show

End Sub

Private Sub mnusent不完全齿轮机构_Click()

Form10.Show

End Sub

Private Sub mnusent连杆机构_Click()

Form6.Show

End Sub

Private Sub mnusent偏心轮机构_Click()

Form7.Show

End Sub

Private Sub mnusent凸轮机构_Click()

Form8.Show

End Sub

Private Sub Timer1_Timer()

t = t + pi * w / 180

Cls

draw

End Sub

Private Sub draw()

w = 1

l1 = 1200

l2 = 4800

x0 = 1500

y0 = 2500

x1 = x0 + l1 * Cos(t)

y1 = y0 - l1 * Sin(t)

x2 = x0 + l1 * (Cos(t) + l2 / l1 - 0.25 * l1 / l2 + 0.25 * l1 / l2 * Cos(2 * t))

y2 = 3500

l3 = 1200

l4 = 4800

a0 = 8000

b0 = 7500

a1 = a0 + l3 * Cos(t - pi / 2)

b1 = b0 - l3 * Sin(t - pi / 2)

a2 = 8000

b2 = b0 - l3 * (Cos(t - pi) + l4 / l3 - 0.25 * l3 / l4 + 0.25 * l3 / l4 * Cos(2 * (t - pi)))

Picture2.Cls

Picture2.DrawWidth = 3

Picture2.Line (x0, y0)-(x1, y1), vbBlue

Picture2.Line -(x2, y2), vbBlue

Picture2.Line (x2 - 200, y2 - 100)-(x2 + 200, y2 - 100), vbBlue Picture2.Line -(x2 + 200, y2 + 100), vbBlue

Picture2.Line -(x2 - 200, y2 + 100), vbBlue

Picture2.Line -(x2 - 200, y2 - 100), vbBlue

Picture2.Line (x0 - 200, y0 + 200)-(x0, y0), vbGreen

Picture2.Line -(x0 + 200, y0 + 200), vbGreen

Picture2.Line -(x0 - 200, y0 + 200), vbGreen

Picture2.DrawWidth = 3

Picture2.Line (5000, 3700)-(7600, 3700), vbRed

Picture2.DrawWidth = 3

Picture2.Line (a0, b0)-(a1, b1), vbBlue

Picture2.Line -(a2, b2), vbBlue

Picture2.Line (a2 - 200, b2 - 100)-(a2 + 200, b2 - 100), vbBlue Picture2.Line -(a2 + 200, b2 + 100), vbBlue

Picture2.Line -(a2 - 200, b2 + 100), vbBlue

Picture2.Line -(a2 - 200, b2 - 100), vbBlue

Picture2.Line (a0 - 200, b0 + 200)-(a0, b0), vbGreen

Picture2.Line -(a0 + 200, b0 + 200), vbGreen

Picture2.Line -(a0 - 200, b0 + 200), vbGreen

Picture2.DrawWidth = 1

Picture2.Line (7700, 3300)-(7700, 1500), vbYellow

Picture2.Line (7200, 3300)-(7200, 1500), vbYellow

Picture2.Line (7750, 3300)-(7750, 1500), vbYellow

Picture2.Line (8250, 3300)-(8250, 1500), vbYellow

Picture2.DrawWidth = 2

Picture2.Circle (x0, y0), l1, vbYellow

Picture2.Circle (a0, b0), l3, vbYellow

Picture2.Circle (x0, y0), 50, vbYellow

Picture2.Circle (x1, y1), 50, vbYellow

Picture2.Circle (x2, y2), 50, vbYellow

Picture2.Circle (a0, b0), 50, vbYellow

Picture2.Circle (a1, b1), 50, vbYellow

Picture2.Circle (a2, b2), 50, vbYellow

End Sub

Private Sub mnuhelp画线_Click()

Form3.Show

End Sub

Private Sub mnuhelp画圆_Click()

Form4.Show

End Sub

Private Sub mnuhelp曲柄滑块_Click()

Form11.Show

End Sub

Private Sub mnuhelp双曲柄机构_Click()

Form9.Show

End Sub

Private Sub mnumove加速度分析_Click()

Form5.Show

End Sub

Private Sub mnumove速度分析_Click()

Form2.Show

End Sub

Private Sub mnumove位置分析_Click()

Form13.Show

End Sub

Private Sub Form_Activate()

RunMain

End Sub

Private Sub RunMain()

Dim LastFrameTime As Long

Const IntervalTime As Long = 40

Dim rt As Long

Dim DrawingRect As RECT

Dim UpperX As Long, UpperY As Long 'Upper left point of drawing rect Dim RectHeight As Long

Form1.Refresh

Get the size of the drawing rectangle by suppying the DT_CALCRECT constant rt = DrawText(picScroll.hdc, ScrollText, -1, DrawingRect, DT_CALCRECT) If rt = 0 Then 'err

MsgBox "Error scrolling text", vbExclamation

EndingFlag = True

Else

DrawingRect.Top = picScroll.ScaleHeight

DrawingRect.Left = 0

DrawingRect.Right = picScroll.ScaleWidth

RectHeight = DrawingRect.Bottom

DrawingRect.Bottom = DrawingRect.Bottom + picScroll.ScaleHeight End If

Do While Not EndingFlag

If GetTickCount() - LastFrameTime > IntervalTime Then

picScroll.Cls

DrawText picScroll.hdc, ScrollText, -1, DrawingRect, DT_CENTER Or DT_WORDBREAK

DrawingRect.Top = DrawingRect.Top - 1

DrawingRect.Bottom = DrawingRect.Bottom - 1

If DrawingRect.Top < -(RectHeight) Then 'time to reset

DrawingRect.Top = picScroll.ScaleHeight

DrawingRect.Bottom = RectHeight + picScroll.ScaleHeight End If

picScroll.Refresh

LastFrameTime = GetTickCount()

End If

DoEvents

Loop

Unload Me

Set Form1 = Nothing

End Sub

Private Sub Form_Unload(Cancel As Integer)

EndingFlag = True

End Sub

Private Sub Timer2_Timer()

If Label1.Left > -25000 And Label1.Left < 13000 Then

Label1.Left = Label1.Left - 100

Else

Label1.Left = 12000

Label1.Left = Label1.Left - 100

End If

End Sub

For13.(位置分析)

Option Explicit

Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long

Private Declare Function GetTickCount Lib "kernel32" () As Long

Const DT_BOTTOM As Long = &H8

Const DT_CALCRECT As Long = &H400

Const DT_CENTER As Long = &H1

Const DT_EXPANDTABS As Long = &H40

Const DT_EXTERNALLEADING As Long = &H200

Const DT_LEFT As Long = &H0

Const DT_NOCLIP As Long = &H100

Const DT_NOPREFIX As Long = &H800

Const DT_RIGHT As Long = &H2

Const DT_SINGLELINE As Long = &H20

Const DT_TABSTOP As Long = &H80

Const DT_TOP As Long = &H0

Const DT_VCENTER As Long = &H4

Const DT_WORDBREAK As Long = &H10

Private Type RECT

Left As Long

Top As Long

Right As Long

Bottom As Long

End Type

Const ScrollText As String = "如图所示，矢量方程式为" & vbCrLf & _

vbCrLf & "L1+L2=Yc" & _

vbCrLf & "L1eiψ1+L2eiψ2=yc " & _

vbCrLf & "展开后分别取虚部和实部得" & _

vbCrLf & "L1sinψ1+L2sin(180-ψ2)=0" & _

vbCrLf & "所以" & _

vbCrLf & " 180-ψ2=arcsin(-L1sinψ1)/ψ2" & _

vbCrLf & "ψ2=180-arcsin(-L1sinψ1/ψ2)" & _

vbCrLf & "yc=L1codψ1-L2cosψ2" & _

vbCrLf & "这里我定义一个的坐标范围" & _

vbCrLf & "输入的长度最好不要超过10000" Dim EndingFlag As Boolean

Const pi = 3.1415926

Public t, l1, l2, Xc, w As Double

Private Sub label5_Click()

Timer1.Enabled = True

Picture2.Scale (-10, 10000)-(100, -500)

Picture2.DrawWidth = 3

Picture2.Line (-10, 0)-(100, 0), vbBlue

Picture2.Line (0, 10000)-(0, -500), vbBlue

End Sub

Private Sub label6_Click()

Timer1.Enabled = False

Picture2.Scale (-10, 10000)-(100, -500)

Picture2.DrawWidth = 3

Picture2.Line (-10, 0)-(100, 0), vbBlue

Picture2.Line (0, 10000)-(0, -500), vbBlue

End Sub

Private Sub label7_Click()

Unload Me

End Sub

Private Sub label4_Click()

Text1.Text = 1200

Text2.Text = 4800

Text3.Text = 1

End Sub

Private Sub Form_Load()

Top = 0

Left = 0

Form13.Height = Screen.Height

Form13.Width = Screen.Width

Timer1.Enabled = False

picScroll.ForeColor = vbWhite

picScroll.FontSize = 14

picScroll.DrawWidth = 4

picScroll.Font = "华文行楷"

End Sub

Private Sub Timer1_Timer()

t = t + pi * w / 180

draw

End Sub

Private Sub draw()

l1 = Text1.Text

l2 = Text2.Text

w = Text3.Text

Xc = l1 * (Cos(t) + l2 / l1 - 0.25 * l1 / l2 + 0.25 * l1 * Cos(2 * t) / l2)

Text4.Text = Xc

Picture2.DrawWidth = 2

Picture2.PSet (t, Xc), vbYellow

End Sub

Private Sub Form_Activate()

RunMain

End Sub

Private Sub RunMain()

Dim LastFrameTime As Long

Const IntervalTime As Long = 40

Dim rt As Long

Dim DrawingRect As RECT

Dim UpperX As Long, UpperY As Long 'Upper left point of drawing rect

Dim RectHeight As Long

Form13.Refresh

rt = DrawText(picScroll.hdc, ScrollText, -1, DrawingRect, DT_CALCRECT)

If rt = 0 Then 'err

MsgBox "Error scrolling text", vbExclamation

EndingFlag = True

Else

DrawingRect.Top = picScroll.ScaleHeight

DrawingRect.Left = 0

DrawingRect.Right = picScroll.ScaleWidth

RectHeight = DrawingRect.Bottom

DrawingRect.Bottom = DrawingRect.Bottom + picScroll.ScaleHeight

End If

Do While Not EndingFlag

If GetTickCount() - LastFrameTime > IntervalTime Then

picScroll.Cls

DrawText picScroll.hdc, ScrollText, -1, DrawingRect, DT_CENTER Or DT_WORDBREAK

DrawingRect.Top = DrawingRect.Top - 1

DrawingRect.Bottom = DrawingRect.Bottom - 1

If DrawingRect.Top < -(RectHeight) Then 'time to reset

DrawingRect.Top = picScroll.ScaleHeight

DrawingRect.Bottom = RectHeight + picScroll.ScaleHeight

End If

picScroll.Refresh

LastFrameTime = GetTickCount() End If

DoEvents

Loop

Unload Me

Set Form13 = Nothing

End Sub

Private Sub Form_Unload(Cancel As Integer) EndingFlag = True

End Sub