VB6如何设置半透明窗体和控件

先建一个标准EXE工程，然后添加一个用户控件，把以下代码复制到控件代码中，再把此控件放置到Form1上。

[vb] view plain copy

• Option Explicit  

• Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)  

• Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long  

• Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long  

• Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long  

• Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long  

• Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long  

• Private Type POINTAPI  

• X As Long  

• Y As Long  

• End Type  

• Private Type RECT  

• Left As Long  

• Top As Long  

• Right As Long  

• Bottom As Long  

• End Type  

• Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long  

• Private Const DT_SINGLELINE = &H20  

• Private Const DT_CENTER = &H1  

• Private Const DT_VCENTER = &H4  

• Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long  

• Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long  

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

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

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

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

• Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long  

• Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long  

• Private Const SW_SHOW = 5  

• Private Const SW_HIDE = 0  

• 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 blendFunct As Long) As Boolean  

• Dim m_hMemDC As Long  

• Dim m_hMemBmp As Long, m_hMemBmpPrev As Long  

• Dim m_rcControl As RECT  

• Private Sub UserControl_Initialize()  

• UserControl.AutoRedraw = True  

• UserControl.BackColor = vbRed  

• m_hMemDC = CreateCompatibleDC(UserControl.hdc)  

• End Sub  

• Private Sub UserControl_Terminate()  

• If m_hMemBmp <> 0 Then  

• DeleteObject SelectObject(m_hMemDC, m_hMemBmpPrev)  

• End If  

• DeleteDC m_hMemDC  

• End Sub  

• Public Sub Translucence()  

• Dim hdc As Long  

• Dim tPt As POINTAPI  

• '获得控件当前位置和大小  

• ClientToScreen UserControl.hwnd, tPt  

• ScreenToClient UserControl.ContainerHwnd, tPt  

• Call GetClientRect(UserControl.hwnd, m_rcControl)  

• OffsetRect m_rcControl, tPt.X, tPt.Y  

• '创建一幅内存位图  

• If m_hMemBmp <> 0 Then  

• DeleteObject (SelectObject(m_hMemDC, m_hMemBmpPrev))  

• End If  

• m_hMemBmp = CreateCompatibleBitmap(UserControl.hdc, m_rcControl.Right, m_rcControl.Bottom)  

• m_hMemBmpPrev = SelectObject(m_hMemDC, m_hMemBmp)  

• '隐藏控件  

• ShowWindow UserControl.hwnd, SW_HIDE  

• DoEvents  

• '保存控件容器的图像到内存位图中  

• Dim hDesktopDC As Long  

• hDesktopDC = GetDC(UserControl.hwnd)  

• BitBlt m_hMemDC, 0, 0, m_rcControl.Right, m_rcControl.Bottom, hDesktopDC, 0, 0, vbSrcCopy  

• ReleaseDC 0, hDesktopDC  

• '通过alpha效果进行半透明渲染  

• UserControl.AutoRedraw = True  

• AlphaBlend m_hMemDC, 0, 0, m_rcControl.Right, m_rcControl.Bottom, UserControl.hdc, 0, 0, m_rcControl.Right, m_rcControl.Bottom, 5242880  

• UserControl.AutoRedraw = False  

• '显示控件  

• ShowWindow UserControl.hwnd, SW_SHOW  

• '将渲染后的结果复制到控件中  

• BitBlt UserControl.hdc, 0, 0, m_rcControl.Right, m_rcControl.Bottom, m_hMemDC, 0, 0, vbSrcCopy  

• End Sub  

• Private Sub UserControl_Paint()  

• BitBlt UserControl.hdc, 0, 0, m_rcControl.Right, m_rcControl.Bottom, m_hMemDC, 0, 0, vbSrcCopy  

• End Sub  

在Form1的Form_Activate事件里输入以下代码：

[vb] view plain copy

• Private Sub Form_Activate()  

• Me.UserControl11.Translucence  

• End Sub  

最后，你将看到一个粉红色半透明的方块，该方块就是你所需要的半透明的控件。至于控件的其它功能，可以自行扩展。

好像不能实现，因为现在vb要实现窗体半透明的话，必须调用系统的api。而api是以窗体的句柄作为对象的。所以只要你一调用透明语句，就把窗体内所有的内容全部透明了。好象不能分别对待。