VB中如何显示异型的图窗体？

hisun

有张不规则的图想在VB中显示，如同一些软件的启动所展示的不规则图那样，我该如何才能实现这样的窗体？

Gorgon_Meducer

用API……

jinesc

这个你到CSDN去问下吧  

主题：如何用vb实现不规则形状的窗体
作者：lgonnet
日期：2001-9-3 11:50:13
分数：40
回复：5
------------------------------------------------------------------------------------------------------

_____________________________________________________________________

回复人：DTWUJP(建平)>>日期：2001-9-3 11:57:15

用API或用AVTIVESKIE控件。

_____________________________________________________________________

回复人：cuiyxy(沧海鲨鱼)>>日期：2001-9-3 16:33:35

在Windows 2000下实现很简单,98要费事的多
以下是在Windows 2000实现不规则形状，透明窗体的一段代码
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
'其中hwnd是透明窗体的句柄，crKey为颜色值，bAlpha是透明度，
'取值范围是[0,255]，dwFlags是透明方式，可以取两个值：当取值为LWA_ALPHA时，
'crKey参数无效，bAlpha参数有效；当取值为LWA_COLORKEY时，bAlpha参数有效而
'窗体中的所有颜色为crKey的地方将变为透明－－这个功能很有用：我们不必再为建立
'不规则形状的窗体而调用一大堆区域分析、创建、合并函数了，只需指定透明处的颜色'
'值即可，哈哈哈哈！请看具体代码。
Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE = (-20)
Private Const LWA_ALPHA = &H2
Private Const LWA_COLORKEY = &H1
'代码一: 一个半透明窗体
Private Sub Form_Load()
    Dim rtn As Long
    rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
    rtn = rtn Or WS_EX_LAYERED
    SetWindowLong hwnd, GWL_EXSTYLE, rtn
    SetLayeredWindowAttributes hwnd, 0, 200, LWA_ALPHA
End Sub
'代码二: 形状不规则的窗体
'Private Sub Form_Load()
'    Dim rtn As Long
'    BorderStyler = 0
'    rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
'    rtn = rtn Or WS_EX_LAYERED
'    SetWindowLong hwnd, GWL_EXSTYLE, rtn
'    SetLayeredWindowAttributes hwnd, &H80C0FF, 0, LWA_COLORKEY    '将扣去窗口中的蓝色
'End Sub
'




_____________________________________________________________________

回复人：coldljy(凤舞N天)>>日期：2001-9-3 18:22:19

Copy 来的一段例子:
' API 函数声明
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 CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreateEllipticRgn 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 Boolean) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'常数声明
Private Const RGN_DIFF = 4
' 目标区域被设置为两个区域不相交的部分
'模块级变量声明
Private OutRgn As Long
' 外边的圆角矩形区域
Private InRgn As Long
' 里边的椭圆区域
Private MyRgn As Long
' 圆角区域剪切掉椭圆区域后的区域，也是窗体最终的形状
Private Sub Form_Click()
If OutRgn <> 0 And InRgn <> 0 And MyRgn <> 0 Then Exit Sub
Dim w As Long, h As Long
w = ScaleX(Form1.Width, vbTwips, vbPixels)
h = ScaleY(Form1.Height, vbTwips, vbPixels)
MyRgn = CreateRectRgn(0, 0, 0, 0)
OutRgn = CreateRoundRectRgn(30, 30, w - 30, h - 30, 100, 100)
InRgn = CreateEllipticRgn(100, 100, w - 100, h - 100)
Call CombineRgn(MyRgn, OutRgn, InRgn, RGN_DIFF)
Call SetWindowRgn(Form1.hWnd, MyRgn, True)
Form1.BackColor = QBColor(4)
End Sub
Private Sub Form_DblClick()
Unload Form1
End Sub
Private Sub Form_Load()
OutRgn = 0
InRgn = 0
MyRgn = 0
Form1.Width = 7800
Form1.Height = 6000
End Sub
Private Sub Form_Unload(Cancel As Integer)
If MyRgn <> 0 Then DeleteObject MyRgn
If OutRgn <> 0 Then DeleteObject OutRgn
If InRgn <> 0 Then DeleteObject InRgn
End Sub

_____________________________________________________________________

回复人：lianghong(寂寞水手)>>日期：2001-9-4 0:19:39

以一张图片去掉底色（透明色）后形成的任意形状的图体。
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(Optional TransColor As Long = vbNull)
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
'注释:  获取窗体的边框大小s
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
Debug.Print bm.bmWidth & " " & bm.bmHeight
'PicShape.Width = bm.bmWidth
'PicShape.Height = bm.bmHeight
Select Case bm.bmBitsPixel
Case 8
    colourDepth = 1
    ReDim bytes(0 To bm.bmWidth, 0 To bm.bmHeight)
    GetBitmapBits PicShape.Image, bm.bmHeight * bm.bmWidth, bytes(0, 0)
    If TransColor = vbNull Then TransColor = bytes(0, 0)
        For R = 0 To bm.bmHeight - 2
            C = 0
            Do
                C = C + 1
                While (bytes(C, R) = TransColor) And (C < bm.bmWidth)
                    C = C + 1
                Wend
                start_c = C
                While (bytes(C, R) <> TransColor) And (C < bm.bmWidth)
                    C = C + 1
                Wend
                stop_c = C
                If start_c < stop_c Then
                    new_rgn = CreateRectRgn(x0 + start_c, R + y0, x0 + stop_c + 1, y0 + R + 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 While C < bm.bmWidth
        Next R
Case 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)
    '注释:  建立表单区域
    If TransColor = vbNull Then TransColor = 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) <> TransColor Then Exit Do
                C = C + 1
            Loop
                start_c = C
            Do While C < bm.bmWidth
                If ints(C, R) = TransColor 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)
    If TransColor = vbNull Then TransColor = ints(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) <> TransColor Or _
                bytes(offset + 1, R) <> TransColor Or _
                bytes(offset + 2, R) <> TransColor Then Exit Do
                    C = C + 1
                offset = offset + colourDepth
            Loop
            start_c = C
            Do While C < bm.bmWidth
                If bytes(offset, R) = TransColor And _
                bytes(offset + 1, R) = TransColor And _
                bytes(offset + 2, R) = TransColor _
                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)
    If TransColor = vbNull Then TransColor = 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 longs(C, R) <> TransColor Then Exit Do
                C = C + 1
            Loop
            start_c = C
            Do While C < bm.bmWidth
                If longs(C, R) = TransColor 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
    Debug.Print bm.bmBitsPixel
    MsgBox "对不起，程序必须在8位， 16位, 24-位 或 32-位 颜色下。", _
    vbExclamation + vbOKOnly
    Exit Sub
End Select
Debug.Print bm.bmBitsPixel
'注释:  设置表单外观为建立区域
SetWindowRgn hWnd, combined_rgn, True
    DeleteObject combined_rgn
End Sub
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Form_Load()
    'Me.BackColor = RGB(255, 127, 0)
    Dim x As Picture
    Set x = LoadPicture(App.Path & "\081.jpg")
    Set PicShape.Picture = x
   
    Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2
   
    Command1.Caption = "&U关闭我"
    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


_____________________________________________________________________

回复人：woowindice(黑山老妖)>>日期：2001-9-4 0:31:15

程序员大本营2000里有列子！！！！！！！！！！！！！！！！！！

=======================end=============================

zcllom

第一种方法

创建不规则窗口
　　Win32 API 有很多让你意想不到的功能。要创建特殊的不规则窗口看上去似乎很难。但我们如果我们说我们用几行代码就可以实现，这似乎不可思议。但事实就是如此！　　
　　请试试：
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 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 Sub Form_Load()

Show 'The form!

SetWindowRgn hWnd, CreateEllipticRgn(0, 0, 300, 200), True

End Sub

zcllom

第二种方法：
任意多边形的窗口

声明：

Private Type POINTAPI

X As Long

Y As Long

End Type

Dim XY() As POINTAPI

Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long

Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

该例子把窗口变成了一个 T 型：

Private Sub Form_Load()

Me.ScaleMode = vbPixels

End Sub

Private Sub Command1_Click()

Dim hRgn As Long

Dim lRes As Long

ReDim XY(7) As POINTAPI 'T 形需要 8 个点

With Me

XY(0).X = 0

XY(0).Y = 0

XY(1).X = .ScaleWidth

XY(1).Y = 0

XY(2).X = .ScaleWidth

XY(2).Y = .ScaleHeight / 2

XY(3).X = .ScaleWidth - (.ScaleWidth / 3)

XY(3).Y = .ScaleHeight / 2

XY(4).X = .ScaleWidth - (.ScaleWidth / 3)

XY(4).Y = .ScaleHeight

XY(5).X = .ScaleWidth / 3

XY(5).Y = .ScaleHeight

XY(6).X = .ScaleWidth / 3

XY(6).Y = .ScaleHeight / 2

XY(7).X = 0

XY(7).Y = .ScaleHeight / 2

End With

hRgn = CreatePolygonRgn(XY(0), 8, 2)

lRes = SetWindowRgn(Me.hWnd, hRgn, True)

End Sub

zcllom

第三种方法：

建立不规则的窗口
点击此处下载 ourdev_424711.zip(文件大小:2K) (原文件名:建立不规则的窗口.zip)

zcllom

似乎我上面的回复理解有误，楼主要的是 异型 带 背景图 的窗口，那实际上的做法是：你最好准备一幅png格式的图片，运行的时候，把主窗口隐藏，但控件还是保留显示，再载入贴图。在VB编程资源大全里有，你去下载来看下就行了。

hisun

楼上的好象符合我的想法，我就是想实现一个带有空洞的图片显示而又不能挡住桌面上的内容，我水平有限楼上的讲解我还不清楚，可否讲得详细点？在VB里面怎么样实现隐藏主窗体而又可以显示控件中的图？谢谢了！

hisun

(原文件名:未标题-1 拷贝.gif)
我想实现如上图，所调用的窗体中只显示图中红色的字体，而其它地方是能够显示后面的内容/图文而不会被遮盖的。

lkr90

8楼的用窗体透明就可以了。

hyz_avr

设置窗体透明色。那种颜色就是透明的。。C++BUILDER 是这样。。VB就不知道了

zcllom

透明的Form上显示背景透通图，这是一个很奇特的功能，首先要让Form变透明，接着，放一张背景透明的.gif图进来，如此，这变成一个透明的form，上面有许多Button，且图不会是一个方形，而会让图的背景透通。
    但有一点要注意，这种透明的Form不可以移动，否则一移就会发现它似乎不是透明的，这个很不好解释，建议您一开始设定Form的BorderStyle = 2 大小可变可移动，而去移动与更动小大，便可以知道。因此，在设计阶段时，一定要设BorderStyle = 0 没有框线，这样子您的Form才不会有问题。首先我使用以下的程式码令Form变透明
    注:有适当的软体(如 MS PhotEditor)可以将图变成背景透通(引用 老怪之言)

Me.AutoRedraw = True
hBitmap = CreateCompatibleBitmap(Me.hdc, 0, 0)
SelectObject Me.hdc, hBitmap
Me.Refresh

而透明的图形呢，那需要那一种背景透通性的.GIF档，在Form上放一个Image Control，将图放到Image Control，那就OK了注释：需一个Image Control , 一个Command1

Option Explicit
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private hBitmap As Long
Private Sub Command1_Click()
Unload Me
End Sub

Private Sub Form_Load()
注释：事先请设form的BorderStyle = 0 没有框线
Me.AutoRedraw = True
Set Image1.Picture = LoadPicture("e:\bubbles.gif") 注释：请自行找一个背景透明的图
hBitmap = CreateCompatibleBitmap(Me.hdc, 0, 0)
SelectObject Me.hdc, hBitmap
Me.Refresh
End Sub

Private Sub Form_Unload(Cancel As Integer)
DeleteObject hBitmap
End Sub

=======================================
以上系转载。

hisun

非常感谢楼上大侠，实验确实很好。
    不过我又有个疑问想请教，若我先加载了窗体1，然后再想启动楼上说说的方法显示个异型窗体图的时候这个窗体透明的地方将会显示出窗体1的界面，如果我不想让它讲窗体1的内容也显示出来，除了用Form1.Hide外还可以用什么方法可以不卸载窗体1而又不会显示出窗体1呢？
    哎呀，这几句说得很绕口，不好意思了。