[已解决]求一個重複打開當前工作簿預警代碼

yl.fu

比如，局域網上一個工作簿，已有人打開，我再打開時就只顯示一個對話框提示當前 **（用戶名） 在使用，請稍後！不要顯示EXCEL介面 ，   如沒人打開則正常使用，不知是否可以？

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-5-26 11:29

1. Sub getUser()
   
2.     Dim arr
   
3.     Dim strMsg$
   
4.     arr = ThisWorkbook.UserStatus
   
5.     If Not IsArray(arr) Then Exit Sub
   
6.     strMsg = "用户名" & vbTab & "打开时间" & vbTab & vbCrLf
   
7.    
   
8.     For i = LBound(arr) To UBound(arr)
   
9.         strMsg = strMsg & arr(i, 1) & vbTab & arr(i, 2) & vbTab & Choose(arr(i, 3), "独占", "共享") & vbCrLf
   
10.     Next
    
11.     MsgBox strMsg
    
12.    
    
13. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

Workbook.UserStatus 属性
返回一个基为 1 的二维数组，该数组提供有关每一个以共享列表模式打开工作簿的用户的信息。Variant 类型，只读。
语法

表达式.UserStatus

表达式   一个代表 Workbook 对象的变量。

说明


数组第二维的第一个元素为用户名，第二个元素是用户打开工作簿的日期和时间，第三个元素是一个表示清单类型的数字（1 表示独占，2 表示共享）。

UserStatus 属性不返回有关以只读方式打开指定工作簿的用户的信息。


示例


本示例新建一个工作簿，并将所有以共享清单模式打开活动工作簿的用户的信息插入新工作簿。

Visual Basic for Applications
users = ActiveWorkbook.UserStatus
With Workbooks.Add.Sheets(1)
    For row = 1 To UBound(users, 1)
        .Cells(row, 1) = users(row, 1)
        .Cells(row, 2) = users(row, 2)
        Select Case users(row, 3)
            Case 1
                .Cells(row, 3).Value = "Exclusive"
            Case 2
                .Cells(row, 3).Value = "Shared"
        End Select
    Next
End With

hwc2ycy

Workbook.RemoveUser 方法
断开指定用户与共享工作簿的连接。
语法

表达式.RemoveUser(Index)

表达式   一个代表 Workbook 对象的变量。

参数

名称 必选/可选 数据类型 说明
Index 必选 Long 用户索引。

示例


本示例断开第二个用户与共享工作簿的连接。

Visual Basic for Applications
Workbooks(2).RemoveUser 2

hwc2ycy

有了这个UserStatus
你应该会写剩下的代码了。

hwc2ycy

共享的时候，你的宏能运行？

yl.fu

hwc2ycy 发表于 2013-5-26 11:19
有了这个UserStatus
你应该会写剩下的代码了。

老大您可高看我了啊，我啥都不會啊，我的這個工作簿不能設置共享的，共享了好多命令就不能用了，只是放指定路徑下，防止大家同時更改不能合併保存的問題。

yl.fu

hwc2ycy 发表于 2013-5-26 11:21
共享的时候，你的宏能运行？

厲害，我正寫呢你就預警了

hwc2ycy

1. Sub getUser()
   
2.     Dim arr
   
3.     Dim strMsg$
   
4.     arr = ThisWorkbook.UserStatus
   
5.     If Not IsArray(arr) Then Exit Sub
   
6.     strMsg = "用户名" & vbTab & "打开时间" & vbTab & vbCrLf
   
7.    
   
8.     For i = LBound(arr) To UBound(arr)
   
9.         strMsg = strMsg & arr(i, 1) & vbTab & arr(i, 2) & vbTab & Choose(arr(i, 3), "独占", "共享") & vbCrLf
   
10.     Next
    
11.     MsgBox strMsg
    
12.    
    
13. End Sub

复制代码

yl.fu

hwc2ycy 发表于 2013-5-26 11:29

老大，如何搞個OPEN事件一開就提醒啊

yl.fu

Private Sub Workbook_Open()    '打开文档时执行
    Application.ScreenUpdating = False
    Sheets(1).Activate    '进入第一页
    Call 设置界面
    Call 弊屏功能区
    Call 建立菜单
    Call 锁定工作表
    Application.ScreenUpdating = True
End Sub
  是不是這樣啊