rotate.frm

vb程序的实现动画

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Rotate Bitmap"
   ClientHeight    =   4140
   ClientLeft      =   1575
   ClientTop       =   1530
   ClientWidth     =   6690
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   276
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   446
   Begin VB.TextBox Text1 
      Height          =   285
      Left            =   480
      TabIndex        =   5
      Top             =   2760
      Width           =   1455
   End
   Begin VB.PictureBox Rot 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H00000000&
      BorderStyle     =   0  'None
      ForeColor       =   &H0000FF00&
      Height          =   735
      Left            =   0
      ScaleHeight     =   49
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   65
      TabIndex        =   1
      Top             =   0
      Width           =   975
      Begin VB.CommandButton Ren 
         Caption         =   "Ren"
         Height          =   255
         Left            =   240
         TabIndex        =   4
         Top             =   0
         Visible         =   0   'False
         Width           =   495
      End
      Begin VB.CommandButton Rl 
         Caption         =   "L"
         Height          =   255
         Left            =   0
         TabIndex        =   3
         Top             =   0
         Width           =   255
      End
      Begin VB.CommandButton Rr 
         Caption         =   "R"
         Height          =   255
         Left            =   720
         TabIndex        =   2
         Top             =   0
         Width           =   255
      End
   End
   Begin VB.PictureBox Store 
      AutoRedraw      =   -1  'True
      Height          =   1575
      Left            =   4320
      Picture         =   "Rotate.frx":0000
      ScaleHeight     =   101
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   133
      TabIndex        =   0
      Top             =   240
      Width           =   2055
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

'Declare Function Arc Lib "gdi32" (ByVal hdc As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long
'Declare Function Chord Lib "gdi32" (ByVal hdc As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nwidth As Long, ByVal nheight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nwidth As Long, ByVal nheight As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nwidth As Long, ByVal nheight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nwidth As Long, ByVal nheight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function FloodFill Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
'Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nwidth As Long, ByVal nheight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
'Declare Function GetPaletteEntries Lib "gdi32" (ByVal hPalette As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
'Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
'Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
'Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long

'Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
'Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
'Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
'Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
'Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
'Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
'Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
'Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
'Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
'Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
'Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long


 Const SRCCOPY = &HCC0020
 Const BLACKNESS = &H42&
 Const SrcPaint = &HEE0086
 Const SRCAND = &H8800C6
 Const SRCINVERT = &H660046
Dim a, b, c, d, e, f, g, r, pi, zz, cx, cy, bx, by, zr, sc, drawcolor, Sscr&, stool, ww, tool, gbs, x1, y1, sx, sy, deg, ims, ti, Sh, Sw, scv, Picwidth, Picheight, Bm&, tp&, tmp&
Dim Px, Py, S, Ital, Wt, Ht, Thick, Esc, Ul, Fontuse, Fbc, Dm, Filcolor

Sub Rotate()
Rot.ScaleMode = 3
Rem this routine draws the square one side at a time
Rem by = center Y of bitmap and  bx = center X of the bitmap
Rem e = Work Box center X and f = Work Box center Y
Rem a holds the Degrees and b = right side c = Bottom d = left side
Rem zx and zy are just temparary variables
pi = 4 * Atn(1): pi = (pi / 180): a = deg: b = (deg + 90): c = (deg + 180): d = (deg + 270)
e = (Form1.Rot.ScaleWidth / 2) - 2: f = (Form1.Rot.ScaleHeight / 2) - 2: Form1.Rot.DrawWidth = 1
zx = (by * Sin(a * pi) + e): zy = (by * Cos(a * pi) + f)
Form1.Rot.Line (-bx * Sin((a + 90) * pi) + zx, -bx * Cos((a + 90) * pi) + zy)-(bx * Sin((a + 90) * pi) + zx, bx * Cos((a + 90) * pi) + zy), QBColor(10)
zx = (bx * Sin(b * pi) + e): zy = (bx * Cos(b * pi) + f):
Form1.Rot.Line (-by * Sin((b + 90) * pi) + zx, -by * Cos((b + 90) * pi) + zy)-(by * Sin((b + 90) * pi) + zx, by * Cos((b + 90) * pi) + zy), QBColor(10)
zx = (by * Sin(c * pi) + e): zy = (by * Cos(c * pi) + f)
Form1.Rot.Line (-bx * Sin((c + 90) * pi) + zx, -bx * Cos((c + 90) * pi) + zy)-(bx * Sin((c + 90) * pi) + zx, bx * Cos((c + 90) * pi) + zy), QBColor(10)
zx = (bx * Sin(d * pi) + e): zy = (bx * Cos(d * pi) + f)
Form1.Rot.Line (-by * Sin((d + 90) * pi) + zx, -by * Cos((d + 90) * pi) + zy)-(by * Sin((d + 90) * pi) + zx, by * Cos((d + 90) * pi) + zy), QBColor(10)
Text1.Text = "  " + Str$(deg) + " Degrees"
End Sub


Private Sub Form_Load()
Rem set the Rot.PictureBox to an area big enough to hold the Bitmap on a 45 degree angle
Rem now copy the bitmap into it to start rotations
Rem and Position the buttons
Rr.Left = Rot.Width - Rr.Width: deg = 0
bx = (Store.ScaleWidth / 2): by = (Store.ScaleHeight / 2)
a = (Form1.Store.Width * Form1.Store.Width) + (Form1.Store.Height * Form1.Store.Height): b = Sqr(a)
Form1.Rot.Top = 0: Form1.Rot.Left = 0:
Form1.Rot.Width = b: Form1.Rot.Height = b: Form1.Rot.Visible = True: Form1.Ren.Visible = True
a = (b / 2) - 1: tmp = BitBlt(Form1.Rot.hdc, (a - bx), (a - by), Form1.Store.Width, Form1.Store.Height - 6, Form1.Store.hdc, 0, 0, SRCCOPY)
 Form1.Ren.Left = (Rot.Width / 2) - (Form1.Ren.Width / 2) + 4: Form1.Ren.Top = 6
Rr.Left = Rot.ScaleWidth - Rr.Width: Ren.Left = (Rot.ScaleWidth / 2 - Ren.Width / 2): Ren.Top = 0
Text1.Text = "  " + Str$(deg) + "   Degrees"
End Sub

Private Sub Ren_Click()
r = 0: Ren.Visible = False: Rr.Visible = False: Rl.Visible = False
Rot.AutoRedraw = False
Rem setup the draw in degrees function
pi = 4 * Atn(1): pi = (pi / 180): a = deg: b = (deg + 90): c = (deg + 180): d = (deg + 270)
e = (Rot.ScaleWidth / 2) - 2: f = (Rot.ScaleHeight / 2) - 2: Form1.Rot.DrawWidth = 1
Rem Do a palette copy so the colors will come out right in 256 colors
Clipboard.Clear: Clipboard.SetData Form1.Picture, 9
Form1.Rot.Picture = Clipboard.GetData(9)
Rem setup the variables
Dim cc As Long
Form1.Rot.DrawMode = 13
tby = (by - 2): lft = 0: rt = 0: Form1.Rot.Cls
Rem loop through the bitmap getting one pixel color at a time
Rem and paste them down on the new position on the rot.PictureBox
Rem the for next loop does one scan line at a time
Rem the loop counts down then vertical scan lines to the bottom on the bitmap
Rem useing tby as a checkpoint
Rem Note that everything is calculated from the center
lpf:
For stx = (bx - 2) To (-bx + 2) Step -1
cc = Form1.Store.Point(lft, rt): lft = lft + 1
zx = (tby * Sin(c * pi) + e): zy = (tby * Cos(c * pi) + f)
tmp = SetPixel(Form1.Rot.hdc, (stx * Sin((c + 90) * pi) + zx), (stx * Cos((c + 90) * pi) + zy), cc)
tmp = SetPixel(Form1.Rot.hdc, (stx * Sin((c + 90) * pi) + zx), (stx * Cos((c + 90) * pi) + zy + 1), cc)
Next: lft = 0: rt = rt + 1
tby = tby - 1: If tby > (-by + 2) Then GoTo lpf
Rem replace the buttons for another rotation
Ren.Visible = True
Rl.Visible = True: Rr.Visible = True

End Sub


Private Sub Rl_Click()
Rem draw the square
Form1.Rot.DrawMode = 6
If r = 1 Then Rotate: r = 0
If deg < 360 Then deg = deg + 2: Rotate: r = 1

End Sub


Private Sub Rr_Click()
Rem draw the square
Form1.Rot.DrawMode = 6
If r = 1 Then Rotate: r = 0
deg = deg - 2: Rotate: r = 1

End Sub