让图片框透明的代码

我们知道，利用API函数可以使窗体透明，但图片框无法透明。下面介绍一个类模块Trans，可以使图片框透明，注意图片框的ScaleMode = 3

Option Explicit

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) 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 CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Public Sub Lucency(Color As Long, Pic As PictureBox) 'Color-要透明的颜色
Dim CurRgn As Long, TempRgn As Long '地域变量
Dim colPoints As Collection '保留所有像素点
Set colPoints = New Collection
Dim X As Integer, Y As Integer
Dim dblHeight As Double, dblWidth As Double
Dim lngHDC As Long
Dim booMiddleOfSet As Boolean '为需要透明的像素点做标记
Dim Z As Variant '在迭代到收集期间使用
Dim dblTransY As Double '这3个变量包含将被透明的像素点
Dim dblTransStartX As Double
Dim dblTransEndX As Double

With Pic
  lngHDC = .hdc
  dblHeight = .ScaleHeight
  dblWidth = .ScaleWidth
End With
booMiddleOfSet = False

'收集所有需要透明的点
For Y = 0 To dblHeight  '遍历每一列像素
  dblTransY = Y
  For X = 0 To dblWidth  '遍历每一行像素
    If TypeOf Pic Is Form Then
      If GetPixel(lngHDC, X, Y) = Color Then
        If booMiddleOfSet = False Then
          dblTransStartX = X
          dblTransEndX = X
          booMiddleOfSet = True
        Else
          dblTransEndX = X
        End If
      Else
        If booMiddleOfSet Then
          colPoints.Add Array(dblTransY, dblTransStartX, dblTransEndX)
          booMiddleOfSet = False
        End If
      End If
    ElseIf TypeOf Pic Is PictureBox Then
      If Pic.Point(X, Y) = Color Then
        If booMiddleOfSet = False Then
          dblTransStartX = X
          dblTransEndX = X
          booMiddleOfSet = True
        Else
          dblTransEndX = X
        End If
      Else
        If booMiddleOfSet Then
          colPoints.Add Array(dblTransY, dblTransStartX, dblTransEndX)
          booMiddleOfSet = False
        End If
      End If
    End If
  Next X
Next Y

CurRgn = CreateRectRgn(0, 0, dblWidth, dblHeight)  '创建基础区域，即当前整个窗口

For Each Z In colPoints   '开始透明
  TempRgn = CreateRectRgn(Z(1), Z(0), Z(2) + 1, Z(0) + 1)  '为这个像素创建一个临时像素区域
  CombineRgn CurRgn, CurRgn, TempRgn, 4 '将临时像素区域与基础区域结合，提取像素并使其透明
  DeleteObject (TempRgn)  '删除临时区域，释放资源
Next

SetWindowRgn Pic.hwnd, CurRgn, True
Set colPoints = Nothing
End Sub

在窗体中调用的代码如下：

Option Explicit

'Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Dim tRan As New Trans

Private Sub Form_Load()
Picture1.Picture = LoadPicture(App.Path & "\101.ico") '这里是全路径图片文件名
End Sub

Private Sub Command1_Click()
'SetWindowLong hwnd, -20, &H80000
'SetLayeredWindowAttributes hwnd, BackColor, 0, 1 '窗体透明
tRan.Lucency Picture1.Point(1, 1), Picture1 '图片框透明
End Sub

Private Sub Command2_Click()
'SetWindowLong hwnd, -20, &H80000
'SetLayeredWindowAttributes hwnd, BackColor, 255, 2 '窗体不透明
tRan.Lucency &HFFFFFF, Picture1 '图片框不透明
End Sub

去掉代码中API函数前面的注释符，就可以透明窗体。