原tab控件，仿360开关控件版权归原作者! VB控件背景透明代码来自：新浪 “玄雨清风”的博客 感谢以上两位源代码作者 链接:http://pan.baidu.com/s/1hrAEXqG 密码:nfhc '-----------------------以下是转自博客的控件透明源代码(可透明至父窗体或桌面)------------- '添加一个用户控件UserControl,代如下： Option Explicit '实现用户控件UserControl的"伪透明" 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 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 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 GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Const WM_ERASEBKGND = &H14 Private Const WM_PAINT = &HF Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) Private m_BK As Boolean '复制控件在父窗口的背景 Private Sub CopyParentBackground(ByVal phWnd As Long, ByVal chWnd As Long, ByVal hDestDC As Long) Dim lpRect As RECT, lpPoint As POINTAPI, nWidth As Long, nHeight As Long Dim BitMap As Long, oldBitMap As Long, hDC As Long, memDC As Long Call GetWindowRect(phWnd, lpRect) 'Call GetClientRect(phWnd, lpRect) nWidth = lpRect.Right - lpRect.Left '获取控件的宽度 nHeight = lpRect.Bottom - lpRect.Top '获取控件的高度 hDC = GetDC(0) BitMap = CreateCompatibleBitmap(hDC, nWidth, nHeight) Call ReleaseDC(0, hDC) memDC = CreateCompatibleDC(0) oldBitMap = SelectObject(memDC, BitMap) Call SendMessage(phWnd, WM_ERASEBKGND, memDC, 0) Call SendMessage(phWnd, WM_PAINT, memDC, 0) '至此memDC上已经保存了父窗口的背景内容 '用户可以调用BitBlt(...)等函数拷贝memDC的内容到子窗口的某个区域， '这样就达到了透明效果; Call GetWindowRect(chWnd, lpRect) lpPoint.X = lpRect.Left lpPoint.Y = lpRect.Top Call ScreenToClient(phWnd, lpPoint) '获取控件在父窗口的左上角位置 Call BitBlt(hDestDC, 0, 0, nWidth, nHeight, memDC, lpPoint.X, lpPoint.Y, SRCCOPY) ''''''''''''''''''''''复制背景之后,在这里可以其他事情'''''''''''''''''''''''''''' UserControl.CurrentY = 10 UserControl.Print "透明用户控件" UserControl.Refresh ' Call SelectObject(memDC, oldBitMap) Call DeleteDC(memDC) Call DeleteObject(BitMap) End Sub '复制控件在屏幕的背景 Private Sub CopyScreenBackground(ByVal phWnd As Long, ByVal chWnd As Long, ByVal hDestDC As Long) Dim lpRect As RECT, nWidth As Long, nHeight As Long, hDC As Long Call GetWindowRect(chWnd, lpRect) nWidth = lpRect.Right - lpRect.Left '获取控件的宽度 nHeight = lpRect.Bottom - lpRect.Top '获取控件的高度 ShowWindow chWnd, 0 '隐藏 DoEvents hDC = GetDC(0) Call BitBlt(hDestDC, 0, 0, nWidth, nHeight, hDC, lpRect.Left, lpRect.Top, SRCCOPY) Call ReleaseDC(0, hDC) ShowWindow chWnd, 5 '显示 ''''''''''''''''''''''复制背景之后,在这里可以其他事情'''''''''''''''''''''''''''' UserControl.CurrentY = 10 UserControl.Print "透明用户控件" UserControl.Refresh End Sub Private Sub UserControl_Initialize() UserControl.ScaleMode = vbPixels End Sub Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) RaiseEvent MouseDown(Button, Shift, X, Y) End Sub Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) RaiseEvent MouseMove(Button, Shift, X, Y) End Sub Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) RaiseEvent MouseUp(Button, Shift, X, Y) CopyBKImage m_BK End Sub Private Sub UserControl_Resize() On Error Resume Next CopyBKImage m_BK End Sub Private Sub UserControl_Show() CopyBKImage m_BK End Sub Public Property Let CopyBKMode(ByVal bkm As Boolean) m_BK = bkm End Property Public Property Let BorderStyle(BStyle As Boolean) If BStyle = True Then UserControl.BorderStyle = 1 Else UserControl.BorderStyle = 0 End If End Property Public Sub Refresh() CopyBKImage m_BK UserControl.Refresh End Sub Private Sub CopyBKImage(Optional ByVal flag As Boolean = False) If flag = True Then CopyScreenBackground UserControl.Parent.hwnd, UserControl.hwnd, UserControl.hDC Else CopyParentBackground UserControl.Parent.hwnd, UserControl.hwnd, UserControl.hDC End If End Sub '''''''''''''''''''''''''''''''调用实例''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''Form1代码'''''''''''''''''''''''''''''' Option Explicit Dim LabX As Single, LabY As Single, IsMouseDownLab As Boolean Private Sub ctl1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) IsMouseDownLab = True LabX = X: LabY = Y End Sub Private Sub ctl1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If IsMouseDownLab = True Then '移动ctl1的位置 If Button = 1 Then ctl1.Move ctl1.Left + Me.ScaleX(X - LabX, 3, 3), ctl1.Top + ScaleX(Y - LabY, 3, 3) End If End Sub Private Sub ctl1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) IsMouseDownLab = False End Sub Private Sub Form_Load() Me.ScaleMode = vbPixels ctl1.CopyBKMode = True '复制控件在屏幕的背景 ctl2.CopyBKMode = False '默认值,复制控件在父窗口的背景 ctl2.BorderStyle = True '有边框 ctl1.BorderStyle = False '无边框 End Sub

比网上其他版本(也包括之前在此发的两次)修正： 去除tab只有9页的限制 修正tab页宽度超过1万后，应该在其他页中的控件会留一部分在当前页 放多个没有left、top或WhatsThisHelpID的控件不会产生错误(只是不会随页变动) 修正tabstop不能保持原值错误 修正鼠标停在tab上会不断刷新占用系统资源甚至内存溢出错误(去除usercontrol_mouseover中refresh) tab标题头背景透明处理(美化了^_^) '-------------------------------------------- 修正后仍存在的不足 -------------------------------- 1、控件必须编译后使用，否则一旦拖放出新的adodc等会让自定义控件变为不可用状态的控件，TAB则会跳页错乱! 2、tab控件中的WhatsThisHelpID属性被占用(-_-#，没办法，为了省系统资源，好在多数控件有这个属性且基本没人用，偷笑^^) 3、没有WhatsThisHelpID属性的控件不会随页变动 4、如果把本控件的BackColor设成&H00FF00DA& ，则所有放在Tab页上的控件将与背景一起被透明掉。 (本控件会重画放在其上的控件，所以控件也会被透明) 这个问题其实不算问题，没人必须把背景色设的和这个完全一样吧^^，哪怕差1也可以啊，点明这个问题只是要说明本控件的背景透明或任意形状控件的制作原理 原理： backstyle设为：0 maskColor设为：&H00FF00DA& (这个控件里UserControl的BackColor也要设为：&H00FF00DA&) 在Refresh方法中将在UserControl中重绘好的图作为maskPicture，即： Set UserControl.MaskPicture = UserControl.Image 这样maskpicture中背景没有被重绘的部分保持&H00FF00DA&(即与maskcolor指定的颜色相同色)，该颜色的部分即被透明 (注意，指定了backstyle=0及maskpicture后超出maskpicture大小的部分全部会被透明)!!! '---------------------------------------------------------比这个前一个版本的是没有用API的，可以在我的资源里找到前两次修改的版本，使用的话还是用这个版本 这几个控件有很多可学的地方， 比如其中的错误处理(网上的源码和我上一个修改版本的源码中错误处理的部分是不太合理的，虽然我和这个控件的其他修改者一样思路，但研究后最终还是用这次发布的这个版本) 比如上一版本中的无API绘图，这个版本有api，因此图大小可变 -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- 测试.vbp那个是原先旧版的测试，没有跟着新版修改，所以不兼容，此楼新版是经过测试的，编译好的ocx可以直接使用(★必须使用编译好的ocx，原因一楼已经说了★) 对编译好的ocx有疑问或自己要改进的可以直接修改TabSwitch.vbp，再重新编译

Static、Edit、Check Box、Radio等常用控件透明的方法，无需重写类，解决重影问题。 仅在VS2012下测试通过。

visual c++ vc Static控件背景透明时 文字覆盖问题的解决方案.zip