禁用EXCEL的Open/Save As功能

 

    发现我大多数时候在CSDN提的技术问题都没有得到解决过,一切还是得靠自己,这个问题由复杂变简单,写下来可以让别人也可以参考一下.

 

    Requirement:User通过Citrix连接到Server,运行Server上的程序会产生一些xls格式的表示,Leader希望禁掉所有xls文件的Open/Save As功能,就是不希望User删除Server上的文件.

 

    我本来以为没有必要做这个事情,因为User本来就没有权限删除Server上的权限的,但是他可以Save As后再删除,但他是删除他自己的文件,原始文件他不能删除也没有关系撒,但严谨一点的话就是不希望User做查看Report以外的操作,要操作自己Copy到自己本地磁盘上去操作,呵呵...

    于是开始找方法啊找方法:

     第一种最简单但不算方法的方法就是改变xls文件的默认打开方式.

     (还有一个问题值得注意的就是禁用了User使用Open/Save As功能但是其他应用程序可以正常Open/Read/write Excel文件.)

     这种方法只能实现用户双击的时候不能正常打开xls,但是人家还是可以选择打开方式为Excel撒,然后就可以Sava As了,想到这个方法也是因为之前有误解以为根本就不让User打开文件,弃之,BS下自己.

     第二种方法就是用Windows API,但是对这个一点都不熟悉,那就学吧,先把思路整理出来.

     就是用VB写一个程序,当EXCEL一启动的时候就触发它,然后这个程序循环扫描桌面所有的Excel文件窗口,然后来禁用Open/Save As功能.实现了一半,发现获得Window句柄时并不能根据Window句柄获得Menu,再经研究发现,MS根本就实现不了,这个好像只能获得本应用程序的Menu,所以弃之,选择另外的方向.

    第三种方法就是现在成功实现的方法,当第二种方法遇到问题的时候开始重点转移到Maro,如果能编辑一个宏实现禁用Open/Sava As 功能,然后这个宏可以应用到所有的xls文件,而且是xls一打开的时候就自动执行这个宏,那就完成了为需求的实现鸟,呵呵,事实证明,这个是最容易最简单的一种方法.

    实现: 1.打开一个新的Workbook,打开vba编辑器(ALT + F11),双击ThisWorkbook,输入下面代码.

               Private Sub Workbook_Open()
                   Application.CommandBars("File").Controls("Save As...").Enabled = False
                   Application.CommandBars("File").Controls("Open...").Enabled = False
               End Sub

             注意:如果你的操作系统是中文的话就应该是:

                   Application.CommandBars("File").Controls("另存为...").Enabled = False
                   Application.CommandBars("File").Controls("打开...").Enabled = False

             跟你EXCEL里面菜单项目的名字一样就可以了.

             2.将Workbook保存名为PERSONAL.XLS,然后放在C:/Program Files/Microsoft Office/OFFICE11/XLSTART目录下,

       这个路径是相对路径,你可以搜索XLSTART目录在你的电脑上,然后将此文件放在这个目录下.

 

这样的话每次你打一个xls文件PERSONAL.XLS文件都会打开而且自动执行宏,所以你的文件的Open/Save As也就变灰了,不能用咯.

 

补充:可以将PERSONAL.XLS文件设置为hide,这样可以防止用户不小心把PERSONAL.XLS文件也改变并且存盘了.

参考资料:       

http://faq.csdn.net/read/213792.html
http://office.microsoft.com/zh-cn/help/HA010346282052.aspx
   

    2010-03-01

     More requirement:

     禁用一个三级菜单项,例:

     Application.CommandBars("Data").Controls("Get External Data").Controls("New Database Query...").Enabled = False    

    还遇到个问题就是把这个文件放进XLSART后,目地是达到了,但是如果删除了这个文件的话,相应的功能并不会消失,菜单项还是会被禁用,所以就只能所所有禁用的功能改为True

    如:Application.CommandBars("Data").Controls("Get External Data").Controls("New Database Query...").Enabled = True

    这样再打开其他Excel文件就没有影响了,而且不用的话最好是把XLSTART下面的文件删掉,免得每次打开一个文件这个文件还是自动为启动,占资源.

    还增了个需求就是在菜单栏加一个自定义菜单,然后实现当User点此菜单就自动将本文件另存到他本地C:/Temp/下.

 

'添加一个菜单项

    'SaveToC' 是宏名,点BEA就自动运行SaveToC

Sub CreateMyMenu()
     Set MyMenu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)
     With MyMenu
          .BeginGroup = True
          .Caption = "BEA"
          .OnAction = "SaveToC"
     End With
End Sub

 

'删除菜单项
Sub DeleleMyMenu()
 On Error Resume Next
    Application.CommandBars("Worksheet Menu Bar").Controls("BEA").Delete
End Sub

 

'打开文件的时候如果此菜单存在就删除,然后调用添加菜单项

Private Sub Workbook_Open()  
  Call DeleleMyMenu
  Call CreateMyMenu 
End Sub

 

'在关闭文件的时候调用删除单菜荐
Private Sub Workbook_BeforeClose(Cancel As Boolean)

   Call DeleleMyMenu 
End Sub

 

'宏 SaveToC

Sub SaveToC()
'
' SaveToC Macro
' Macro recorded 2/26/2010 by Jessie
'
'
    Dim strFileName As String
    Dim strPath As String
    Dim iResponse As Integer
    Dim blnIsExistFolder As Boolean
    Dim blnIsExistFile As Boolean
   
    strPath = "C:/temp/"
       
    If FileFolderExists(strPath) Then
        blnIsExistFolder = True
    Else
       blnIsExistFolder = False
    End If
   
    If blnIsExistFolder = False Then
       MkDir (strPath)
    End If
   
    strFileName = strPath & ThisWorkbook.Name
   
    If FileFolderExists(strFileName) Then
       blnIsExistFile = True
    Else
       blnIsExistFile = False
    End If
   
    If blnIsExistFile = True Then
       iResponse = MsgBox("The file '" & ThisWorkbook.Name & "' already exists. Do you want to replace the existing file?' ", vbYesNoCancel + vbExclamation)
    Else
       Application.ActiveSheet.SaveAs Filename:=strFileName
    End If
    If iResponse = 6 Then
       Application.DisplayAlerts = False
       Application.ActiveSheet.SaveAs Filename:=strFileName
       Application.DisplayAlerts = True
    End If
   
End Sub
Public Function FileFolderExists(strFullPath As String) As Boolean
    On Error GoTo EarlyExit
    If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
   
EarlyExit:
    On Error GoTo 0
End Function