如何用vb编制半透明窗体.txt

VB技巧问答10000例 VB技巧问答10000例

说明：表单一个Form1，图片框一个PicShape，在图片框内放置任何图片时，系统将使用图片框中的图片为窗体，并且屏蔽图片中白色部分，从而建立特效的变形窗体。 
    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 picShape_Click() 
     
    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 
<END>     
    （主持人注：下面的方法仅适用于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 
     
     'If blnok Then 
     SetLayeredWindowAttributes frm.hwnd, Color, 180, LWA_COLORKEY Or LWA_ALPHA 
     'Else 
     'SetLayeredWindowAttributes frm.hWnd, Color, 112, LWA_COLORKEY Or LWA_ALPHA 
     'End If 
     
    End Sub 
<END>