X
XUEPING8
Unregistered / Unconfirmed
GUEST, unregistred user!
在VB6.0中使用API函数AnimateWindow,实现窗体的动态效果,总会出现黑色背景,在网上搜了一下,,http://www.mvps.org/emorcillo/en/code/vb6/animatewindow.shtml,可以解决,但运行总报错,请哪位高手帮忙解决下,谢谢。附该代码:Const GWL_WNDPROC = (-4)Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" ( _ ByVal hWnd As Long, _ ByVal nIndex As Long) As LongPrivate Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _ ByVal hWnd As Long, _ ByVal nIndex As Long, _ ByVal dwNewLong As Long) As LongConst PROP_PREVPROC = "PrevProc"Const PROP_FORM = "FormObject"Private Declare Function SetProp Lib "user32" Alias "SetPropA" ( _ ByVal hWnd As Long, _ ByVal lpString As String, _ ByVal hData As Long) As LongPrivate Declare Function GetProp Lib "user32" Alias "GetPropA" ( _ ByVal hWnd As Long, _ ByVal lpString As String) As LongPrivate Declare Function RemoveProp Lib "user32" Alias "RemovePropA" ( _ ByVal hWnd As Long, _ ByVal lpString As String) As LongPrivate Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" ( _ Dest As Any, _ Src As Any, _ ByVal DestL As Long)Const WM_PRINTCLIENT = &H318Private Type RECT Left As Long Top As Long Right As Long Bottom As LongEnd TypePrivate Declare Function GetClientRect Lib "user32" ( _ ByVal hWnd As Long, _ lpRect As RECT) As LongPrivate Declare Function apiOleTranslateColor Lib "oleaut32" Alias "OleTranslateColor" ( _ ByVal lOleColor As Long, _ ByVal lHPalette As Long, _ lColorRef As Long) As LongEnum AnimateWindowFlags AW_HOR_POSITIVE = &H1 AW_HOR_NEGATIVE = &H2 AW_VER_POSITIVE = &H4 AW_VER_NEGATIVE = &H8 AW_CENTER = &H10 AW_HIDE = &H10000 AW_ACTIVATE = &H20000 AW_SLIDE = &H40000 AW_BLEND = &H80000End EnumPrivate Declare Function apiAnimateWindow Lib "user32" Alias "AnimateWindow" ( _ ByVal hWnd As Long, _ ByVal dwTime As Long, _ ByVal dwFlags As Long) As LongPrivate Declare Function MulDiv Lib "kernel32" ( _ ByVal Mul As Long, _ ByVal Nom As Long, _ ByVal Den As Long) As LongPrivate Declare Function CreateSolidBrush Lib "gdi32" ( _ ByVal crColor As Long) As LongPrivate 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 LongPrivate Declare Function GetDC Lib "user32" ( _ ByVal hWnd As Long) As LongPrivate Declare Function CreateCompatibleDC Lib "gdi32" ( _ ByVal hDC As Long) As LongPrivate Declare Function ReleaseDC Lib "user32" ( _ ByVal hWnd As Long, _ ByVal hDC As Long) As LongPrivate Declare Function DeleteDC Lib "gdi32" ( _ ByVal hDC As Long) As LongPrivate Declare Function FillRect Lib "user32" ( _ ByVal hDC As Long, _ lpRect As RECT, _ ByVal hBrush As Long) As LongPrivate Declare Function DeleteObject Lib "gdi32" ( _ ByVal hObject As Long) As LongPrivate Declare Function SelectObject Lib "gdi32" ( _ ByVal hDC As Long, _ ByVal hObject As Long) As LongPrivate Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _ ByVal lpPrevWndFunc As Long, _ ByVal hWnd As Long, _ ByVal Msg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long'' AnimateWindow'' Wrapper for AnimateWindow api'Sub AnimateWindow( _ ByVal Form As Form, _ ByVal dwTime As Long, _ ByVal dwFlags As AnimateWindowFlags) ' Set the properties SetProp Form.hWnd, PROP_PREVPROC, GetWindowLong(Form.hWnd, GWL_WNDPROC) SetProp Form.hWnd, PROP_FORM, ObjPtr(Form) ' Subclass the window SetWindowLong Form.hWnd, GWL_WNDPROC, AddressOf AnimateWinProc ' Call AnimateWindow API apiAnimateWindow Form.hWnd, dwTime, dwFlags ' Unsubclass the window SetWindowLong Form.hWnd, GWL_WNDPROC, GetProp(Form.hWnd, PROP_PREVPROC) ' Remove the properties RemoveProp Form.hWnd, PROP_FORM RemoveProp Form.hWnd, PROP_PREVPROC ' Refresh the form Form.Refresh End Sub'' AnimateWinProc'' Window procedure for AnimateWindow'Private Function AnimateWinProc( _ ByVal hWnd As Long, _ ByVal Msg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As LongDim lPrevProc As LongDim lForm As LongDim oForm As Form ' Get the previous WinProc pointer lPrevProc = GetProp(hWnd, PROP_PREVPROC) ' Get the form object lForm = GetProp(hWnd, PROP_FORM) MoveMemory oForm, lForm, 4& Select Case Msg Case WM_PRINTCLIENT Dim tRect As RECT Dim hBr As Long ' Get the window client size GetClientRect hWnd, tRect ' Create a brush with the ' form background color hBr = CreateSolidBrush(OleTranslateColor(oForm.BackColor)) ' Fill the DC with the ' background color FillRect wParam, tRect, hBr ' Delete the brush DeleteObject hBr If Not oForm.Picture Is Nothing Then Dim lScrDC As Long Dim lMemDC As Long Dim lPrevBMP As Long ' Create a compatible DC lScrDC = GetDC(0&) lMemDC = CreateCompatibleDC(lScrDC) ReleaseDC 0, lScrDC ' Select the form picture in the DC lPrevBMP = SelectObject(lMemDC, oForm.Picture.Handle) ' Draw the picture in the DC BitBlt wParam, _ 0, 0, _ HM2Pix(oForm.Picture.Width), HM2Pix(oForm.Picture.Height), _ lMemDC, 0, 0, vbSrcCopy ' Release the picture SelectObject lMemDC, lPrevBMP ' Delete the DC DeleteDC lMemDC End If End Select ' Release the form object MoveMemory oForm, 0&, 4& ' Call the original window procedure AnimateWinProc = CallWindowProc(lPrevProc, hWnd, Msg, wParam, lParam) End Function'' HM2Pix'' Converts HIMETRIC to Pixel'Private Function HM2Pix(ByVal Value As Long) As Long HM2Pix = MulDiv(Value, 1440, 2540) / Screen.TwipsPerPixelXEnd Function'' OleTranslateColor'' Wrapper for OleTranslateColor API'Private Function OleTranslateColor(ByVal Clr As Long) As Long apiOleTranslateColor Clr, 0, OleTranslateColorEnd Function