Форум на Исходниках.RU

Option Explicit

Private Declare Function UpdateLayeredWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, ByVal crKey As Long, pblend As Long, ByVal dwFlags As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Private 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

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 ReleaseCapture Lib "user32" () As Long

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Const WM_NCLBUTTONDOWN As Long = &HA1

Private Const HTCAPTION As Long = 2

Private Const WS_EX_LAYERED = &H80000

Private Const GWL_EXSTYLE As Long = -20

Private Const ULW_ALPHA = &H2

Private Const AB_32Bpp255 = 33488896

Private Sub Form_DblClick()

Unload Me

End Sub

Private Sub Form_Load()

Dim dc As Long

Dim bmp As Long

Dim obm As Long

Dim col() As Byte

Dim idx As Long

Width = 6400: Height = 6400

DrawMode = vbMergePenNot: FillStyle = vbFSSolid: Line (1, 1)-(ScaleWidth - 2, ScaleHeight - 2), &HA0A0A0, BF

FillStyle = vbFSTransparent: Line (0, 0)-(ScaleWidth - 1, ScaleHeight - 1), &H505050, B

Line (10, 10)-(ScaleWidth - 11, ScaleHeight - 11), vbWhite, B

DrawMode = vbMergePenNot: FillStyle = vbFSSolid: Line (10, 10)-(ScaleWidth - 11, ScaleHeight - 11), &H505050, B

dc = CreateCompatibleDC(hdc)

ReDim col(3) ' RGBA

For idx = 127 To 0 Step -1

col(0) = (&H80& * idx) \ &H100&: col(1) = (&H80& * idx) \ &H100&: col(2) = (&H30& * idx) \ &H100&: col(3) = idx

bmp = CreateBitmap(1, 1, 1, 32, col(0)): obm = SelectObject(dc, bmp)

StretchBlt hdc, 138 - idx, 138 - idx, ScaleWidth - (138 - idx) * 2, ScaleHeight - (138 - idx) * 2, dc, 0, 0, 1, 1, vbSrcCopy

SelectObject dc, obm: DeleteObject bmp

DeleteDC dc

Dim sz As Currency, pt As Currency

SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED

sz = (ScaleWidth + CCur(ScaleHeight) * 4294967296#) / 10000

UpdateLayeredWindow hwnd, hdc, pt, sz, hdc, pt, 0, AB_32Bpp255, ULW_ALPHA

End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

ReleaseCapture

SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0

End Sub