VB6利用win32API画玫瑰花算法

这是以前找到的一个VB程序，作者已经不可得知。

昨天晚上与朋友聊画图算法的时候我突然想到了这个程序。

算法并不是太难，利用三角函数画出图形轮廓。

接着利用api函数填充图形。

核心算法如下：

Private Sub comp(a As Double, b As Double, c As Double)
    Dim j       As Long
    Dim AA      As Double, BB       As Double
    Dim n       As Double, o        As Double
    Dim w       As Double, z        As Double
    If c > 60 Then  ' 花茎
        Ds.a = Sin(a * 7) * (13 + 5 / (0.2 + (b * 4) ^ 4)) - Sin(b) * 50
        Ds.b = b * f + 50
        Ds.c = 625 + Cos(a * 7) * (13 + 5 / (0.2 + (b * 4) ^ 4)) + b * 400
        Ds.d = a - b / 2
        Ds.e = a
        Exit Sub
    End If
    AA = a * 2 - 1
    BB = b * 2 - 1
    If AA * AA + BB * BB < 1 Then
        If c > 37 Then   '花叶
            j = Int(c) And 1
            n = IIf(j, 6, 4)
            o = 0.5 / (a + 0.01) + Cos(b * 125) * 3 - a * 300
            w = b * h
            Ds.a = o * Cos(n) + w * Sin(n) + j * 610 - 390
            Ds.b = o * Sin(n) - w * Cos(n) + 550 - j * 350
            Ds.c = 1180 + Cos(BB + AA) * 99 - j * 300
            Ds.d = 0.4 - a * 0.1 + ((1 - BB * BB) ^ (-h * 6)) * 0.15 - a * b * 0.4 + Cos(a + b) / 5 + (Cos((o * (a + 1) + (IIf(BB > 0, w, -w))) / 25) ^ 30) * 0.1 * (1 - BB * BB)
            Ds.e = o / 1000# + 0.7 - o * w * 0.000003
        ElseIf c > 32 Then   '萼片
            c = c * 1.16 - 0.15
            o = a * 45 - 20
            w = b * b * h
            z = o * Sin(c) + w * Cos(c) + 620
            Ds.a = o * Cos(c) - w * Sin(c)
            Ds.b = 28 + Cos(BB * 0.5) * 99 - b * b * b * 60 - z / 2 - h
            Ds.c = z
            Ds.d = (b * b * 0.3 + ((1 - a * a) ^ 7) * 0.15 + 0.3) * b
            Ds.e = b * 0.7
        Else     '花
             o = AA * (2 - b) * (80 - c * 2)
             w = 99 - Cos(AA) * 120 - Cos(b) * (-h - c * 4.9) + Cos((1 - b) ^ 7) * 50 + c * 2
            z = o * Sin(c) + w * Cos(c) + 700
            Ds.a = o * Cos(c) - w * Sin(c)
            Ds.b = BB * 99 - Cos(b ^ 7) * 50 - c / 3 - z / 1.35 + 450
            Ds.c = z
            Ds.d = (1 - b / 1.2) * 0.9 + a * 0.1
            Ds.e = ((1 - b) ^ 20) / 4 + 0.05
        End If
    End If
  
End Sub




Private Sub DrawRose()     
    Dim x               As Long, y          As Long
    Static i            As Long
    Dim j               As Long
    Dim x1              As Long, y1         As Long
    Dim z               As Long
    Dim r               As Long, g          As Long
    Dim b               As Long
    Dim q               As Long
    
    x = 1:      y = 1:
    x1 = 1:     y1 = 1
    z = 1
    r = 255
    
    j = i Mod 46


    comp Rnd, Rnd, j / 0.74
    
    i = i + 1


    z = Ds.c
    If z = 0 Then z = 1
    x = Ds.a * f / z - h
    y = Ds.b * f / z - h
    x = x / 2
    y = y / 2


    q = y * f + x
    If Not ((Not m(q)) Or m(q) > z) Then Exit Sub
    m(q) = z
    
    r = Ds.d * h
    g = Ds.e * h
    b = Ds.d * Ds.d * (-80)


    SetPixel Me.hdc, x, y, RGB(Abs(r), Abs(g), Abs(b))
  
End Sub

源程序点我下载