vb 让PictureBox控件透明 可加载gif 图片

将目标PictureBox的BackColor设置为白色，再调用ShapeMe RGB(255,255,255),True,PictureBox ，就可以让名称为PictureBox 的PictureBox 控件背景透明

'========================================'声明作用：透明化PictureBox，注意设置其背景颜色为纯白'========================================Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long,ByVal X As Long,ByVal Y As Long) As LongPrivate Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long,ByVal hRgn As Long,ByVal bRedraw As Boolean) As LongPrivate Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long,ByVal Y1 As Long,ByVal X2 As Long,ByVal Y2 As Long) As LongPrivate Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long,ByVal hSrcRgn1 As Long,ByVal hSrcRgn2 As Long,ByVal nCombineMode As Long) As LongPrivate Declare Sub ReleaseCapture Lib "user32" ()Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long,ByVal wMsg As Long,ByVal wParam As Long,lParam As Any) As LongPrivate Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPrivate Const RGN_DIFF = 4Dim CurRgn As Long,TempRgn As Long ' Region variables'========================================'函数名称：ShapeMe'函数作用：透明化PictureBox背景'========================================Public Sub ShapeMe(Color As Long,HorizontalScan As Boolean,Optional Name1 As Form = Nothing,Optional Name2 As PictureBox = Nothing) Dim X As Integer,Y As Integer 'points on form Dim dblHeight As Double,dblWidth As Double 'height and width of object Dim lngHDC As Long 'the hDC property of the object Dim booMiddleOfSet As Boolean 'used during the gathering of transparent points Dim colPoints As Collection 'this will hold all usrPoints Set colPoints = New Collection Dim Z As Variant 'used during iteration through collection Dim dblTransY As Double 'these 3 variables hold each point that will be made transparent Dim dblTransStartX As Double Dim dblTransEndX As Double Dim Name As Object 'will hold the name of the object. Late-bound and slower,but allows different types (in this case Form or PictureBox) 'check out the name or names passed into the subroutine If Name1 Is Nothing Xor Name2 Is Nothing Then 'we know there is a name in one of them If Name1 Is Nothing Then 'set the name Set Name = 界面上的PictureBox控件 Else Set Name = 界面上的PictureBox控件 End If Else 'both or none hold valid names MsgBox "Must pass in the name of either a Form OR a PictureBox. TransForm received NONE or BOTH. Function failed.",vbOKOnly,"ShapeMe Subroutine" Exit Sub End If 'initialization With Name .AutoRedraw = True 'object must have this setting .ScaleMode = 3 'object must have this setting lngHDC = .hdc 'faster to use a variable; VB help recommends using the property,but I didn't encounter any problems If HorizontalScan = True Then 'look for lines of transparency horizontally dblHeight = .ScaleHeight 'faster to use a variable dblWidth = .ScaleWidth 'faster to use a variable Else 'look vertically (note that the names "dblHeight" and "dblWidth" are non-sensical now,but this was an easy way to do this dblHeight = .ScaleWidth 'faster to use a variable dblWidth = .ScaleHeight 'faster to use a variable End If 'HorizontalScan = True End With booMiddleOfSet = False 'gather all points that need to be made transparent For Y = 0 To dblHeight ' Go through each column of pixels on form dblTransY = Y For X = 0 To dblWidth ' Go through each line of pixels on form 'note that using GetPixel appears to be faster than using VB's Point If TypeOf Name Is Form Then 'check to see if this is a form and use GetPixel function which is a little faster If GetPixel(lngHDC,X,Y) = Color Then ' If the pixel's color is the transparency color,record it If booMiddleOfSet = False Then dblTransStartX = X dblTransEndX = X booMiddleOfSet = True Else dblTransEndX = X End If 'booMiddleOfSet = False Else If booMiddleOfSet Then colPoints.Add Array(dblTransY,dblTransStartX,dblTransEndX) booMiddleOfSet = False End If 'booMiddleOfSet = True End If 'GetPixel(lngHDC,Y) = Color ElseIf TypeOf Name Is PictureBox Then 'if a PictureBox then use Point; a little slower but works when GetPixel doesn't If Name.Point(X,Y) = Color Then If booMiddleOfSet = False Then dblTransStartX = X dblTransEndX = X booMiddleOfSet = True Else dblTransEndX = X End If 'booMiddleOfSet = False Else If booMiddleOfSet Then colPoints.Add Array(dblTransY,dblTransEndX) booMiddleOfSet = False End If 'booMiddleOfSet = True End If 'Name.Point(X,Y) = Color End If 'TypeOf Name Is Form Next X Next Y CurRgn = CreateRectRgn(0,dblWidth,dblHeight) ' Create base region which is the current whole window For Each Z In colPoints 'now make it transparent TempRgn = CreateRectRgn(Z(1),Z(0),Z(2) + 1,Z(0) + 1) ' Create a temporary pixel region for this pixel CombineRgn CurRgn,CurRgn,TempRgn,RGN_DIFF ' Combine temp pixel region with base region using RGN_DIFF to extract the pixel and make it transparent DeleteObject (TempRgn) ' Delete the temporary region and free resources Next SetWindowRgn Name.hwnd,True ' Finally set the windows region to the final product 'I do not use DeleteObject on the CurRgn,going with the advice in Dan Appleman's book: 'once set to a window using SetWindowRgn,do not delete the region. Set colPoints = Nothing End Sub

（编辑：李大同）

【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!