觉得Excel提供的窗体太单一？让你能制作任何样式的用户窗体！

hd37

在VB6中的窗体都可以有很多种样式可以选择，比如无边框无标题栏的窗体。无奈Excel提供的用户窗体却只有那么一种样式。还好可以利用API来获得任何自己想要的窗体样式，甚至是不规则的窗体。我将代码封装在一个函数中，可以很方便的调用。完整的示例可以下载附件，其中也演示了如何用一种简单的办法创建一个不规则的窗体。好了，上代码吧 ^_^
调用的方法也很简单，首先用myHwnd=SysGetWindowsHwnd(Me.Caption) 获得窗体句柄，然后，比如你想得到一个半透明的窗体，就用这样的参数调用就可以了，代码中有很详细的解释：SysSetFormAllStyleEx myHwnd, , , , , , , , , , , 1, 150

－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public 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 Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Public Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetForegroundWindow Lib "user32" () As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Public Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
' ---------------------------
Public Const HTCAPTION = 2
Public Const HWND_NOTOPMOST = -2
Public Const HWND_TOPMOST = -1
Public Const HWND_TOP = 0

Public Const LWA_ALPHA = &H2&
Public Const LWA_COLORKEY = &H1
Public Const ULW_ALPHA = &H2

Public Const GWL_WNDPROC = (-4)
Public Const GWL_EXSTYLE = -20
Public Const GWL_STYLE = (-16)
Public Const GWL_HWNDPARENT = (-8)
Public Const WS_CAPTION = &HC00000
Public Const WS_SYSMENU = &H80000
Public Const WS_MINIMIZEBOX = &H20000
Public Const WS_VISIBLE = &H10000000
Public Const WS_POPUP = &H80000000
Public Const WS_MAXIMIZEBOX = &H10000
Public Const WS_THICKFRAME = &H40000
Public Const WS_EX_DLGMODALFRAME = &H1&
Public Const WS_EX_NOPARENTNOTIFY = &H4&
Public Const WS_EX_LAYERED = &H80000
Public Const WS_EX_TRANSPARENT = &H20&
Public Const WS_EX_WINDOWEDGE = &H1&
Public Const WS_EX_APPWINDOW = &H40000
Public Const WS_EX_TOOLWINDOW = &H80
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const SW_SHOW = 5
Public Const SW_SHOWDEFAULT = 10
Public Const SC_CLOSE = &HF060&

Public Const NIM_ADD = 0
Public Const NIM_DELETE = 2
Public Const NIF_MESSAGE = 1
Public Const NIF_ICON = 2
Public Const NIF_TIP = 4
Public Const ICON_SMALL = 0
Public Const ICON_BIG = 1
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_SETICON = &H80

Public Const AC_SRC_ALPHA As Long = &H1
Public Const AC_SRC_OVER = &H0
Public Const DIB_RGB_COLORS = 0
' ------------------系统常数声明--------------------------------------

Public Function SysSetFormAllStyleEx(ByVal SysHwnd As Long, Optional ByVal winCaption As Boolean = True, Optional ByVal winSysMenu As Boolean = True, Optional ByVal winSizeable As Boolean = False, Optional ByVal winMinBox As Boolean = False, Optional ByVal winMaxBox As Boolean = False, Optional ByVal winCloseBox As Boolean = True, Optional ByVal winBorder As Boolean = True, Optional ByVal winShowInTaskbar As Boolean = False, Optional ByVal winIcon As Boolean = False, Optional ByVal winIconHandle As Long = 0, Optional ByVal winShowLayered As Byte = 0, Optional ByVal winLayeredAlpha As Byte = 255, Optional ByVal winLayeredColorKey As Long = 0, Optional ByVal JustShow As Boolean = True, Optional ByVal winOther As Byte = 0, Optional ByVal setNewOwner As Long = 0, Optional ByVal setNewParent As Long = 0) As Long
'-----------------------------------------------------------------
'   任意设置EXCEL用户窗体样式
'   好了，现在在EXCEL中还有什么窗体不能做出来了呢^_^
'   如果你觉得这个函数还算有用，请保留这段声明
'   也欢迎大家相互交流探讨，我的QQ 511795070
'   2009年3月 by hd37
' -----------------------------------------------------------------
'集中设置窗体的所有样式，得到自己希望的窗体，此函数是上面所有函数集合起来的，如果对窗体样式改变比较多，可以用这个
'winCaption=是否有标题栏
'winSysMenu=是否有系统菜单
'winSizeable=是否可以调节大小
'winMinBox=是否有最小化按钮
'winMaxBox=是否有最大化按钮
'winCloseBox=是否显示关闭按钮
'winBorder=是否显示边框。winCaption=False时有效，因为当窗体有标题栏时，无论怎样设置，都是有边框的
'winShowInTaskbar=是否在任务栏显示图标。（注意，这里是指任务栏中间的区域，不是系统托盘处，要在托盘显示图标，需要另外的设置）
'winIcon=是否显示图标
'winIconHandle=要显示的图标的句柄，仅当winIcon为True时有效。（你可以将图标存储在图片框，调用时直接传入图片框图片的句柄就可以了）
'winShowLayered=是否为窗体添加Layered样式，winShowLayered=0，不添加该样式；winShowLayered=1，添加该样式同时设置窗体透明度；winShowLayered=2，添加该样式同时设置窗体透明颜色；winShowLayered=3，添加该样式并同时设置窗体透明颜色和窗体透明度；winShowLayered=4，仅添加该样式，不设置窗体透明度和透明色
'Layered样式是一种扩展样式，它可以让你的窗体变成半透明效果，或者很容易的做出不规则的窗体来。
'winLayeredAlpha=设置窗体的透明度，0-完全透明，255-完全不透明，125就是半透明窗口了，仅当winShowLayered=1，3时有效
'winLayeredColorKey=设置窗体的透明颜色，可以用函数RGB()将RGB颜色转换为Long值，仅当winShowLayered=2，3时有效
'winLayeredColorKey的作用就是，比如你想做一个圆形的或者任何形状的窗口，你就把窗体圆形或自己想要的形状之外的区域用一种纯色涂满（或者用一张图片），然后将这种纯色设置为窗体的透明色。那么当窗体显示出来时，透明色是不会显示的，就成为一个不规则窗体了。
'winOther=其它操作。winOther=0不做其他操作，winOther=1 重新设置窗体的所有者，winOther=2 重设设置窗体的父窗体，winOther=3 同时重新设置新的所有者和父窗体
'setNewOwner=设置窗体新的所有者句柄，仅当winOther=1，3时有效
'窗体所有者就是说，比如我们在EXCEL中创建的用户窗体，其实全部是ECXEL的子窗体，那么所有者就是EXCEL的主窗体。要是我想让自己的窗体在任务栏显示图标，当然你说可以把winShowInTaskbar设为True，确实这也可以。但是你这么设置后，它仍然是EXCEL的子窗体，当EXCEL最小化以后，所有子窗体也最小化了
'要想自己的窗口不再受所有者窗口的影响，那么你就需要设一个新的所有者，在这里，你可以把setNewOwner设为0，那么它就变成一个独立的窗口，不再是EXCEL子窗口了。
'setNewParent=设置窗体新的父窗口句柄，仅当winOther=2，3时有效
'不要将setNewParent与setNewOwner混淆了，setNewParent与setNewOwner可以相同，也可以不同。父窗口句柄也就是容器的句柄。比如，桌面上所有顶级窗口的父窗口就是桌面（我们的用户窗体默认也是），如果你想让自己的窗体嵌入到另一个窗体中，就得用这个了。子窗体会嵌入到父窗体中，并且移动范围不能超出父窗体。
'比如你可以将自己的窗体嵌入到一个别的应用程序中，成为那个程序的一个工具栏，那么你就可以将setNewParent设置为那个程序主窗口的句柄。你也可以将自己的窗口嵌入到某个游戏窗口的里面（当然如果同时设置setNewOwner效果就更好了）
Dim lOldStyle As Long, hMenu As Long
SysSetFormAllStyleEx = SysHwnd
lOldStyle = GetWindowLong(SysHwnd, GWL_STYLE)    '首先得到以前的基本样式
'然后根据设置选项打开或关闭需要的样式
If winCaption Then lOldStyle = lOldStyle Or WS_CAPTION Else lOldStyle = lOldStyle And (Not WS_CAPTION)
If winSysMenu Then lOldStyle = lOldStyle Or WS_SYSMENU Else lOldStyle = lOldStyle And (Not WS_SYSMENU)
If winSizeable Then lOldStyle = lOldStyle Or WS_THICKFRAME Else lOldStyle = lOldStyle And (Not WS_THICKFRAME)
If winMinBox Then lOldStyle = lOldStyle Or WS_MINIMIZEBOX Else lOldStyle = lOldStyle And (Not WS_MINIMIZEBOX)
If winMaxBox Then lOldStyle = lOldStyle Or WS_MAXIMIZEBOX Else lOldStyle = lOldStyle And (Not WS_MAXIMIZEBOX)
If winShowInTaskbar Then lOldStyle = lOldStyle And (Not WS_VISIBLE) And (Not WS_POPUP) Else lOldStyle = lOldStyle Or WS_VISIBLE Or WS_POPUP
'--------------以上就是基本样式的设置阵列----------
SetWindowLong SysHwnd, GWL_STYLE, lOldStyle   '将设置好的数据写入窗体
' -------------------------
lOldStyle = GetWindowLong(SysHwnd, GWL_EXSTYLE)  '然后得到以前的扩展样式（Windows窗体的样式分为基本样式和扩展样式，都会对窗体的外观产生影响）
'以下根据需要设置窗体的扩展样式
If Not winIcon Then lOldStyle = lOldStyle Or WS_EX_DLGMODALFRAME Else lOldStyle = lOldStyle And (Not WS_EX_DLGMODALFRAME)
If winShowInTaskbar Then lOldStyle = lOldStyle Or WS_EX_APPWINDOW Else lOldStyle = lOldStyle And (Not WS_EX_APPWINDOW)
If winSmallCaption Then lOldStyle = lOldStyle Or WS_EX_TOOLWINDOW Else lOldStyle = lOldStyle And (Not WS_EX_TOOLWINDOW)
If winBorder Then lOldStyle = lOldStyle Or WS_EX_WINDOWEDGE Else lOldStyle = lOldStyle And (Not WS_EX_WINDOWEDGE)
If winShowLayered > 0 Then lOldStyle = lOldStyle Or WS_EX_LAYERED Else lOldStyle = lOldStyle And (Not WS_EX_LAYERED)
'--------以上就是扩展样式的设置阵列--------------
SetWindowLong SysHwnd, GWL_EXSTYLE, lOldStyle  '将设置好的数据写入窗体
If winCloseBox Then
'如果要删除关闭按钮的话，需要处理系统菜单
'所谓系统菜单，就是关闭按钮，最大化最小化按钮和你右键单击标题栏出现的那个菜单
    hMenu = GetSystemMenu(SysHwnd, True)  '第2个参数为True则恢复原始的系统菜单
Else
    hMenu = GetSystemMenu(SysHwnd, 0)
    DeleteMenu hMenu, SC_CLOSE, 0&     '删除关闭按钮
End If
If winShowLayered = 1 Then SetLayeredWindowAttributes SysHwnd, 0, winLayeredAlpha, LWA_ALPHA
If winShowLayered = 2 Then SetLayeredWindowAttributes SysHwnd, winLayeredColorKey, 255, LWA_COLORKEY
If winShowLayered = 3 Then SetLayeredWindowAttributes SysHwnd, winLayeredColorKey, winLayeredAlpha, LWA_COLORKEY Or LWA_ALPHA
If winIcon Then SysAddIcoToWin SysHwnd, winIconHandle   '显示图标
If winOther = 1 Or winOther = 3 Then SetWindowLong SysHwnd, GWL_HWNDPARENT, setNewOwner   '设置所有者
If winOther = 2 Or winOther = 3 Then SetParent SysHwnd, setNewParent    '设置父窗口
' -----------
If JustShow Then ShowWindow SysHwnd, SW_SHOW   '要不要立即显示窗口，对于某些样式，最好用ShowWindow来显示，而不用Me.Show，否则可能不正常
DrawMenuBar SysHwnd   '改变窗口的样式后，需要用此函数重画窗口，不然看起来会很乱
End Function

Public Sub SysAddIcoToWin(ByVal SysHwnd As Long, ByVal myIcon As Long)
'设置窗口的图标。myIcon是图标的句柄
SendMessage SysHwnd, WM_SETICON, ICON_SMALL, ByVal myIcon   '先设置小图标
SendMessage SysHwnd, WM_SETICON, ICON_BIG, ByVal myIcon   '再设置大图标
DrawMenuBar SysHwnd
End Sub

Public Function SysGetWindowsHwnd(ByVal WinText As String) As Long
' 取得窗口句柄
Dim myHwnd As Long
If Val(Application.Version) < 9 Then
    myHwnd = FindWindow("ThunderXFrame", WinText)  'Excel97版本
Else
    myHwnd = FindWindow("ThunderDFrame", WinText)  'Excel2000以上版本
End If
If myHwnd = 0 Then myHwnd = FindWindow(vbNullString, WinText)
SysGetWindowsHwnd = myHwnd
End Function

jilijun

感谢分享！！试试看！

碧海晴天

很多很全，拿走了。谢谢分享！

小村夫

谢谢分享了。

wsri

很不错！API真的很神奇，我也研究过一段时间，也是没登堂入室！遗憾啊！！！

sanmao007

先支持一个。。。

ExceLove

谢谢楼主分享！

刘志文

感谢分享！！

hanter007

感谢分享..谢谢楼主..

tfosorcim

实在是精彩啊！   谢谢！