读书人

VB6.0有没有像window画图板那样的高速

发布时间: 2012-03-22 17:43:57 作者: rapoo

VB6.0有没有像window画图板那样的高速90度旋转的方法
壁纸级别的图片都转起来的速度,唉。
请指点小弟一条明路吧

[解决办法]
Private Type POINTAPI
X As Long
Y As Long
End Type

Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Declare Function GetObject Lib "gdi32 " Alias "GetObjectA " (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetTickCount Lib "kernel32 " () As Long
Private Declare Function SelectObject Lib "gdi32 " (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32 " (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32 " (ByVal hdc As Long) 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 DeleteDC Lib "gdi32 " (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32 " (ByVal hwnd As Long, ByVal hdc 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 PlgBlt Lib "gdi32 " (ByVal hdcDest As Long, lpPoint As POINTAPI, ByVal hdcSrc As Long, ByVal nXSrc As Long, ByVal nYSrc As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hbmMask As Long, ByVal xMask As Long, ByVal yMask As Long) As Long

Public Sub Rotate90(Pic As PictureBox)
Dim DefPoints(3) As POINTAPI
Dim MemDC As Long
Dim BHandle As Long
Dim OldObject As Long
Dim PicInfo As BITMAP
Dim Width As Long, Height As Long, Temp As Long
Pic.AutoSize = True: Pic.AutoRedraw = True
GetObject Pic.Image, Len(PicInfo), PicInfo
Width = PicInfo.bmWidth
Height = PicInfo.bmHeight
MemDC = CreateCompatibleDC(Pic.hdc)
BHandle = CreateCompatibleBitmap(Pic.hdc, Width, Height)
OldObject = SelectObject(MemDC, BHandle)
BitBlt MemDC, 0, 0, Width, Height, Pic.hdc, 0, 0, vbSrcCopy
DefPoints(0).X = 0
DefPoints(0).Y = Width
DefPoints(1).X = 0
DefPoints(1).Y = 0
DefPoints(2).X = Height
DefPoints(2).Y = Width
Pic.Move Pic.Left, Pic.Top, Pic.Height, Pic.Width
Set Pic.Picture = Nothing
PlgBlt Pic.hdc, DefPoints(0), MemDC, 0, 0, Width, Height, 0, 0, 0
SelectObject MemDC, OldObject
DeleteDC MemDC
DeleteObject BHandle
End Sub

Private Sub Command1_Click()
Dim t As Long
t = GetTickCount
Rotate90 Picture1
MsgBox GetTickCount - t
End Sub

读书人网 >VB

热点推荐