- Tham gia
- 3/6/06
- Bài viết
- 1,611
- Được thích
- 14,001
- Nghề nghiệp
- ...thiết kế máy bay cho VOI tự lái...^.^
Password (phần I)
Module mở password của EDC, nhằm giúp các bạn học hỏi.
Lắm lúc khi tôi Protect một sheet, quên password,...đúng là dở khóc dở cười.
Các bạn hãy download Add-in này về mà sử dụng:
Http://WWW.Erlandsenddata.no
Trong chương trình có 3 form và 4 module.
Module modMenu:
Mã:
' Purpose: Create the main menu and add the tool menu
' ------------------------------------------------------------
' Author: Ole P. Erlandsen, ope@erlandsendata.no
' Company: Erlandsen Data Consulting, http://www.erlandsendata.no
' Revision History:
' 1998-12-11 OPE: Created.
' 2002-05-08 OPE: Updated.
' ------------------------------------------------------------
Option Explicit
Public Const EDCMenuTag As String = "EDC_menu"
Public Const EDCToolTag As String = "EDC_PasswordTool" ' a unique tool identification
Sub CreateMenuPasswordTool()
' creates your custom menu, duplicate this procedure for each menu you want to create
Dim cbm As CommandBarPopup, cbMenu As CommandBarPopup, cbSubMenu As CommandBarPopup
On Error Resume Next
Set cbm = GetEDCMenu(Application.CommandBars.ActiveMenuBar) ' returns/creates the main menu
On Error GoTo 0
If cbm Is Nothing Then Exit Sub
DeleteCommandBarControl Application.CommandBars.ActiveMenuBar, EDCToolTag ' delete the custom menu if it already exists
On Error Resume Next
Set cbMenu = cbm.Controls.Add(msoControlPopup, , , , True)
On Error GoTo 0
If cbMenu Is Nothing Then Exit Sub ' could not create/find the menu
With cbMenu
Select Case ICS
Case 47
.Caption = "&Passord"
Case Else
.Caption = "&Password"
End Select
.Tag = EDCToolTag
.BeginGroup = False
End With
'add a menuitem to the menu
With cbMenu.Controls.Add(msoControlButton, 1, , , True)
Select Case ICS
Case 47
.Caption = "Den &aktive arbeidsboken..."
Case Else
.Caption = "The &active workbook..."
End Select
.OnAction = "'" & ThisWorkbook.Name & "'!UnprotectInActiveWorkbook"
.Style = msoButtonIconAndCaption
.FaceId = 225
End With
'add a menuitem to the menu
With cbMenu.Controls.Add(msoControlButton, 1, , , True)
Select Case ICS
Case 47
.Caption = "En &beskyttet arbeidsbok..."
Case Else
.Caption = "A &protected workbook..."
End Select
.OnAction = "'" & ThisWorkbook.Name & "'!OpenProtectedWB"
.Style = msoButtonIconAndCaption
.FaceId = 23
End With
' default menu code'
' add a menuitem to the menu
With cbMenu.Controls.Add(msoControlButton, 1, , , True)
.BeginGroup = True
Select Case ICS
Case 47
.Caption = "&Hjelp..."
Case Else
.Caption = "&Help..."
End Select
.OnAction = "'" & ThisWorkbook.Name & "'!HelpThisWorkbookPasswordTool"
.Style = msoButtonIconAndCaption
.FaceId = 49
End With
' add a menuitem to the menu
With cbMenu.Controls.Add(msoControlButton, 1, , , True)
Select Case ICS
Case 47
.Caption = "&Om " & ThisWorkbook.Name & "..."
Case Else
.Caption = "&About " & ThisWorkbook.Name & "..."
End Select
.OnAction = "'" & ThisWorkbook.Name & "'!AboutThisWorkbookPasswordTool"
.Style = msoButtonIconAndCaption
.FaceId = 487
End With
' add a menuitem to the menu
With cbMenu.Controls.Add(msoControlButton, 1, , , True)
Select Case ICS
Case 47
.Caption = "&Lukk " & ThisWorkbook.Name
Case Else
.Caption = "&Close " & ThisWorkbook.Name
End Select
.OnAction = "'" & ThisWorkbook.Name & "'!CloseThisWorkbookPasswordTool"
.Style = msoButtonIconAndCaption
.FaceId = 1088
End With
Set cbSubMenu = Nothing
Set cbMenu = Nothing
End Sub
Private Sub RemoveThisMenuPasswordTool() ' used by the menu to remove itself
DeleteCommandBarControl Nothing, EDCToolTag
DeleteEmptyEDCMenus
End Sub
Private Function GetEDCMenu(cb As CommandBar) As CommandBarPopup
' returns the main menu control
Dim cbMenu As CommandBarPopup
If cb Is Nothing Then Exit Function
Set cbMenu = cb.FindControl(, , EDCMenuTag, True, True)
If cbMenu Is Nothing Then
On Error Resume Next
Set cbMenu = cb.Controls.Add(msoControlPopup, , , , True)
On Error GoTo 0
End If
If Not cbMenu Is Nothing Then
With cbMenu
Select Case ICS
Case 47
.Caption = "&EDC"
.TooltipText = "Verktøy fra Erlandsen Data Consulting"
Case Else
.Caption = "&EDC"
.TooltipText = "Tools from Erlandsen Data Consulting"
End Select
.Tag = EDCMenuTag
.BeginGroup = False
End With
Set GetEDCMenu = cbMenu
End If
Set cbMenu = Nothing
End Function[*]Sub DeleteEmptyEDCMenus()
' deletes the main menu if it is empty
Dim cb As CommandBar, cbm As CommandBarPopup
Select Case ICS
Case 47
Application.StatusBar = "Rydder i menyene..."
Case Else
Application.StatusBar = "Cleaning menus..."
End Select
For Each cb In Application.CommandBars
Set cbm = cb.FindControl(, , EDCMenuTag, False, True)
If Not cbm Is Nothing Then
If cbm.Controls.Count = 0 Then
On Error Resume Next
cbm.Delete
On Error GoTo 0
End If
End If
Next cb
Set cb = Nothing
Application.StatusBar = False
End Sub
Sub DeleteCommandBarControl(cb As CommandBar, strTag As String)
' deletes commandbar controls with a tag = strTag from cb
Dim c As CommandBarControl
If cb Is Nothing Then ' delete ALL occurences
Set c = Application.CommandBars.FindControl(, , strTag, False)
Do While Not c Is Nothing
On Error Resume Next
c.Delete
On Error GoTo 0
Set c = Application.CommandBars.FindControl(, , strTag, False)
Loop
Else ' delete from one commandbar
Set c = cb.FindControl(, , strTag, False, True)
Do While Not c Is Nothing
On Error Resume Next
c.Delete
On Error GoTo 0
Set c = cb.FindControl(, , strTag, False, True)
Loop
End If
Set c = Nothing
End Sub(Trích bài của anh Lê Văn Duyệt)
Chỉnh sửa lần cuối bởi điều hành viên:
