***********如何做属于自己的/任意形状的窗体?***********急!急!急!急!急!急!*******同志们!上啊!.........

[questions21cn]

小弟初学VB,想知道如何才能作出自己想要的窗体,想国外一些媒体播放机似的,奇形怪状的! 小弟会一点3DS MAX!所以很想用所学做出一些有新意的东西来!
如果能在大家的帮助下得以梦想成真!小弟定将作品公布于天下--FREE DOWNLOAD!
小弟先谢了!

[xxlroad]

原有信息：
　　序　号　：891741
　　标　题　：根据图像创建不规则形状控件/窗体的新方法(1291字)
　　作　者　：SuperAPI
　　时　间　： 2000.12.03 18:21
　　访问量　：1
　　详细信息：

‘请把这一段代码复制到General部分，调用CreateRegion根据图像产生
‘不规则区域。需要先在DestPictureBox中加载图像，黑色为透明区域。
‘如果需要以其他颜色产生透明区域，请修改If tColour = 0 Then一句；
‘比如要以红色产生透明区域，修改为If tColour = RGB(255, 0, 0) Then
‘要创建不规则形状窗体，把所有的“PictureBox”替换为“Form”即可。
‘对于无法加载图像而有hWnd属性的控件(如TextBox)，可以“借花献佛”，
‘使用SetWindowRgn把由PictureBox创建的区域设置给控件，就可以创造出
‘飞机形的文本框，炸弹形的列表框，随你发挥想象啦……
‘----------------------------------------------------------------
‘入口：DestPictureBox -- 要设置为不规则形状的图片框
‘----------------------------------------------------------------
‘这里使用GetPixel代替Point方法，直接调用API函数以加快速度。
‘本过程在VB5 + Win98下运行通过。
Private Const RGN_XOR = 3
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 GetWindowRect Lib "user32" (ByVal hwnd As
Long, lpRect As RECT) 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 GetPixel Lib "gdi32" (ByVal hdc As Long,
ByVal x As Long, ByVal y As Long) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Sub CreateRegion(DestPictureBox As PictureBox)
Dim hRgn As Long, hRect As RECT, hTempRgn As Long, tColour As Long,
OldScaleMode As Integer
OldScaleMode = DestPictureBox.ScaleMode
DestPictureBox.AutoRedraw = True
DestPictureBox.ScaleMode = 3
a = GetWindowRect(DestPictureBox.hwnd, hRect)
hRgn = CreateRectRgn(0, 0, hRect.Right, hRect.Bottom)
For AbsoluteX = 0 To DestPictureBox.ScaleWidth
For AbsoluteY = 0 To DestPictureBox.ScaleHeight
tColour = GetPixel(DestPictureBox.hdc, AbsoluteX, AbsoluteY)
If tColour = 0 Then
hTempRgn = CreateRectRgn(AbsoluteX, AbsoluteY, AbsoluteX
+ 1, AbsoluteY + 1)
a = CombineRgn(hRgn, hRgn, hTempRgn, RGN_XOR)
a = DeleteObject(hTempRgn)
End If
Next AbsoluteY
Next AbsoluteX
a = SetWindowRgn(DestPictureBox.hwnd, hRgn, True)
DeleteObject hRgn
DestPictureBox.ScaleMode = OldScaleMode
End Sub


根据图像创建不规则形状控件/窗体的新方法(1291字) (SuperAPI 今天 18:21 阅读 0)

[questions21cn]

哇!哇!哇!哇!哇!哇!哇! 深了....
小弟得先回家"烟酒,烟酒", 分先给两位大哥加上了, 我只剩这几十分了!
请两位大侠留下伊妹儿,小弟下次再来可能得换个名字了!还得多请教二位呢!!!!!

[questions21cn]

有这方面的控件吗?

[xxlroad]

CSDN讨论组：wxj_lake(蔚蓝的风)　(2000-12-23 21:50:00) 得50分
这是我前段时间一篇稿子的片断

　　关于用VB制作不规则窗口的文章，在各种杂志、报纸、网站上面也不知提过几回了，我都有点不好意思再谈了。但是我们编程序不仅仅要实现功能，更要寻求最佳的实现方案，本着这样的原则，让我们再来回顾一下这个老命题，也向大家介绍一下我的心得。
　　Windows提供了一个API函数SetWindowRgn，凭着这个函数，我们可以把窗口设置为任意形状。问题在于，我们如何来获取所需的区域形状。一般情况下，我们可以使用CreateEllipticRgn创建椭圆区域，CreateRectRgn创建矩形区域，CreateRoundRectRgn创建圆角矩形区域。（口干，喝一口水，继续……）如果我们需要不规则的形状呢？那就可以使用CreatePolygonRgn。可是这个函数需要的参数之一是包含整个不规则区域轮廓坐标点的数组，对于一个稍微复杂一点的形状就可能需要几百个坐标点，要获取和改动这些坐标点都是相当麻烦的。
有没有更为方便的方法呢？答案是肯定的。（不然我在这儿瞎搞什么？）
　　原理是用一张图片作为窗体的背景，图片中有一种颜色是我们不需要的，称为透明色。然后编程一行行地扫描图片，将透明色的点删去，而把有用的像素点合并成一块区域，如此便得到所需的形状了。
　　但是行扫描的速度奇慢，我最初实现的程序起码用了5分钟才显示出窗体。咎其原因是我们选错了兵刃。一开始我使用GetPixel来获取每一点的颜色，这样每取一个点都需要通过设备上下文hdc从图片中读取信息，这就是造成龟速的罪魁祸首了。
　　正确的方法是使用GetBitmapBits函数。它可以将位图中每一点颜色信息一下子读到一个数组中，以后只要扫描这个数组就行了，这将极大的提高运行速度。

Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) 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 Const RGN_OR = 2
Public Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
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
Dim bmByte() As Byte

Public Sub SetAutoRgn(hForm As Form, Optional transColor As Byte = vbNull)
Dim X As Long, Y As Long
Dim Rgn1 As Long, Rgn2 As Long
Dim SPos As Long, EPos As Long
Dim bm As BITMAP
Dim hbm As Long
Dim Wid As Long, Hgt As Long

'获取窗体背景图片尺寸
hbm = hForm.Picture
GetObjectAPI hbm, Len(bm), bm
Wid = bm.bmWidth
Hgt = bm.bmHeight

'改变窗体尺寸以符合背景图片大小
hForm.Height = Hgt * Screen.TwipsPerPixelY
hForm.Width = Wid * Screen.TwipsPerPixelX

ReDim bmByte(1 To Wid, 1 To Hgt)
GetBitmapBits hbm, Wid * Hgt, bmByte(1, 1) '获取图像数组

'如果没有传入transColor参数，则用第一个像素作为透明色
If transColor = vbNull Then transColor = bmByte(1, 1)

Rgn1 = CreateRectRgn(0, 0, 0, 0)
For Y = 1 To Hgt '逐行扫描
X = 0
Do
X = X + 1

While (bmByte(X, Y) = transColor) And (X < Wid)
X = X + 1 '跳过是透明色的点
Wend
SPos = X

While (bmByte(X, Y) <> transColor) And (X < Wid)
X = X + 1 '跳过不是透明色的点
Wend
EPos = X - 1

'这一段是合并区域
If SPos <= EPos Then
Rgn2 = CreateRectRgn(SPos - 1, Y - 1, EPos, Y)
CombineRgn Rgn1, Rgn1, Rgn2, RGN_OR
DeleteObject Rgn2
End If
Loop Until X >= Wid
Next Y

SetWindowRgn hForm.hwnd, Rgn1, True '设定窗体形状区域
DeleteObject Rgn1
End Sub

　　以上这一大段程序列出了所有必需的API函数申明。自定义过程SetAutoRgn有两个参数，hForm是将要设置形状的窗体名称，transColor是透明颜色值。关于获取窗体背景图片尺寸的代码，相信各位一看就明白，我不再罗嗦。
　　我想需要解释的是像素格式的概念。大家可能已经注意到程序中二维数组bmByte()的类型是Byte，而在后面的循环体中，我每次取数组的一项就代表一个像素点，这意味着窗体的背景图片只能是8位色深256色的图片（比如GIF格式）。如果是16位色深的图片（JPG格式），那么数组的行宽得翻一倍，并且两个数组项才代表一个像素，要不你就把bmByte()的类型改为Integer。同理，24位色深的像素点要用3个Byte表示，32位的要用4个Byte或者一个Long。transColor的值在不同的像素格式下的值也是不同的。比如在8位情况下，它的取值范围为0-255，代表颜色在图片调色板中的位置。好在程序默认以图片左上角第一个像素为透明色，这样你也就不必深究transColor的具体表示方法了。更为详细的关于像素格式的资料可以在MSDN的光盘中找到，限于篇幅，这里就不展开了。
　　好，理解了程序，我们可以试着来运行一下了，大家可以先看看程序运行的效果（见图二）。在我的古董MMX200上，把图一这样一张图片变成图二那样的窗体，大约耗时0.4秒左右，这么一点延迟应该是可以忍受的。如果你不放心，可以这样来调用以了解精确的运行时间。

Private Sub Form_Load()
Dim t As Single
t = Timer
If Me.Picture <> 0 Then Call SetAutoRgn(Me)
MsgBox Timer - t
End Sub

[ityaa]

简单的方法是用图片做窗体的背景，然后想办法透明，若做成SKIN的那种随时更改的，很麻烦

[nothingneed]

转载自www.vbgood.com
一个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