如何在VB中利用API使Form背景独自透明

Question

这个问题我一直没有好的解决方法，用API实现VB程序窗口form透明是很容易的事情，但是同时会出现一个问题，即FORM上的button、picture、label也同时透明，我知道在VB.NET中可以通过设置参数使FORM中的某一种色彩透明，形成FORM背景单独透明的效果，但是在VB6中应该如何取实现呢？注：不是指程序窗口透明，这个我懂

Answer 1

想让button、label透明很简单，都用label设置label1.BackStyle =1
picture透明做什么，你让图片透明？不知道你的picture里放的是什么

Answer 2

楼上的误会了，我是要让form的背景透明，不是让button之类的透明，举个例子，我在form上放了个swf，并将swf设置为透明，但是后面还有一个form，如果我用API把form也设置为透明的，则form上的swf也会跟着一起透明，我现在需要的是让form看不见，但是form上的所有东西都能看见，这就是我说的form背景单独透明的意思。

Answer 3

Option Explicit
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
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
Const WS_EX_LAYERED = &H80000
Const GWL_EXSTYLE = (-20)
Const LWA_ALPHA = &H2
Const LWA_COLORKEY = &H1
Dim sty As Long
Dim cs As IntegerPrivate Sub Form_Load()
sty = GetWindowLong(Me.hwnd, GWL_EXSTYLE)
sty = sty Or WS_EX_LAYERED
SetWindowLong Me.hwnd, GWL_EXSTYLE, sty
SetLayeredWindowAttributes Me.hwnd, 0, 192, LWA_ALPHA
cs = 255
End SubPrivate Sub Timer1_Timer()
cs = cs - 5
SetLayeredWindowAttributes Me.hwnd, 0, cs, LWA_ALPHA
If cs <= 15 Then
cs = 255
End If
End Sub请观看Timer控件中cs改变使窗体透明效果会发生变化. 

Answer 4

说明：表单一个Form1，图片框一个PicShape，在图片框内放置任何图片时，系统将使用图片框中的图片为窗体，并且屏蔽图片中白色部分，从而建立特效的变形窗体。这代码来自VB编程技巧10000例(源江科技),供参考:
Option Explicit
Dim MoveTrue As Boolean, OldX As Long, OldY As Long
Private 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
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) 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 SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
 
Private Sub FitToPicture()
    Const RGN_OR = 2
    Dim border_width As Single
    Dim title_height As Single
    Dim bm As BITMAP
    Dim bytes() As Byte
    Dim ints() As Integer
    Dim longs() As Long
    Dim R As Integer
    Dim C As Integer
    Dim start_c As Integer
    Dim stop_c As Integer
    Dim x0 As Long
    Dim y0 As Long
    Dim combined_rgn As Long
    Dim new_rgn As Long
    Dim offset As Integer
    Dim colourDepth As Integer
    ScaleMode = vbPixels
    PicShape.ScaleMode = vbPixels
    PicShape.AutoRedraw = True
    PicShape.Picture = PicShape.Image
    ' 获取窗体的边框大小
    border_width = (ScaleX(Width, vbTwips, vbPixels) - ScaleWidth) / 2
    title_height = ScaleX(Height, vbTwips, vbPixels) - border_width - ScaleHeight
    ' 获取图片大小
    x0 = PicShape.Left + border_width
    y0 = PicShape.Top + title_height
    '给出图片信息
    GetObject PicShape.Image, Len(bm), bm
    Select Case bm.bmBitsPixel
    Case 15, 16:
    'MsgBox _
    "图片框中图片的颜色大高。",vbExclamation + vbOKOnly
    colourDepth = 2
    ' 分配空格给图片.
    ReDim ints(0 To bm.bmWidthBytes \ 2 - 1, 0 To bm.bmHeight - 1)
    ' 给出图片表面数据
    GetBitmapBits PicShape.Image, bm.bmHeight * bm.bmWidthBytes, ints(0, 0)
    ' 建立表单区域
    For R = 0 To bm.bmHeight - 2
    C = 0
    Do While C < bm.bmWidth
    start_c = 0
    stop_c = 0
    ' 查找白色区域,屏蔽
    Do While C < bm.bmWidth
    If (ints(C, R) And &H7FFF) <> &H7FFF Then Exit Do
    C = C + 1
    Loop
    start_c = C
    Do While C < bm.bmWidth
    If (ints(C, R) And &H7FFF) = &H7FFF Then Exit Do
    C = C + 1
    Loop
    stop_c = C
    If start_c < bm.bmWidth Then
    If stop_c >= bm.bmWidth Then stop_c = bm.bmWidth - 1
    new_rgn = CreateRectRgn(start_c + x0, R + y0, stop_c + x0, R + y0 + 1)
    If combined_rgn = 0 Then
    combined_rgn = new_rgn
    Else
    CombineRgn combined_rgn, combined_rgn, new_rgn, RGN_OR
    DeleteObject new_rgn
    End If
    End If
    Loop
    Next R
    Case 24:
    colourDepth = 3
    ReDim bytes(0 To bm.bmWidthBytes - 1, 0 To bm.bmHeight - 1)
    GetBitmapBits PicShape.Image, bm.bmHeight * bm.bmWidthBytes, bytes(0, 0)
    For R = 0 To bm.bmHeight - 2
    ' Create a region for this row.
    C = 0
    Do While C < bm.bmWidth
    start_c = 0
    stop_c = 0
    offset = C * colourDepth
    Do While C < bm.bmWidth
    If bytes(offset, R) <> 255 Or _
    bytes(offset + 1, R) <> 255 Or _
    bytes(offset + 2, R) <> 255 Then Exit Do
    C = C + 1
    offset = offset + colourDepth
    Loop
    start_c = C
    Do While C < bm.bmWidth
    If bytes(offset, R) = 255 And _
    bytes(offset + 1, R) = 255 And _
    bytes(offset + 2, R) = 255 _
    Then Exit Do
    C = C + 1
    offset = offset + colourDepth
    Loop
    stop_c = C
    If start_c < bm.bmWidth Then
    If stop_c >= bm.bmWidth Then stop_c = bm.bmWidth - 1
    ' 建立区域
    new_rgn = CreateRectRgn(start_c + x0, R + y0, stop_c + x0, R + y0 + 1)
    If combined_rgn = 0 Then
    combined_rgn = new_rgn
    Else
    CombineRgn combined_rgn, combined_rgn, new_rgn, RGN_OR
    DeleteObject new_rgn
    End If
    End If
    Loop
    Next R
    Case 32:
    colourDepth = 4
    ReDim longs(0 To bm.bmWidthBytes \ 4 - 1, 0 To bm.bmHeight - 1)
    GetBitmapBits PicShape.Image, bm.bmHeight * bm.bmWidthBytes, longs(0, 0)
    For R = 0 To bm.bmHeight - 2
    C = 0
    Do While C < bm.bmWidth
    start_c = 0
    stop_c = 0
    Do While C < bm.bmWidth
    If (longs(C, R) And &HFFFFFF) <> &HFFFFFF Then Exit Do
    C = C + 1
    Loop
    start_c = C
    Do While C < bm.bmWidth
    If (longs(C, R) And &HFFFFFF) = &HFFFFFF Then Exit Do
    C = C + 1
    Loop
    stop_c = C
    If start_c < bm.bmWidth Then
    If stop_c >= bm.bmWidth Then stop_c = bm.bmWidth - 1
    new_rgn = CreateRectRgn(start_c + x0, R + y0, stop_c + x0, R + y0 + 1)
    If combined_rgn = 0 Then
    combined_rgn = new_rgn
    Else
    CombineRgn combined_rgn, combined_rgn, new_rgn, RGN_OR
    DeleteObject new_rgn
    End If
    End If
    Loop
    Next R
    Case Else
    MsgBox "对不起，程序必须在 16位, 24-位 或 32-位 颜色下。", _
    vbExclamation + vbOKOnly
    Exit Sub
    End Select
    ' 设置表单外观为建立区域
    SetWindowRgn hwnd, combined_rgn, True
    DeleteObject combined_rgn
End Sub
     
Private Sub Form_Load()
    Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2
    FitToPicture
End Sub
     
Private Sub picShape_DblClick()
    Unload Me
End Sub
     
Private Sub picshape_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    MoveTrue = True
    OldX = x: OldY = y
End Sub
     
Private Sub picshape_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If MoveTrue = True Then
    Form1.Left = Form1.Left + x - OldX
    Form1.Top = Form1.Top + y - OldY
    End If
End Sub
     
Private Sub picshape_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    MoveTrue = False
End Sub    '下面的方法仅适用于Windows 2000/XP，因为SetLayeredWindowAttributes函数在其他系统中不支持。）
Public Sub NTSetfrmRgn(PicBox As PictureBox, frm As Form)
     '-------------------------------------------------
     ' 窗体形状及透明度
     ' Color (取得0,0处象素的颜色,即要裁减的区域的颜色
     ' SetLayeredWindowAttributes 设置透明度及窗体形状
     '-------------------------------------------------
     Dim WindowExs As Long, Color As Long
     frm.Picture = PicBox.Picture
     Color = GetPixel(PicBox.hDC, 0, 0)
     WindowExs = GetWindowLong(frm.hwnd, GWL_EXSTYLE)
     WindowExs = WindowExs Or WS_EX_LAYERED
     SetWindowLong frm.hwnd, GWL_EXSTYLE, WindowExs
     SetLayeredWindowAttributes frm.hwnd, Color, 180, LWA_COLORKEY Or LWA_ALPHA
End Sub

Answer 5

代码来自VB编程技巧10000例(源江科技),供参考: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 SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
    Const GWL_EXSTYLE = (-20)
    Const WS_EX_TRANSPARENT = &H20&
    Dim sj As BooleanPrivate Sub Command3_Click()
    Form1.Show
End SubPrivate Sub Form_Activate()
    SetWindowLong hwnd, GWL_EXSTYLE, WS_EX_TRANSPARENT
End SubPrivate Sub Form_Load()
    SetWindowLong hwnd, GWL_EXSTYLE, WS_EX_TRANSPARENT
End Sub
Private Sub Command1_Click()
    Print "Hello"
End Sub
     
Private Sub Command2_Click()
    End
End SubPrivate Sub Form_Click()
    If sj Then
        Me.WindowState = 2
    Else
        Me.WindowState = 0
    End If
    sj = Not sj
End Sub

Answer 6

楼上的用的Api是这些，就是思路不好。应该是从Form左上角开始到右下角。
遇到swf(应该是Flash控件吧)的地方就不处理其他地方都是透明。

Answer 7

可是这样flash控件还是有一个长方的背景不是透明的

Answer 8

使用API： SetLayeredWindowAttributes
定义：
Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongWS_EX_LAYERED = 0x80000;
LWA_ALPHA = 0x2;
LWA_COLORKEY=0x1 
其中dwFlags有LWA_ALPHA和LWA_COLORKEY
LWA_ALPHA被设置的话,通过bAlpha决定透明度.
LWA_COLORKEY被设置的话,则指定被透明掉的颜色为crKey,其他颜色则正常显示因此只要设置LWA_COLORKEY和crKey，并且将窗体背景色和控件颜色设为 不同的颜色，就可以做到楼主的要求，经实际测试可行

Answer 9

我上次用flashwindow函数的时候，把form1的autodraw属性设置为true，结果除了了窗口标题栏和控件可以看见以外，窗体背景就成了首次show的时候被遮盖的背景了