＋设为首页 ＋添加到收藏夹
建立一个form，再在form上面放一个image控件，image控件有一幅透明的图片，我怎么样让form和image控件透明而只显示那幅透明图片，最终结果是要透过透明的图片可以看见后面的窗体桌面等等，图片不会因为窗体的透明而模糊掉或者没有了
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Sub Form_Load()
Dim hBitmap As Integer
Me.AutoRedraw = True
hBitmap = CreateCompatibleBitmap(Me.hdc, 0, 0)
SelectObject Me.hdc, hBitmap
Me.Refresh
End Sub
这个代码粘过来来了
控件是Timer1，Picture1，还有两个图片Y5.bmp，\y4.bmp，还有个LABLE1，这下应该解决了吧
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
Private Const RGN_OR = 2
Private Sub Form_Load()
Picture1.ScaleMode = vbPixels 设置度量单位为像素
Picture1.AutoRedraw = True 自动重绘
Picture1.AutoSize = True
Picture1.BorderStyle = vbBSNone
Me.BorderStyle = vbBSNone
Set Picture1.Picture = LoadPicture(App.Path & "\y4.bmp")
Dim WindowRegion As Long
WindowRegion = getpic(Picture1)
SetWindowRgn Me.hWnd, WindowRegion, True
End Sub
Public Function getpic(pic As PictureBox) As Long
Dim I As Long, j As Long, linex As Long
Dim lineall, myline, mycolor As Long
Dim mystart, mybool As Boolean
Dim hDC As Long, PicWidth, PicHeight As Long
hDC = pic.hDC
mystart = True
mybool = False
I = 0
j = 0
PicWidth = pic.ScaleWidth
PicHeight = pic.ScaleHeight
linex = 0
mycolor = GetPixel(hDC, 0, 0)
For j = 0 To PicHeight - 1
For I = 0 To PicWidth - 1
If GetPixel(hDC, I, j) = mycolor Or I = PicWidth Then 如果是透明像素
If mybool Then
mybool = False
myline = CreateRectRgn(linex, j + 1, I, j)
If mystart Then
lineall = myline
mystart = False
Else
CombineRgn lineall, lineall, myline, RGN_OR 剪裁区域
End If
End If
Else
If Not mybool Then
mybool = True
linex = I + 2
End If
End If
Next
Next
getpic = lineall
End Function
Private Sub Timer1_Timer() 半透明动画
Me. = Me. - 20
Dim WindowRegion As Long
Set Picture1.Picture = LoadPicture(App.Path & "\Y5.bmp")
Label1.Caption = "太阳出来了！"
WindowRegion = getpic(Picture1)
SetWindowRgn Me.hWnd, WindowRegion, True
End Sub
Private Sub Picture1_Click()
End
End Sub
这个是 把图片中白色部分变成透明。
把下面的过程放到标准模块中。
用的时候，在form中放一个和窗体一样大的 picturebox，在这个picturebox 中的picture属性
放一张部分白色的图片。
像这样调用就可以了：
Public Sub Form_Load()
FitToPicture picMain, Me
End Sub
Option Explicit
Public Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Public Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
