|
一打开WINDOWS，看着四四方方立在桌面上的应用程序窗口，您是否有些厌倦？别心烦，在WINDOW世界里，只要您能为之“心动”,生活总是美丽而又精彩的。因而许许多多爱好“多样”的CFAN，便为自己的窗口做成了“透明的”、“不规则的”等样式。笔者也心血来潮，将自己的窗口做成了“投影式立体窗口”，见下图1：
图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中加入如下代码：
(图3)
Option Explicit
Dim ShowdawDepth As Integer ’投影大小
Dim ShowdawColor as long ‘投影色彩
Dim WinX, WinY, WinW, WinH, wx,wy, xw, xh As Long
Private Sub labColor_Click()
On Error GoTo exitLabColor
dlg.ShowColor
ShowdawColor = dlg.Color
labColor.BackColor = ShowdawColor
Call Paint
exitLabColor:
End Sub
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
ShowdawColor =0
Timer1.interval=100
Dlg.CancelError=True
labColor.BorderStyle=1
labColor.BackStyle = 1
labColor.BackColor = ShowdawColor
xh = CLng(ScaleY(ShowdawDepth, 3, 1) + 0.5)
xw = CLng(ScaleX(ShowdawDepth, 3, 1) + 0.5)
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 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，看看您亲手做的这种投影效果。注意：以上的投影大小不能太大，否则速度会变慢
|
