例子代码：在win9x下实现快速窗体半透明

enmity 2002-05-06 03:04:29

不使用win2k API，在win9x下实现快速窗体半透明

把下面内容保存成控件，命名为Translucency：
Option Explicit

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex 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 AlphaBlend Lib "msimg32" (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 WidthSrc As Long, ByVal HeightSrc As Long, ByVal dreamAKA As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateDC Lib "Gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
Private Declare Function DeleteDC Lib "Gdi32.dll" (ByVal hdc As Long) As Long

Const m_def_BlendColor = vbBlack

Dim m_BlendColor As OLE_COLOR
Private Const SM_CYCAPTION = 4
Private Const SM_CXFRAME = 32
Private Const SM_CYFRAME = 33

Public Function drawTranslucency()
UserControl.Parent.Refresh
If Ambient.UserMode Then
BlendIT UserControl.Parent, picCapture
End If
End Function

Private Sub BlendIT(frm As Object, Pic As PictureBox)

Dim titleBarheight As Integer
Dim xDeviation As Integer
Dim yDeviation As Integer
Dim windowFrameHeight As Integer
Dim windowframewidth As Integer
Dim BlendVal As Long
Dim hDCscr As Long

picCapture.Move 5000, 5000, frm.Width, frm.Height

frm.AutoRedraw = True

If frm.BorderStyle <> 0 Then
titleBarheight = GetSystemMetrics(SM_CYCAPTION)
windowFrameHeight = GetSystemMetrics(SM_CYFRAME)
windowframewidth = GetSystemMetrics(SM_CXFRAME)
yDeviation = titleBarheight + windowFrameHeight
xDeviation = windowframewidth
Else
yDeviation = 0
xDeviation = 0
End If

frm.BackColor = m_BlendColor

Pic.Cls

hDCscr = CreateDC("DISPLAY", "", "", 0)

BitBlt Pic.hdc, 0, 0, frm.Width, frm.Height, hDCscr, frm.Left / Screen.TwipsPerPixelX + xDeviation, frm.Top / Screen.TwipsPerPixelX + yDeviation, vbSrcCopy 'vbSrcErase
frm.Cls

BlendVal = 11796480

AlphaBlend frm.hdc, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, Pic.hdc, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, BlendVal

DeleteDC hDCscr

End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

m_BlendColor = PropBag.ReadProperty("BlendColor", m_def_BlendColor)

End Sub

Public Property Get BlendColor() As OLE_COLOR

BlendColor = m_BlendColor

End Property

Public Property Let BlendColor(ByVal New_BlendColor As OLE_COLOR)

m_BlendColor = New_BlendColor
PropertyChanged "BlendColor"

End Property

Private Sub UserControl_InitProperties()

m_BlendColor = m_def_BlendColor

End Sub

Private Sub UserControl_Resize()

Image1.Move 0, 0
Width = Image1.Width
Height = Image1.Height

End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

Call PropBag.WriteProperty("BlendColor", m_BlendColor, m_def_BlendColor)

End Sub

使用：添加该控件（Translucency1）
Private Sub Form_Load()
Translucency1.drawTranslucency
End Sub

...全文

25 42 打赏收藏转发到动态举报

写回复

用AI写文章

42 条回复

切换为时间正序

请发表友善的回复…

发表回复

shengdesan 2002-12-26

打赏
举报

用不了
shengdesan@sohu.com

enmity 2002-06-12

打赏
举报

已经发送，请查收

gmlwx 2002-06-12

打赏
举报

我也试过，但也不能！能给我来个源程序吗？
-------------------------------------------------
gmlwx@21cn.com

adv_21 2002-05-18

打赏
举报

谢过！！~

smint 2002-05-16

打赏
举报

不错.关键在于
Private Declare Function AlphaBlend Lib "msimg32" (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 WidthSrc As Long, ByVal HeightSrc As Long, ByVal dreamAKA As Long) As Long

把screen抓下来贴上去.不过可能有潜在的一些问题.不能和系统的Layer函数相同.不过还是很有创意的.