VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
查看: 1125|回复: 14

[求助] 如何用VB实现半透明控件

[复制链接]
发表于 2017-5-4 11:20:12 | 显示全部楼层 |阅读模式
我想用VB做半透明的控件,在网上找到了一段代码,可我用后不能实现半透明,文章里说将会得到一个粉红色半透明的方块,可我做完后是红色不透明的,请教高手是怎么回事。怎么解决,先谢谢了
下面是从网上找到的文章:
本代码演示半透明控件的实现过程。如果是自定义控件,实现起来非常简单,如果是系统控件,则要复杂一些。如果系统控件支持属主画,跟自定义控件思路完全是一样的,只不过代码是写在子类化的过程里。

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

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事件里输入以下代码:

Private Sub Form_Activate()  
    Me.UserControl11.Translucence  
End Sub  

    最后,你将看到一个粉红色半透明的方块,该方块就是你所需要的半透明的控件。至于控件的其它功能,读者可以自行扩展。
 楼主| 发表于 2017-5-4 22:20:32 | 显示全部楼层
如果这个不行,请问还有别的方法吗?
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-5-4 22:21:36 | 显示全部楼层
如果这个不行,请问还有别的方法吗?
回复 支持 反对

使用道具 举报

发表于 2017-5-5 20:58:06 | 显示全部楼层
没毛病呀,是可以用的


回复 支持 反对

使用道具 举报

发表于 2017-5-5 21:00:13 | 显示全部楼层
没毛病呀,是可以用的


回复 支持 反对

使用道具 举报

发表于 2017-5-5 21:01:04 | 显示全部楼层
没毛病呀,是可以用的

2017-05-05_205406.jpg
半透明控件.rar (2.3 KB, 下载次数: )
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-5-6 21:45:36 | 显示全部楼层
为什么在我的电脑上就不行呢?用户控件不是可以加很多的吗?难道只有第一个可以第二个以后就不行了?
难道我电脑是不是出什么问题?
QQ截图20170506201318.jpg

半透明控件.rar

6.85 KB, 下载次数: 33

回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-5-6 21:48:13 | 显示全部楼层
ymismy 发表于 2017-5-5 21:01
没毛病呀,是可以用的

对了,你用的是什么版本 是VB.NET还是6.0
我用的是6.0,跟这有关系吗?
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-5-6 21:48:28 | 显示全部楼层
ymismy 发表于 2017-5-5 21:01
没毛病呀,是可以用的

对了,你用的是什么版本 是VB.NET还是6.0
我用的是6.0,跟这有关系吗?
回复 支持 反对

使用道具 举报

 楼主| 发表于 2017-5-6 21:48:46 | 显示全部楼层
ymismy 发表于 2017-5-5 21:01
没毛病呀,是可以用的

对了,你用的是什么版本 是VB.NET还是6.0
我用的是6.0,跟这有关系吗?
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

文字版|手机版|小黑屋|VBGood  

GMT+8, 2017-11-24 08:22

VB爱好者乐园(VBGood)
快速回复 返回顶部 返回列表