пихаеш в модуль,

Option Explicit

Private Declare Function CallWindowProcA Lib "user32" (ByVal lpPrevWndFunc As Long, ByVal lngHandle As Long, ByVal lngMsg As Long, ByVal lngFirstParam As Long, ByVal lngLastParam As Long) As Long

Private Declare Function SetWindowLongA Lib "user32" (ByVal lngHandle As Long, ByVal nIndex As Long, ByVal dwNewLong 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 GetDC Lib "user32" (ByVal hwnd As Long) As Long

Private lngOldProc As Long

Public Sub SetProc(ByVal lngHandle As Long)

lngOldProc = SetWindowLongA(lngHandle, -4, AddressOf WinProc)

End Sub

Private Function WinProc(ByVal lngHandle As Long, ByVal lngMsg As Long, ByVal lngFirstParam As Long, ByVal lngLastParam As Long) As Long

If lngMsg = &H3 Then

frmMain.picShadow.Move frmMain.Left, frmMain.Top

DoEvents

BitBlt frmMain.picShadow.hDC, 0, 0, frmMain.picShadow.Width, frmMain.picShadow.Height, GetDC(0), frmMain.picShadow.Left / Screen.TwipsPerPixelX + 30, frmMain.picShadow.Top / Screen.TwipsPerPixelY + 30, vbSrcCopy

frmMain.picShadow.Line (0, 0)-(frmMain.picShadow.ScaleWidth, frmMain.picShadow.ScaleHeight), vbGrayText, BF

frmMain.picShadow.Move frmMain.Left + (30 * Screen.TwipsPerPixelX), frmMain.Top + (30 * Screen.TwipsPerPixelY), frmMain.Width, frmMain.Height

End If

WinProc = CallWindowProcA(lngOldProc, lngHandle, lngMsg, lngFirstParam, lngLastParam)

End Function

Пихаеш в форму

Option Explicit

Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long

Private Declare Function GetDesktopWindow Lib "user32" () As Long

Private Sub Form_Load()

SetParent picShadow.hwnd, GetDesktopWindow

SetProc hwnd

End Sub

нормально работает под Win2000 и Win98 на других не тестил.

Ответить

Дык этот пример здесь на сайте есть. Он бредовый

Тень нужна как от менюх в XP

Ответить

Sub ropShadow(hwnd As Long)

    SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) Or CS_DROPSHADOW
End Sub

Вот нашел код. Плюс ко всему этому нужно включать в настройках системы

SystemParametersInfo(SPI_SETDROPSHADOW,0,TRUE,0);

Только вот немогу найти значение константы CS_DROPSHADOW

Ответить

Нашел!

Private Const CS_DROPSHADOW = &H20000

Ответить

Ответить

Ответить

А теперь продолжение вопроса: Как избавиться от сабжа???

После применения тени к одной из форм проекта, все окна, что будут открыты после этой формы, тоже автоматом рисуются с тенями, независимо от того, выгружена эта форма или нет, ну и соответственно, всё жутко морозится, всё-таки тень требует ресурсов дай боже. Вроде комп у меня не самый медленный, но страшно всё мерзнет. Так как избавиться от тени там, где она не нужна? Отключать всей системе тень - как-то неправильно...

Ответить

Sub ropShadow(hwnd As Long)

CurrentStyle= GetClassLong hwnd, GCL_STYLE)   

SetClassLong hwnd, GCL_STYLE, CurrentStyle Or CS_DROPSHADOW
End Sub

А где нибудь в анлоад_форм пишешь вот это

SetClassLong hwnd, GCL_STYLE, CurrentStyle

Вроде бы так, я точно не помню

Ответить

Всё правильно, так и делаю, но при этом:

1.Один раз появившись, тень не исчезнет, хотя и выгрузишь форму, даже вернув прежний стиль класса, так вот эти тени бесхозные висят по всему экрану, там где появлялось окно с тенью.

2.Если в программе всего одна форма, и к ней применялась тень - проблем нет. Если форм несколько, то применив тень хотя бы к одной, от теней уже не избавишься, даже выгружая эту форму. Пока полностью не закончит работу программа, тени будут присутствовать.

3.Экспериментально нащупал, что тень - это что-то вроде какого-то объекта, вернее часть формы. Сделаешь форме SetWindowPos c HWND_TOPMOST - тени посл её выгрузки тоже остаются TOPMOST.

4.Единственное, что пока придумал - перед Unload задвинуть форму с тенью за пределы экрана, пусь там висят.

Ответить