為您的應用程序建立投影式立體窗口(陰影)

--------------------------------------------------------------------------------

　　一打開WINDOWS，看著四四方方立在桌面上的應用程序窗口，您是否有些厭倦？別心煩，在WINDOW世界里，只要您能為之"心動",生活總是美麗而又精彩的。因而許許多多愛好"多樣"的CFAN，便為自己的窗口做成了"透明的"、"不規則的"等樣式。筆者也心血來潮，將自己的窗口做成了"投影式立體窗口"，見下圖1：
　　怎么樣？Cool吧！

　　其實，制作這樣的立體窗口不是非常難，其原理是這樣的（設要為hWnd窗口做個立體）：1、獲取hWnd在屏幕上的位置（GetWindowRect），根據其位置為其建立三個投影窗口，分別命名LeftForm-左邊投影，DownForm-下面投影，RdForm-右下角投影；2、獲取三個投影窗口在屏幕上的位置信息，根據黑色漸變原理，將其寫入三個投影窗口中。注意：不能直接將其投影信息寫入屏幕DC中，否則的話，桌面將會被您繪的一踏糊涂。另外：窗口在移動、改變大小時，均應該重新繪制投影信息。這個在VB中不是非常容易做得到，因此我們需要為其增加一個Timer控件，在Timer事件監視這一系列的動作。

　　好了，下面我們開始動手做做這種效果：

　　1、啟動VB6.0，建立一個新的標準exe工程文件，將啟動主窗口FormName命名為"MainForm",并將ScaleMode設置為3,另外再新添建三個窗口，分別命名為"LeftForm","DownForm","RdForm"，并且將其"BorderStyle"設置為"0-None"，將各自的GotFocus事件中寫入如下代碼：

　　MainForm.setfocus

　　2、新建一個模塊API.bas(可以用"外接程序"中的"API瀏覽器"),插入如下代碼：



Public Const SRCCOPY = &HCC0020

Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

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

Public 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

Public Declare Function SetPixel Lib "gdi32" (
ByVal hdc As Long,
ByVal x As Long,
ByVal y As Long,
ByVal crColor As Long) As Long

Public Declare Function GetPixel Lib "gdi32" (
ByVal hdc As Long,
ByVal x As Long,
ByVal y As Long) As Long

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

Public Declare Function CreateCompatibleBitmap Lib "gdi32" (
ByVal hdc As Long,
ByVal nWidth As Long,
ByVal nHeight As Long) As Long

Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

Public Declare Function GetWindowRect Lib "user32" (
ByVal hwnd As Long,
lpRect As RECT) As Long

'取色彩中的Red的值
Public Function GetRed(ByVal n As Long) As Integer
GetRed = n Mod 256&
End Function

'取色彩中的Green的值
Public Function GetGreen(ByVal n As Long) As Integer
GetGreen = (n \ 256&) Mod 256&
End Function

'取色彩中的Blue的值
Public Function GetBlue(ByVal n As Long) As Integer
GetBlue = n \ 65536
End Function

'獲取漸變色彩值
'入口參數：SrcColor 原色彩
' Steps 步驟數
' CurStep 當前的步子
' DstColor 目標色彩
'返回值：當月前的色彩值
Public Function GetTrienColor(ByVal scrColor As Long,
ByVal dstColor As Long, ByVal Steps As Integer,
ByVal curStep As Integer) As Long
Dim sR, sG, sB, dR, dG, dB As Integer
sR = GetRed(scrColor)
sG = GetGreen(scrColor)
sB = GetBlue(scrColor)
dR = GetRed(dstColor)
dG = GetGreen(dstColor)
dB = GetBlue(dstColor)
sR = sR + curStep * (dR - sR) / Steps
sG = sG + curStep * (dG - sG) / Steps
sB = sB + curStep * (dB - sB) / Steps
GetTrienColor = RGB(sR, sG, sB)
End Function

　　其工程文件結構如圖2：
　　圖2
　　3、將MainForm窗體設計成如圖3，且將窗體Code中加入如下代碼：

Option Explicit
Dim ShowdawDepth As Integer
Dim WinX, WinY, WinW, WinH, wx, wy, xw, xh As Long
Dim ShowdawColor As Long

Private Sub GetWandH()
Dim r As RECT
wy = MainForm.Top
wx = MainForm.Left
Call GetWindowRect(MainForm.hwnd, r) '獲取當前窗口在屏幕上的位置
WinX = r.Left
WinY = r.Top
WinH = r.Bottom - r.Top + 1
WinW = r.Right - r.Left + 1
'重新調整左邊投影的位置
LeftForm.Left = CLng(ScaleX(r.Right, 3, 1) + 0.5)
LeftForm.Top = CLng(ScaleY(r.Top, 3, 1) + 0.5)
LeftForm.Width = xw
LeftForm.Height = CLng(ScaleY(WinH, 3, 1) + 0.5)
'重新調整下邊投影的位置
DownForm.Width = CLng(ScaleX(WinW, 3, 1) + 0.5)
DownForm.Height = xh
DownForm.Top = CLng(ScaleY(r.Bottom, 3, 1) + 0.5)
DownForm.Left = CLng(ScaleX(r.Left, 3, 1) + 0.5)
'重新調整右下角邊投影的位置
RdForm.Top = CLng(ScaleY(r.Bottom, 3, 1) + 0.5)
RdForm.Left = CLng(ScaleX(r.Right, 3, 1) + 0.5)
RdForm.Width = xw
RdForm.Height = xh
End Sub

Private Sub Command1_Click()
Unload MainForm
End Sub

Private Sub Form_Load()
ShowdawDepth = 10
xh = CLng(ScaleY(ShowdawDepth, 3, 1) + 0.5)
xw = CLng(ScaleX(ShowdawDepth, 3, 1) + 0.5)
ShowdawColor = 0
Timer1.Interval = 100
dlg.CancelError = True
labColor.BorderStyle = 1
labColor.BackStyle = 1
labColor.BackColor = ShowdawColor
End Sub

Private Sub Paint() '窗口繪制
Dim hScreenDc, hMemLeftDc, hMemDownDc, hMemRdDc, x, y As Long
Dim hMemLeftBit, hMemDownBit, hMemRdBit, curColor, srcColor As Long
LeftForm.Visible = False
DoEvents
DownForm.Visible = False
DoEvents
RdForm.Visible = False
DoEvents
hScreenDc = GetDC(0) '獲取桌面DC
hMemLeftDc = CreateCompatibleDC(hScreenDc)
hMemLeftBit = CreateCompatibleBitmap(hScreenDc, ShowdawDepth, WinH)
SelectObject hMemLeftDc, hMemLeftBit
hMemDownDc = CreateCompatibleDC(hScreenDc)
hMemDownBit = CreateCompatibleBitmap(hScreenDc, WinW, ShowdawDepth)
SelectObject hMemDownDc, hMemDownBit
hMemRdDc = CreateCompatibleDC(hScreenDc)
hMemRdBit = CreateCompatibleBitmap(hScreenDc, ShowdawDepth, ShowdawDepth)
SelectObject hMemRdDc, hMemRdBit
For y = 0 To WinH - 1
For x = 0 To ShowdawDepth - 1 '左邊的投影
srcColor = GetPixel(hScreenDc, WinW + WinX + x, WinY + y)
If srcColor <> -1 Then
If y < ShowdawDepth And x < y Or y >= ShowdawDepth Then
curColor = GetTrienColor(ShowdawColor, srcColor, ShowdawDepth, x)
Else
curColor = srcColor
End If
SetPixel hMemLeftDc, x, y, curColor
End If
Next x
Next y
For y = 0 To ShowdawDepth - 1 '右下角的投影
For x = 0 To ShowdawDepth - 1
srcColor = GetPixel(hScreenDc, WinW + WinX + x, WinY + WinH + y)
If srcColor <> -1 Then
If x <= y Then
curColor = GetTrienColor(ShowdawColor, srcColor, ShowdawDepth, y)
Else
curColor = GetTrienColor(ShowdawColor, srcColor, ShowdawDepth, x)
End If
SetPixel hMemRdDc, x, y, curColor
End If
Next x
Next y
For y = 0 To ShowdawDepth - 1
For x = 0 To WinW - 1
srcColor = GetPixel(hScreenDc, WinX + x, WinY + WinH + y)
If srcColor <> -1 Then
If y < ShowdawDepth And x >= y Or x >= ShowdawDepth Then
curColor = GetTrienColor(ShowdawColor, srcColor, ShowdawDepth, y)
Else
curColor = srcColor
End If
SetPixel hMemDownDc, x, y, curColor
End If
Next x
Next y
LeftForm.Visible = True
DoEvents
Call BitBlt(LeftForm.hdc, 0, 0, ShowdawDepth, WinH, hMemLeftDc, 0, 0, SRCCOPY)
DownForm.Visible = True
DoEvents
Call BitBlt(DownForm.hdc, 0, 0, WinW, ShowdawDepth, hMemDownDc, 0, 0, SRCCOPY)
RdForm.Visible = True
DoEvents
Call BitBlt(RdForm.hdc, 0, 0, ShowdawDepth, ShowdawDepth, hMemRdDc, 0, 0, SRCCOPY)
DeleteDC hMemLeftDc
DeleteDC hMemDownDc
DeleteDC hScreenDc
DeleteDC hMemRdDc
DeleteObject hMemLeftBit
DeleteObject hMemRdBit
DeleteObject hMemDownBit
End Sub

Private Sub Form_Resize()
If MainForm.WindowState = vbNormal Then '窗口在正常狀態下才顯示立體投影
If MainForm.Height < 2 * xh Then MainForm.Height = 2 * xh
If MainForm.Width < 2 * xw Then MainForm.Width = 2 * xw
Call GetWandH
Call Paint
Else
wx = -1
LeftForm.Visible = False
DownForm.Visible = False
RdForm.Visible = False
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
Unload LeftForm
Unload DownForm
Unload RdForm
End Sub

Private Sub labColor_Click()
On Error GoTo exitLabColor
dlg.ShowColor
ShowdawColor = dlg.Color
labColor.BackColor = ShowdawColor
Call Paint
exitLabColor:
End Sub

Private Sub Timer1_Timer()
If MainForm.WindowState = vbNormal And (MainForm.Left <> wx Or MainForm.Top <> wy) Then
Call GetWandH
Call Paint
End If
End Sub

Private Sub Form_Paint()
Call GetWandH
Call Paint
End Sub

Private Sub UpDown_Change()
ShowdawDepth = UpDown.Max + UpDown.Min - UpDown.Value
ShowSize.Text = ShowdawDepth
xh = CLng(ScaleY(ShowdawDepth, 3, 1) + 0.5)
xw = CLng(ScaleX(ShowdawDepth, 3, 1) + 0.5)
Call GetWandH
Call Paint
End Sub

　　此至，您可以按下Play，看看您親手做的這種投影效果。注意：以上的投影大小不能太大，否則速度會變慢。(2000年2月14日完稿，本文發表于《電腦編程技術與維護》2000年第7期,Word版文檔下載地址為：http://www.i0713.net/Download/Prog/Dragon/Doc/Showdaw.doc,

源程序下載地址：htttp://www.i0713.net/Download/Prog/Dragon/Prog/Showdaw.zip