先用CreateEllipticRgn创建圆形区域
再用SetWindowRgn设置窗口的显示区域CreateEllipticRgn VB声明
Declare Function CreateEllipticRgn Lib "gdi32" Alias "CreateEllipticRgn" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
说明
创建一个椭圆,该椭圆与X1,Y1和X2,Y2坐标点确定的矩形内切
返回值
Long,执行成功则为区域句柄,失败则为零
参数表
参数 类型及说明
X1,Y1 Long,矩形左上角X,Y坐标
X2,Y2 Long,矩形右下角X,Y坐标
注解
不用时一定要用DeleteObject函数删除区域。用Ellipse API函数绘出的椭圆与该椭圆区域不完全相同,因为本函数的绘图计算不包括矩形的下边和右边
SetWindowRgn VB声明
Declare Function SetWindowRgn Lib "user32" Alias "SetWindowRgn" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
说明
这是那些很难有人注意到的对编程者来说是个巨大的宝藏的隐含的API函数中的一个。本函数允许您改变窗口的区域。
通常所有窗口都是矩形的——窗口一旦存在就含有一个矩形区域。本函数允许您放弃该区域。这意味着您可以创建圆的、星形的窗口,也可以将它分为两个或许多部分——实际上可以是任何形状
返回值
Long,执行成功为非零值,失败为0
参数表
参数 类型及说明
hWnd Long,将设置其区域的窗口
hRgn Long,将设置的区域的句柄,一旦设置了该区域,就不能使用或修改该区域句柄,也不要删除它
bRedraw Boolean,若为TRUE,则立即重画窗口
注解
为区域指定的所有坐标都以窗口坐标(不是客户坐标)表示,它们以整个窗口(包括标题栏和边框)的左上角为起点
再用SetWindowRgn设置窗口的显示区域CreateEllipticRgn VB声明
Declare Function CreateEllipticRgn Lib "gdi32" Alias "CreateEllipticRgn" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
说明
创建一个椭圆,该椭圆与X1,Y1和X2,Y2坐标点确定的矩形内切
返回值
Long,执行成功则为区域句柄,失败则为零
参数表
参数 类型及说明
X1,Y1 Long,矩形左上角X,Y坐标
X2,Y2 Long,矩形右下角X,Y坐标
注解
不用时一定要用DeleteObject函数删除区域。用Ellipse API函数绘出的椭圆与该椭圆区域不完全相同,因为本函数的绘图计算不包括矩形的下边和右边
SetWindowRgn VB声明
Declare Function SetWindowRgn Lib "user32" Alias "SetWindowRgn" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
说明
这是那些很难有人注意到的对编程者来说是个巨大的宝藏的隐含的API函数中的一个。本函数允许您改变窗口的区域。
通常所有窗口都是矩形的——窗口一旦存在就含有一个矩形区域。本函数允许您放弃该区域。这意味着您可以创建圆的、星形的窗口,也可以将它分为两个或许多部分——实际上可以是任何形状
返回值
Long,执行成功为非零值,失败为0
参数表
参数 类型及说明
hWnd Long,将设置其区域的窗口
hRgn Long,将设置的区域的句柄,一旦设置了该区域,就不能使用或修改该区域句柄,也不要删除它
bRedraw Boolean,若为TRUE,则立即重画窗口
注解
为区域指定的所有坐标都以窗口坐标(不是客户坐标)表示,它们以整个窗口(包括标题栏和边框)的左上角为起点
然后调用此过程,调用方式 SetAutoRgn Form1,Form1.Picture.Handle
'mdlMakeRange.bas
Option ExplicitPublic Declare Function GetObject 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 Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Public Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, ByVal nCount As Long, ByVal nPolyFillMode As Long) As LongPublic Const RGN_OR = 2
Public Const ALTERNATE = 1 ' ALTERNATE and WINDING arePublic Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End TypePublic Type POINTAPI
X As Long
Y As Long
End Type''调用此过程生成不规则窗体
Public Sub SetAutoRgn(hForm As Form, hbm As Long, 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, SPos1 As Long, Epos1 As Long
Dim bm As BITMAP
'Dim hbm As Long
Dim Wid As Long, hGt As Long
Dim Bind As Boolean
Dim bmByte() As Byte
Dim Pt(0 To 3) As POINTAPI
Bind = False
' 获取窗体背景图片大小
'hbm = hForm.Pic
If hbm = 0 Then Exit Sub
GetObject hbm, Len(bm), bm
Wid = bm.bmWidth
hGt = bm.bmHeight
'改变窗体大小以符全图片
hForm.Height = hGt * Screen.TwipsPerPixelY
hForm.Width = Wid * Screen.TwipsPerPixelX
' Rgn1 = CreateRectRgn(0, 0, hGt, Wid)
' SetWindowRgn hForm.hWnd, Rgn1, True
ReDim bmByte(1 To bm.bmWidthBytes, 1 To hGt)
SetWindowRgn hForm.hWnd, Rgn1, True
GetBitmapBits hbm, bm.bmWidthBytes * 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) '((bmByte(X, Y) >= transColor - 2) And (bmByte(X, Y) <= transColor + 2)) And (X < Wid)
X = X + 1 '跳过透明的点
Wend
If X < Wid Then
SPos = X
While (bmByte(X, Y) <> transColor) And (X < Wid) '((bmByte(X, Y) <= transColor - 2) Or (bmByte(X, Y) >= transColor + 2)) And (X < Wid)
X = X + 1 '跳过不透明的点
Wend
Epos = X - 1
'全并一段区域
Rgn2 = CreateRectRgn(SPos, Y, Epos, Y + 1)
CombineRgn Rgn1, Rgn1, Rgn2, RGN_OR
DeleteObject Rgn2
End If
Loop Until X >= Wid
Next Y
Erase bmByte
'设定窗口形状区域
SetWindowRgn hForm.hWnd, Rgn1, True
DeleteObject Rgn1
End Sub
....
...
..
.
给你个简单点的例子,
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) 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 priEillWnd As Long
Private Sub Command1_Click() priEillWnd = CreateEllipticRgn(1, 1, 74, 21)
Dim ss As Long
ss = SetWindowRgn(Text1.hWnd, priEillWnd, True)
End Sub
可以把Text1改成Me,呵呵,~~~~