求救透明控件（VB）

Question

请问各位什么地方有透明的控件，并且能在控件上画点、线、圆

Answer 1

透明的窗体Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd _
    As Long, lpRECT As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd _
    As Long, lpRECT As RECT) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn _
    As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, _
    ByVal nCombineMode As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As _
    Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) _
    As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd _
    As Long, lpPoint As POINTAPI) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As _
    Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As LongConst RGN_XOR = 3Private Type POINTAPI
    x As Long
    Y As Long
End TypePrivate Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End TypePrivate rctClient As RECT, rctFrame As RECT
Private hClient As Long, hFrame As LongPublic Sub MakeTransparent(frm As Form)
    GetFrameClientRgn frm
    SetWindowRgn frm.hWnd, hFrame, True
End SubPrivate Sub GetFrameClientRgn(frm As Form)
    GetWindowRect frm.hWnd, rctFrame
    GetClientRect frm.hWnd, rctClient    '将窗口矩形坐标转换为屏幕坐标
    Dim lpTL As POINTAPI, lpBR As POINTAPI
    lpTL.x = rctFrame.Left
    lpTL.Y = rctFrame.Top
    lpBR.x = rctFrame.Right
    lpBR.Y = rctFrame.Bottom
    ScreenToClient frm.hWnd, lpTL
    ScreenToClient frm.hWnd, lpBR
    rctFrame.Left = lpTL.x
    rctFrame.Top = lpTL.Y
    rctFrame.Right = lpBR.x
    rctFrame.Bottom = lpBR.Y
    rctClient.Left = Abs(rctFrame.Left)
    rctClient.Top = Abs(rctFrame.Top)
    rctClient.Right = rctClient.Right + Abs(rctFrame.Left)
    rctClient.Bottom = rctClient.Bottom + Abs(rctFrame.Top)
    rctFrame.Right = rctFrame.Right + Abs(rctFrame.Left)
    rctFrame.Bottom = rctFrame.Bottom + Abs(rctFrame.Top)
    rctFrame.Top = 0
    rctFrame.Left = 0    hClient = CreateRectRgn(rctClient.Left, rctClient.Top, _
    rctClient.Right, rctClient.Bottom)
    hFrame = CreateRectRgn(rctFrame.Left, rctFrame.Top, _
    rctFrame.Right, rctFrame.Bottom)    CombineRgn hFrame, hClient, hFrame, RGN_XOR
End SubPrivate Sub Form_Resize()
    MakeTransparent Me
End Sub

Answer 2

自己做一个 用户控件吧 ，把BackStyle =0 就行了

Answer 3

这个完全能行的通的,我做过!
自己写控件,然后在控件上放一个shape(但是picturebox好想是比较难实现!)
         
就可以了!画图什么可以使用属性传递给控件.
在Property Let"属性"中调用函数,画图!
在设置控件的时候,要设置BackStyle为0(即透明)
或者在运行阶段设置BackStyle=0如果在控件上加载图片可以相应的写函数给控件改变图片!
用同样的方式:使用属性传递的方式产生改变图片的事件!
在控件中函数为:
Private Sub ChangePic(ByVal n As Integer)
    If n = 0 Then
        UserControl.MaskColor = QBColor(15)
        UserControl.Picture = LoadPicture(App.path & "\icon\pic1.gif")
        UserControl.MaskPicture = LoadPicture(App.path & "\icon\pic1.gif")
    ElseIf n = 1 Then
        UserControl.MaskColor = QBColor(15)
        UserControl.Picture = LoadPicture(App.path & "\icon\pic2.gif")
        UserControl.MaskPicture = LoadPicture(App.path & "\icon\pic2.gif")
    End If
End Sub另外,如果使用picturebox的话,在控件中大概要写如下代码,但具体没有试过!Private Type Bitmap
  Type As Long ' 位图类型
  Width As Long '宽度
  Height As Long '高度
  WidthBytes As Long '多少二进制位构成一个存储单位
  Planes As Integer '调色板数
  BitsPixel As Integer '每一个Pixel所占用的二进制位数
  Bits As Long '二进制位数据的起始位置
End Type
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) 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 BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hsourceDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long '图象转移
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteDC 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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Sub Transparent(ByVal sourceBmp As Long, destObject As Control, ByVal destX As Integer, ByVal destY As Integer, ByVal TransColor As Long)
  Dim sourceDC As Long  '源位图
  Dim destScale As Long
  Dim maskDC As Long    'mask位图
  Dim saveDC As Long    '源位图的备份
  Dim resultDC As Long  '源位图与背景的合并
  Dim invDC As Long     'Mask位图的反向图
  Dim OrigColor As Long '背景色
  Dim lResult As Long   '调用 Windows API的结果  Dim bmpTemp As Bitmap   '原位图的数据结构说明
  Dim hResultBmp As Long  '源与背景的位图合并
  Dim hSaveBmp As Long    '原位图的拷贝
  Dim hSrcPrevBmp As Long
  Dim hDestPrevBmp As Long
  Dim hInvBmp As Long     '反转掩码位图 (monochrome)
  Dim hPrevBmp As Long
  Dim hInvPrevBmp As Long
  Dim hSavePrevBmp As Long
  Dim hMaskBmp As Long
  Dim hMaskPrevBmp As Long
'设置度量单位
  destScale = destObject.ScaleMode
  destObject.ScaleMode = vbPixels
'建立存储器DC
  sourceDC = CreateCompatibleDC(destObject.hdc)
  saveDC = CreateCompatibleDC(destObject.hdc)
  invDC = CreateCompatibleDC(destObject.hdc)
  maskDC = CreateCompatibleDC(destObject.hdc)
  resultDC = CreateCompatibleDC(destObject.hdc)
'接受源位图得到它的的宽度和长度
  lResult = GetObject(sourceBmp, Len(bmpTemp), bmpTemp)
'创建单色掩码位图
  hMaskBmp = CreateBitmap(bmpTemp.Width, bmpTemp.Height, 1, 1, ByVal 0&)
  hInvBmp = CreateBitmap(bmpTemp.Width, bmpTemp.Height, 1, 1, ByVal 0&)
  hResultBmp = CreateCompatibleBitmap(destObject.hdc, bmpTemp.Width, bmpTemp.Height)
  hSaveBmp = CreateCompatibleBitmap(destObject.hdc, bmpTemp.Width, bmpTemp.Height)
'为设备场景都设置图形对象
  hSrcPrevBmp = SelectObject(sourceDC, sourceBmp)
  hSavePrevBmp = SelectObject(saveDC, hSaveBmp)
  hMaskPrevBmp = SelectObject(maskDC, hMaskBmp)
  hInvPrevBmp = SelectObject(invDC, hInvBmp)
  hDestPrevBmp = SelectObject(resultDC, hResultBmp)
  
'拷贝背景图并创建最终的透明位图
  lResult = BitBlt(saveDC, 0, 0, bmpTemp.Width, bmpTemp.Height, sourceDC, 0, 0, vbSrcCopy) '制作源位图的拷贝以便后面恢复
  OrigColor = SetBkColor(sourceDC, TransColor)
  lResult = BitBlt(maskDC, 0, 0, bmpTemp.Width, bmpTemp.Height, sourceDC, 0, 0, vbSrcCopy)
  TransColor = SetBkColor(sourceDC, OrigColor)
  lResult = BitBlt(invDC, 0, 0, bmpTemp.Width, bmpTemp.Height, maskDC, 0, 0, vbNotSrcCopy)  lResult = BitBlt(resultDC, 0, 0, bmpTemp.Width, bmpTemp.Height, destObject.hdc, destX, destY, vbSrcCopy)
  lResult = BitBlt(resultDC, 0, 0, bmpTemp.Width, bmpTemp.Height, maskDC, 0, 0, vbSrcAnd)
  lResult = BitBlt(sourceDC, 0, 0, bmpTemp.Width, bmpTemp.Height, invDC, 0, 0, vbSrcAnd)
  lResult = BitBlt(resultDC, 0, 0, bmpTemp.Width, bmpTemp.Height, sourceDC, 0, 0, vbSrcInvert)
  lResult = BitBlt(destObject.hdc, destX, destY, bmpTemp.Width, bmpTemp.Height, resultDC, 0, 0, vbSrcCopy)
  lResult = BitBlt(sourceDC, 0, 0, bmpTemp.Width, bmpTemp.Height, saveDC, 0, 0, vbSrcCopy)
'选择对象以便释放
  hPrevBmp = SelectObject(resultDC, hDestPrevBmp)
  hPrevBmp = SelectObject(sourceDC, hSrcPrevBmp)
  hPrevBmp = SelectObject(saveDC, hSavePrevBmp)
  hPrevBmp = SelectObject(invDC, hInvPrevBmp)
  hPrevBmp = SelectObject(maskDC, hMaskPrevBmp)
'释放资源
  lResult = DeleteDC(saveDC)
  lResult = DeleteDC(invDC)
  lResult = DeleteDC(resultDC)
  lResult = DeleteObject(hSaveBmp)
  lResult = DeleteObject(hMaskBmp)
  lResult = DeleteObject(hInvBmp)
  lResult = DeleteDC(sourceDC)
  lResult = DeleteDC(maskDC)  lResult = DeleteObject(hResultBmp)
  destObject.ScaleMode = destScale '恢复 ScaleMode
End SubPrivate Sub cmdShow_Click()
  Call Transparent(picSource.Picture.Handle, picDest, 170, 80, QBColor(15))
End Sub
老弟,你做做，其实，我也在做这个，只是我的实现要求更多,
有很多还没有实现,我在csdn上问了，但是没有人回答啊!
郁闷!

Answer 4

以上控件中的第一个函数:
Private Sub ChangePic(ByVal n As Integer)
    If n = 0 Then
        UserControl.MaskColor = QBColor(15)
        UserControl.Picture = LoadPicture(App.path & "\icon\pic1.gif")
        UserControl.MaskPicture = LoadPicture(App.path & "\icon\pic1.gif")
    ElseIf n = 1 Then
        UserControl.MaskColor = QBColor(15)
        UserControl.Picture = LoadPicture(App.path & "\icon\pic2.gif")
        UserControl.MaskPicture = LoadPicture(App.path & "\icon\pic2.gif")
    End If
End Sub
 是对UserControl.MaskColor = QBColor(15) 白色的透空,如果要用别的颜色可以自己设定!