在VB中能不能设计不规则窗体（如窗体的四个角为圆形等），请问怎么做？

Question

在VB中能不能设计不规则窗体（如窗体的四个角为圆形等），请问怎么做？

Answer 1

Option Explicit
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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y 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
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const RGN_OR = 2
Private Const WM_MOVE = &HF012
Private Const WM_SYSCOMMAND = &H112'图形窗体函数
'Form1：窗体名称
'picSource：装载图形的PictureBox控件名称
'lngTransColor：要屏蔽掉的颜色，缺省为picSource的（1，1）处的颜色值Public Function RegionFromBitmap(Form1 As Form, picSource As PictureBox, Optional lngTransColor As Long) As Long
  Dim lngRetr As Long, lngHeight As Long, lngWidth As Long
  Dim lngRgnFinal As Long, lngRgnTmp As Long
  Dim lngStart As Long, lngRow As Long
  Dim lngCol As Long
  If lngTransColor& < 1 Then
    lngTransColor& = GetPixel(picSource.hdc, 1, 1)
  End If
  lngHeight& = picSource.Height / Screen.TwipsPerPixelY
  lngWidth& = picSource.Width / Screen.TwipsPerPixelX
  lngRgnFinal& = CreateRectRgn(0, 0, 0, 0)
  For lngRow& = 0 To lngHeight& - 1
    lngCol& = 0
    Do While lngCol& < lngWidth&
      Do While lngCol& < lngWidth& And GetPixel(picSource.hdc, lngCol&, lngRow&) = lngTransColor&
        lngCol& = lngCol& + 1
      Loop
      If lngCol& < lngWidth& Then
        lngStart& = lngCol&
        Do While lngCol& < lngWidth& And GetPixel(picSource.hdc, lngCol&, lngRow&) <> lngTransColor&
          lngCol& = lngCol& + 1
        Loop
        If lngCol& > lngWidth& Then lngCol& = lngWidth&
        lngRgnTmp& = CreateRectRgn(lngStart&, lngRow&, lngCol&, lngRow& + 1)
        lngRetr& = CombineRgn(lngRgnFinal&, lngRgnFinal&, lngRgnTmp&, RGN_OR)
        DeleteObject (lngRgnTmp&)
      End If
    Loop
  Next
  RegionFromBitmap& = SetWindowRgn(Form1.hWnd, lngRgnFinal&, True)
End Function
'移动窗体
Public Function FormMove(FormhWnd As Long)
    Call ReleaseCapture
    Call SendMessage(FormhWnd, WM_SYSCOMMAND, WM_MOVE, 0)
End Function

Answer 2

'Createrectrgn为创建一个由点X1，Y1和X2，Y2描述的矩形区域
'因为窗体是由一个个矩形组成的
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
'Combinergn将两个区域组合为一个新区域
'把一个个矩形合为一个新的区域
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
'做一个古怪的窗口必须要用的也是那个程序中最重要的一个函数就是SetWindowRgn
'它的功能就是对指定的窗口进行重画，把这个窗口你选择的部分留下
'其余的部分抹掉。
'参数：hWnd：你所要重画的窗口的句柄，比如你想重画form1
'则应该让此参数为form1.hWnd
'      hRgn：你要保留的区域的句柄，这个句柄是关键，你需要通过别的渠道来获得
'在这里的区域是由Combinergn合成的新区域
'     bRedram：是否要马上重画，一般设为true
Public Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
'用这个函数删除GDI对象，比如画笔、刷子、字体、位图、区域以及调色板等等。对象使用的所有系统资源都会被释放
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Answer 3

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 Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPrivate Sub Form_Activate()
Dim hndRgn As Long 
hndRgn = CreateEllipticRgn(0, 0, 175, 175)
Call SetWindowRgn(Me.hWnd, hndRgn, True)
Call DeleteObject(hndRgn)
End Sub  这是创建椭圆形窗体， 四角圆形窗体可以类推。

Answer 4

其实楼主并没有要求那么多,大家为何写的那么多阿?Option Explicit
'-----------------------------------------------------
'创建圆角窗体 API 声明
'-----------------------------------------------------
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 SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
'-----------------------------------------------------
'获得用户区大小
'-----------------------------------------------------
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End TypePrivate Sub Command3_Click()
End
End SubPrivate Sub Form_Load()
    Dim udtRect As RECT
    GetClientRect Me.hWnd, udtRect
    
    Dim lngRegion As Long
    Dim lngReturn As Long
    
    lngRegion = CreateRoundRectRgn(udtRect.Left, udtRect.Top, udtRect.Right, udtRect.Bottom, 20, 20)
    lngReturn = SetWindowRgn(Me.hWnd, lngRegion, True)End Sub