如圖所示。
附上代碼：
'Create the shadow windows 創建陰影視窗
Private Sub CreateWindows()
Const EX_STYLE As Long = WS_EX_LAYERED Or WS_EX_TRANSPARENT Or WS_EX_NOPARENTNOTIFY
hWndTt = CreateWindowExA(EX_STYLE, "#32770", vbNullString, WS_POPUP, 0, 0, 0, 0, hWndForm, 0, Application.hInstance, 0)
hWndBt = CreateWindowExA(EX_STYLE, "#32770", vbNullString, WS_POPUP, 0, 0, 0, 0, hWndForm, 0, Application.hInstance, 0)
hWndLt = CreateWindowExA(EX_STYLE, "#32770", vbNullString, WS_POPUP, 0, 0, 0, 0, hWndForm, 0, Application.hInstance, 0)
hWndRt = CreateWindowExA(EX_STYLE, "#32770", vbNullString, WS_POPUP, 0, 0, 0, 0, hWndForm, 0, Application.hInstance, 0)
MakeWindow
End Sub
'*******************************************************************************************************************************************
'*******************************************************************************************************************************************
'Display the shadows 創建陰影
Private Sub DisplayShadows()
If bIsLayered Then
If IsWindowVisible(hWndForm) <> 0 Then
With wP
DisplayShadowSub .X, .Y + .cY, .cX + m_Depth + m_Depth, m_Depth, 1 '創建陰影表單(1上)
DisplayShadowSub .X, .Y + .cY, .cX + m_Depth + m_Depth, m_Depth, 2 '創建陰影表單(2下)
DisplayShadowSub .X + .cX, .Y, m_Depth, .cY, 3 '創建陰影表單(3左)
DisplayShadowSub .X + .cX, .Y, m_Depth, .cY, 4 '創建陰影表單(4右)
End With
End If
End If
End Sub
'*******************************************************************************************************************************************
'*******************************************************************************************************************************************
'Display the content of the specified shadow window 繪制陰影
Private Sub DisplayShadowSub(ByVal X As Long, ByVal Y As Long, cX As Long, cY As Long, ByVal sPosition As Integer)
Dim dc As Long
Dim iX As Long
Dim iY As Long
Dim hDib As Long
Dim hWin As Long
Dim nAlpha As Long
Dim aPixels() As Long
Dim pBmpBits As Long
Dim pt0 As tPOINT
Dim pt As tPOINT
Dim sz As tSIZE
Dim bs As tBLENDFUNCTION
Dim bmpHeader As tBITMAPINFOHEADER
Dim SafeArray As tSAFEARRAY2D
dc = CreateCompatibleDC(0) 'Get a screen compatible memory dc
With bmpHeader 'Initialize a bitmap header
.biSize = Len(bmpHeader) 'Bitmap header size
.biWidth = cX 'Bitmap/window pixel width
.biHeight = cY 'Bitmap/window pixel height
.biPlanes = 1 'Graphics planes
.biBitCount = 32 '32bits per pixel BGRA (Blue, Green, Red, Alpha)
.biSizeImage = cX * cY * 4 'Memory size, width * height * 32bit
End With
hDib = CreateDIBSection(dc, bmpHeader, 0, pBmpBits, 0, 0) 'Create a device independant bitmap as per the header, compatible with the dc (compatible with the screen)
With SafeArray 'Construct a VB safearray header that matches the specs of the bitmap
.cbElements = 4 '4 bytes per element - 32bits per pixel
.cDims = 2 'We'll treat the pixels as a two dimensional (x, y) array
.pvData = pBmpBits 'The data pointer points to the bitmap data (pixels)
.Bounds(0).lLbound = 0 'Lowest bound will be 0
.Bounds(0).cElements = cY 'The number of elements
.Bounds(1).lLbound = 0 'Lowest bound will be 0
.Bounds(1).cElements = cX 'The number of elements
End With
CopyMemory ByVal VarPtrArray(aPixels()), VarPtr(SafeArray), 4 'Copy the address of our safearray over the address of aPixels() safearray
'****************************************************************************
Select Case sPosition
Case 1 '上陰影--------------------------------------------------------------------
hWin = hWndTt
For iX = 0 To cX - 1
If iX < cY Then
nAlpha = Round(255 * (iX / (cY - 1)) ^ 2) '陰影左段
ElseIf iX >= (cX - cY) Then
nAlpha = Round(255 * ((cX - 1 - iX) / (cY - 1)) ^ 2) '陰影右段
Else
nAlpha = 255 '陰影中段
End If
For iY = 0 To cY - 1
aPixels(iX, iY) = MakeBGRA(Round(nAlpha * ((cY - 1 - iY) / (cY - 1)) ^ 2))
Next iY
Next iX
Case 2 '下陰影--------------------------------------------------------------------
hWin = hWndBt
For iX = 0 To cX - 1
If iX < cY Then
nAlpha = Round(255 * (iX / (cY - 1)) ^ 1.5) '陰影左段
ElseIf iX >= (cX - cY) Then
nAlpha = Round(255 * ((cX - 1 - iX) / (cY - 1)) ^ 1.5) '陰影右段
Else
nAlpha = 255 '陰影中段
End If
For iY = 0 To cY - 1
aPixels(iX, iY) = MakeBGRA(Round(nAlpha * (iY / (cY - 1)) ^ 1.5))
Next iY
Next iX
Case 3 '左陰影--------------------------------------------------------------------
hWin = hWndLt
For iY = 0 To cY - 1
nAlpha = 255
For iX = 0 To cX - 1
aPixels(iX, iY) = MakeBGRA(Round(nAlpha * (iX / (cX - 1)) ^ 1.5))
Next iX
Next iY
Case 4 '右陰影--------------------------------------------------------------------
hWin = hWndRt
For iY = 0 To cY - 1
nAlpha = 255
For iX = 0 To cX - 1
aPixels(iX, iY) = MakeBGRA(Round(nAlpha * ((cX - 1 - iX) / (cX - 1)) ^ 1.5))
Next iX
Next iY
End Select
'****************************************************************************
CopyMemory ByVal VarPtrArray(aPixels()), 0&, 4
With bs 'Setup the blend function
.AlphaFormat = AC_SRC_ALPHA 'Use the alpha channel for individual pixel transparency
.BlendFlags = 0
.BlendOp = AC_SRC_OVER 'Alpha overlay
.SourceConstantAlpha = m_Transparency 'Alpha transparency for overall transparencyAlpha
End With
pt.X = X 'Setup the window position and size data 設定視窗位置和大小的資料
pt.Y = Y
sz.cX = cX
sz.cY = cY
hDib = SelectObject(dc, hDib) 'Select the bitmap into the memory display context
UpdateLayeredWindow hWin, dc, pt, sz, dc, pt0, 0, bs, ULW_ALPHA 'Do the layered update
SelectObject dc, hDib 'Trash the bitmap
DeleteDC dc 'Delete the memory display context
End Sub
以上代碼基于VBA平臺。
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/23393.html
標籤：VBA
下一篇：vba求教