分享

移除Excel工作簿或工作表窗口中左上角的图标以及右上角的最大化、最小化、关闭按钮

 群先 2021-11-11
将移除Excel工作簿或工作表窗口中左上角的图标以及右上角的最大化、最小化、关闭按钮,下载本示例中的附件后,当您点击工作簿中的“移除”按钮时,工作簿和工作表上的图标及最大化、最小化、关闭按钮全部移除,点击“恢复”按钮后,将恢复上述图标和按钮。
在程序中语句HasSystemMenu False 的作用是移除工作簿左上角图标和右上角最小化/最大化/关闭按钮,将参数False改为True或省略该语句将不移除;语句RemoveWindowX 的作用是移除工作表左上角图标和右上角最小化/最大化/关闭按钮,若省略该语句,将不移除; 语句HasSystemMenu True的作用是恢复工作簿左上角图标和右上角最小化/最大化/关闭按钮;语句RestoreWindowX的作用是恢复工作表左上角图标和右上角最小化/最大化/关闭按钮。可以根据上述语句的作用,将程序适当调整,只移除其中某项图标和按钮。
程序代码如下:

'******声明部分******
Private Declare Function SetWindowLong Lib 'user32.dll' _
  Alias 'SetWindowLongA' ( _
  ByVal hwnd As Long, _
  ByVal nIndex As Long, _
  ByVal dwNewLong As Long) _
  As Long
   
Private Declare Function GetWindowLong Lib 'user32.dll' _
  Alias 'GetWindowLongA' ( _
  ByVal hwnd As Long, _
  ByVal nIndex As Long) _
  As Long

Private Declare Function SetWindowPos Lib 'user32.dll' ( _
  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

Private Declare Function FindWindowEx Lib 'user32.dll' _
  Alias 'FindWindowExA' ( _
  ByVal hWnd1 As Long, _
  ByVal hWnd2 As Long, _
  ByVal lpsz1 As String, _
  ByVal lpsz2 As String) _
  As Long

Private Declare Function GetWindowThreadProcessId Lib 'user32.dll' ( _
  ByVal hwnd As Long, _
  ByRef lpdwProcessId As Long) _
  As Long

Private Declare Function SendMessage Lib 'user32.dll' _
  Alias 'SendMessageA' ( _
  ByVal hwnd As Long, _
  ByVal wMsg As Long, _
  ByVal wParam As Long, _
  ByVal lParam As Long) _
  As Long

Private Declare Function ExtractIcon Lib 'shell32.dll' _
  Alias 'ExtractIconA' ( _
  ByVal hInst As Long, _
  ByVal lpszExeFileName As String, _
  ByVal nIconIndex As Long) _
  As Long
     
Private Declare Function GetCurrentProcessId Lib 'kernel32.dll' () _
  As Long
  
Private Declare Function GetDesktopWindow Lib 'user32.dll' () _
  As Long

Private Const GWL_STYLE   As Long = (-16)

Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_SYSMENU  As Long = &H80000

Private Const HWND_TOP    As Long = 0
Private Const SWP_NOMOVE  As Long = &H2
Private Const SWP_NOSIZE  As Long = &H1
Private Const SWP_FRAMECHANGED  As Long = &H20
Private Const SWP_DRAWFRAME  As Long = &H20
Private Const WM_SETICON  As Long = &H80
'*****************************
Private Function FindOurWindow(Optional ByVal sClass As String = vbNullString, _
          Optional ByVal sCaption As String = vbNullString)
  Dim hWndDesktop As Long
  Dim hwnd As Long
  Dim hProcThis As Long
  Dim hProcWindow As Long
  hWndDesktop = GetDesktopWindow
  hProcThis = GetCurrentProcessId
  Do
hwnd = FindWindowEx(hWndDesktop, hwnd, sClass, sCaption)
GetWindowThreadProcessId hwnd, hProcWindow
  Loop Until hProcWindow = hProcThis Or hwnd = 0
  FindOurWindow = hwnd
End Function
'*****************************
Private Function ApphWnd() As Long
  If Val(Application.Version) >= 10 Then
ApphWnd = Application.hwnd
  Else
ApphWnd = FindOurWindow('XLMAIN', Application.Caption)
  End If
End Function
'*****************************
Private Sub HasSystemMenu(ByVal Allow As Boolean)
  Dim lStyle As Long: lStyle = GetWindowLong(ApphWnd, GWL_STYLE)
  If Allow Then
lStyle = lStyle Or WS_SYSMENU
  Else
lStyle = lStyle And Not WS_SYSMENU
  End If
  Call SetWindowLong(ApphWnd, GWL_STYLE, lStyle)
  Call SetWindowPos(ApphWnd, HWND_TOP, 0, 0, 0, 0, _
     SWP_NOMOVE Or SWP_NOSIZE Or SWP_DRAWFRAME)
End Sub
'*****************************
Public Sub RemoveX()
  HasSystemMenu False '移除工作簿左上角图标和右上角最小化/最大化/关闭按钮
  RemoveWindowX '移除工作表左上角图标和右上角最小化/最大化/关闭按钮
End Sub
'*****************************
Public Sub RestoreX()
  HasSystemMenu True '恢复工作簿左上角图标和右上角最小化/最大化/关闭按钮
  RestoreWindowX '恢复工作表左上角图标和右上角最小化/最大化/关闭按钮
End Sub
'*****************************
Public Sub RemoveWindowX()
ActiveWorkbook.Protect , , True
End Sub
'*****************************
Public Sub RestoreWindowX()
ActiveWorkbook.Protect , , False
End Sub

    本站是提供个人知识管理的网络存储空间,所有内容均由用户发布,不代表本站观点。请注意甄别内容中的联系方式、诱导购买等信息,谨防诈骗。如发现有害或侵权内容,请点击一键举报。
    转藏 分享 献花(0

    0条评论

    发表

    请遵守用户 评论公约

    类似文章 更多