用VB程序怎么做一个心型图？

Dim X1, Y1, X2, Y2 As Integer

Dim I As Integer

Dim J As Boolean

Dim K As IntegerDim WithEvents Label1 As Label

Dim WithEvents Timer1 As TimerPrivate Sub Form_Activate()

I = 100

K = 100

X1 = Me.Width / 2

Y1 = Me.Height / 3

X2 = X1

Y2 = Y1

Label1.Top = Me.Height / 2 - Label1.Height / 2

Label1.Left = Me.Width / 2 - Label1.Width / 2

End SubPrivate Sub Form_Load() Me.BackColor = &H0&

Me.FillColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255)

Me.ForeColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255)

Me.DrawMode = 13

Me.DrawWidth = 2

Me.FillStyle = 7

Set Label1 = Me.Controls.Add("VB.Label", "Label1")

Set Timer1 = Me.Controls.Add("VB.Timer", "Timer1")

Label1.Visible = True

Label1.AutoSize = True

Label1.BackStyle = 0

Label1.Caption = "I LOVE YOU"

Label1.Font.Size = 60

Label1.ForeColor = &HFF00&

Timer1.Enabled = True

Timer1.Interval = 10

Me.WindowState = 2

End SubPrivate Sub Timer1_Timer()

Me.Circle (X1, Y1), 250

Me.Circle (X2, Y2), 250

If Y1 <= Me.Height - 1200 Then

X1 = X1 + K

Y1 = Y1 - I

X2 = X2 - K

Y2 = Y2 - I

I = I - 2

If Y1 <= Me.Height / 3 Then

K = K - 1

ElseIf Y1 >= Me.Height / 3 Then

K = K - 5

End If

Else

I = 100

K = 100

X1 = Me.Width / 2

Y1 = Me.Height / 3

X2 = X1

Y2 = Y1

Me.FillColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255)

Me.ForeColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255) End If

Me.DrawWidth = 3

Me.PSet (Rnd * Me.Width, Rnd * Me.Height), RGB(Rnd * 225, Rnd * 225, Rnd * 225)

Me.DrawWidth = 2

End SubPrivate Sub Form_Click()

End

End SubPrivate Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

End

End Sub

方法一：简单的画法。

Private Sub Command1_Click()

ForeColor = RGB(255, 0, 0)

Font.Name = "Webdings"

Font.Size = 200

Print "Y"

End Sub

方扰磨法二：给个枝李激自定义画法函数给你参猛袜考。

'x，y：图上所示的心形的坐标  a，b：图上所示的心形的大小(b要大于等于a)'co: 心形的颜色 fill: 是否要填充 (true为填充) jd：画图精度(一般取10，太大会卡，太小会有间隙)

Function HuaXinXing(x As Single, y As Single, a As Single, b As Single, co As Long, fill As Boolean, jd As Integer)

 If b < a Then

  Print "b不能小于a"

 Exit Function

 End If

 If jd <= 0 Then

  Print "jd不能小于等于0"

 Exit Function

 End If

 Dim i As Integer, j As Integer, x1 As Single, x2 As Single, x3 As Single, x4 As Single, y1 As Single, y2 As Single

 Dim hd As Single, r As Single, d As Single

 hd = 3.1415926 / 180

 r = (a + b ^ 2 / a) / 2

 d = (b ^ 2 / a - a) / 2

 For i = 0 To 180 * jd

 x1 = x + (Cos(3.1415926 + i * hd / jd) - 1) * a / 2

 x2 = x + (Cos(6.2831852 - i * hd / jd) + 1) * a / 2

 y1 = y + Sin(3.1415926 + i * hd / jd) * a / 2

  PSet (x1, y1), co

  PSet (x2, y1), co

 y2 = y + r * Sin(i * hd / jd / 2)

 If y2 <= y + b Then

 x3 = x - d + r * Cos(i * hd / jd / 2)

 x4 = x + d + r * Cos(3.1415926 - i * hd / jd / 2)

 Else

 y2 = y + b

 End If

 If fill = True Then

  Line (x1, y1)-(x4, y2), co

  Line (x2, y1)-(x3, y2), co

 Else

  PSet (x4, y2), co

  PSet (x3, y2), co

 End If

 Next

End Function

Private Sub Command1_Click()   

 HuaXinXing 1000, 1000, 800, 1200, &HFF&, False, 10

End Sub

方法二运行结果：

---