实现透明窗体的问题

Question

想用VB做一个能通过过滤某种颜色来实现透明窗体的程序，以前通过GetPixel, CreateRectRGN, CombineRGN，SetWindowRGN等一系列API来实现透明效果，但图片尺寸大起来，这法子也不好使了（太慢了），还请大家帮帮忙！！！（WINDOWS 98 系统，最好不要使用第三方控件)
惭愧呀，我可用分只有40分，呜！

Answer 1

在 Win2K 中很容易实现，但在 Win98 系统没有现成的 API 可用，关注！！

Answer 2

WINDOWS 98 系统不太好办？
学习……

Answer 3

'用法：
' SetColorMask( 窗口句柄, 位图句柄, 透明色[默认:紫色], 质量[默认:256] )
'
' 例：为 Form1 的背景图片设置透明色(100, 180, 200)，
' SetColorMask( Form1.hWnd, Form1.Picture.Handle, RGB(100, 180, 200) )
'
' 注：“质量”值越高 SetColorMask 执行速度越慢，但程序重绘速度越快。
'
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 Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Private Type RGNDATAHEADER
        dwSize As Long
        iType As Long
        nCount As Long
        nRgnSize As Long
        rcBound As RECT
End Type
Private Declare Function ExtCreateRegion Lib "gdi32" (lpXform As Any, ByVal nCount As Long, lpRgnData As Any) As Long
Private Type BITMAPINFOHEADER '40 bytes
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
End Type
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFOHEADER, ByVal wUsage As Long) As Long
Private Const BI_RGB = 0&
Private Const RDH_RECTANGLES = 1&
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As LongFunction SetColorMask(ByVal hwnd As Long, ByVal hBitmap As Long, Optional ByVal crColor As Long = vbMagenta, Optional ByVal lQuality As Long = &H100&) As Boolean
  Const TRUEAPI = 1&
  Const FALSEAPI = 0&
  Const NULLAPI = 0&
  Dim hdc As Long: hdc = CreateCompatibleDC(NULLAPI)
  If hdc Then
    Dim biInfo As BITMAPINFOHEADER: biInfo.biSize = Len(biInfo)
    If GetDIBits(hdc, hBitmap, 0&, 0&, ByVal NULLAPI, biInfo, BI_RGB) Then
      Dim bitsBmp() As Long
      With biInfo
        .biHeight = -.biHeight
        .biBitCount = 32
        .biCompression = BI_RGB
        ReDim bitsBmp(.biWidth * (-.biHeight) - 1&)
      End With
      If GetDIBits(hdc, hBitmap, 0&, -biInfo.biHeight, bitsBmp(0&), biInfo, BI_RGB) Then
        Dim lX As Long, lY As Long, lCurIndex As Long, lState As Long, l As Long, _
          lRctCount As Long, lCurRect As Long, lRowRct As Long, _
          lLastRowRct As Long, rctRgn() As RECT, lRowState As Long
        lRctCount = 15&: lCurRect = 2&: lLastRowRct = 2&: ReDim rctRgn(lRctCount)
        For lY = 0& To (-biInfo.biHeight) - 1&
          For lX = 0& To biInfo.biWidth - 1&
            If (bitsBmp(lCurIndex) <> crColor) Then
              If (lState = 0&) Then
                lState = 1&
                With rctRgn(lCurRect)
                  .Top = lY: .Bottom = lY + 1&: .Left = lX
                End With
              End If
              rctRgn(lCurRect).Right = lX + 1&
              If lX = (biInfo.biWidth - 1&) Then lState = 2&
            End If
            If ((bitsBmp(lCurIndex) = crColor) And (lState = 1&)) Or _
              (lX = (biInfo.biWidth - 1&)) Then
              For l = lRowRct To lCurRect - 1&
                If (rctRgn(lCurRect).Left = rctRgn(l).Left) And _
                  (rctRgn(lCurRect).Right = rctRgn(l).Right) And _
                  (rctRgn(lCurRect).Bottom = (rctRgn(l).Bottom + 1)) Then _
                  rctRgn(l).Bottom = rctRgn(lCurRect).Bottom: Exit For
              Next
              If l >= lCurRect Then lState = 2& Else lState = 0&: lRowState = 1&
            End If
            If lState = 2& Then
              lCurRect = lCurRect + 1&
              If (lCurRect > lRctCount) Then
                Do: lRctCount = lRctCount + 16&
                Loop While lCurRect > lRctCount
                ReDim Preserve rctRgn(lRctCount)
              End If
              lState = 0&
            End If
            lCurIndex = lCurIndex + 1&
          Next
          If (lRowState = 0&) Or ((lCurRect - lRowRct) > lQuality) Then
            lRowRct = lLastRowRct
            lLastRowRct = lCurRect
          Else: lRowState = 0&
          End If
        Next
        Dim rgnHeader As RGNDATAHEADER
        rgnHeader.dwSize = Len(rgnHeader)
        rgnHeader.iType = RDH_RECTANGLES
        rgnHeader.nCount = lCurRect - 2&
        rgnHeader.nRgnSize = rgnHeader.nCount * Len(rctRgn(0&))
        rgnHeader.rcBound.Right = biInfo.biWidth
        rgnHeader.rcBound.Bottom = -biInfo.biHeight
        CopyMemory rctRgn(0&), rgnHeader, Len(rgnHeader)
        Dim hRgn As Long
        hRgn = ExtCreateRegion(ByVal NULLAPI, lCurRect * Len(rctRgn(0&)), rctRgn(0&))
        If hRgn Then
          If SetWindowRgn(hwnd, hRgn, TRUEAPI) Then SetColorMask = True
        End If
      End If
      Erase bitsBmp
    End If
    DeleteDC hdc
  End If
End Function

Answer 4

用Bit..这个函数哦。具体的名称我也搞忘了的，大家可以用API View 来查看的 。

Answer 5

顺便问一下 停止透明怎么处理
不要0%
要完全回到没透明的时候===============================
-= www.PoP4u.net =-