You are visitor number since
30 April 2005.
Go to Howard Kaikow's home page
Date: 2 May 2007(Modification of 30 March 2006 version)
From: Howard Kaikow <kaikow@standards.com>
Subject: Setting VBA Project Password
Note: This document should be printed using landscape mode.
Change History
- 30 April 2005: Original posting.
- 1 May 2005: Modified one comment, changed "Powerpoint" to "PowerPoint".
- 7 May 2005: Removed unneeded code that I had forgotten to remove on 30 April 2005.
- 8 May 2005: Removed unneeded code that I had forgotten to remove on 30 April 2005.
- 30 March 2006: Modified comment.
This document describes how to set a VBA project password in code. I have chosen to use Visual Basic 6, but the code should work, with minor changes, in the Microsoft Office applications. I chose to apply the techniques to only Access, Excel, PowerPoint and Word.
Usually, this problem is attacked by using SendKeys. The purpose of this document is to demonstrate how to do the deed without using SendKeys.
A valuable side-effect of this solution is that it demonstrates techniques that could be used to avoid using SendKeys with other dialogs.
Earlier versions of the code were run with Office 97, Office 2000, Office XP, and Office 2003.
Note: The code for Access does not work with Access 97. I have noted which line of code does not work with Access 97 in the comments in the code.
The following describes what you need to do to replicate my approach assuming you are using Visual Basic 6. It should not be difficult to adapt this description to run the code from within Office.
Note: This example was developed using Visual Basic 6, however, if converted to VBA, the code will not work with Office 97.
' Author:Howard Kaikow ' URL: http://www.standards.com/ ' Email address: kaikow@standards.com ' Date: April 2005 Option Explicit Public hWndProjectProperties As Long Public Function EnumChildProc(ByVal hWnd As Long, ByVal lParam As Long) As Long hWndProjectProperties = hWnd ' Do not recurse EnumChildProc = 0 End Function
' Author:Howard Kaikow ' URL: http://www.standards.com/ ' Email address: kaikow@standards.com ' Date: April 2005 Option Explicit ' API constants Private Const BM_CLICK As Long = &HF5& Private Const BM_SETCHECK As Long = &HF1& Private Const BST_CHECKED As Long = &H1& Private Const EM_REPLACESEL As Long = &HC2& Private Const HWND_TOPMOST As Long = -1 Private Const SWP_NOACTIVATE As Long = &H10& Private Const SWP_NOMOVE As Long = &H2& Private Const SWP_NOSIZE As Long = &H1& Private Const SWP_SHOWWINDOW As Long = &H40& Private Const TCM_SETCURFOCUS As Long = &H1330& ' API functions and subs Private Declare Function EnumChildWindows Lib "user32" _ (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetDlgItem Lib "user32.dll" _ (ByVal hDlg As Long, ByVal nIDDlgItem As Long) As Long Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _ (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" _ (ByVal hWnd As Long) As Long Private Declare Sub 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) Private Sub Form_Activate() ' It is necessary to force Form to be topmost SetWindowPos Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, _ SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE End Sub Private Sub btnByeBye_Click() Unload Me End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) If UnloadMode = vbFormControlMenu Then Cancel = 1 MsgBox "Please use the " & btnByeBye.Caption & " button to exit.", vbInformation + vbOKOnly, _ "Close button cannot be used to exit" Else Cancel = 0 End If End Sub Private Function GetPath(strStartPath As String, strType As String, strProject As String) As String ' GetPath returns file path to be saved ' strStartPath: Aw, shucks, you can figure this out yourself ' strType: File type for saved file ' strProject: Project name Dim i As Long Dim strPath As String Dim strProjectStart As String strProjectStart = strProject strPath = strStartPath & "\" & strProjectStart & "." & strType i = -1 While Len(Dir(strPath)) <> 0 i = i + 1 strProjectStart = strProject & Format(i) strPath = strStartPath & "\" & strProjectStart & "." & strType Wend GetPath = strPath End Function Private Function GetPassword() As String ' Set password GetPassword = "my" End Function Private Sub SetPassword(proj As VBProject, strPassword As String) ' Author:Howard Kaikow ' URL: http://www.standards.com/ ' Email address: kaikow@standards.com ' Date: April 2005 ' spy++ was used to find the Control IDs in Project Properties dialog Const ControlIDConfirmPassword As Long = &H1556& Const ControlIDLockProject As Long = &H1557& Const ControlIDOK As Long = &H1& Const ControlIDPassword As Long = &H1555& Const ControlIDSysTabControl32 As Long = &H3020& Dim ctrl As Office.CommandBarControl Dim hWnd As Long Dim hWndLockProject As Long Dim hWndPassword As Long Dim hWndConfirmPassword As Long Dim hWndOK As Long Dim hWndSysTabControl32 As Long Dim strCaption As String With proj strCaption = .Name & " - Project Properties" With .VBE ' Find Project Properties dialog Set ctrl = .CommandBars.FindControl(ID:=2578) ' Display Project Properties dialog ctrl.Execute Set ctrl = Nothing End With End With ' Get hWnd for Project Properties dialog hWndProjectProperties = FindWindow(vbNullString, strCaption) If hWndProjectProperties = 0 Then Exit Sub End If ' Get hWnd for OK button in Project Properties dialog hWndOK = GetDlgItem(hWndProjectProperties, ControlIDOK) ' Get hWnd for Tab Control in Project Properties dialog hWndSysTabControl32 = GetDlgItem(hWndProjectProperties, ControlIDSysTabControl32) 'Move to Protection tab SendMessage hWndSysTabControl32, TCM_SETCURFOCUS, 1, ByVal 0& ' Must reset hWndProjectProperties probably because tab changed. EnumChildWindows ByVal hWndProjectProperties, AddressOf EnumChildProc, ByVal 0 ' Get hWnd for Password Edit control in Project Properties dialog hWndPassword = GetDlgItem(hWndProjectProperties, ControlIDPassword) ' Get hWnd for Confirm Password Edit control in Project Properties dialog hWndConfirmPassword = GetDlgItem(hWndProjectProperties, ControlIDConfirmPassword) ' Get hWnd for Lock Project checkbox control in Project Properties dialog hWndLockProject = GetDlgItem(hWndProjectProperties, ControlIDLockProject) ' Lock project for &viewing SendMessage hWndLockProject, BM_SETCHECK, BST_CHECKED, 0 ' &Password SendMessage hWndPassword, EM_REPLACESEL, vbTrue, ByVal strPassword ' &Confirm password SendMessage hWndConfirmPassword, EM_REPLACESEL, vbTrue, ByVal strPassword 'OK button SetFocusAPI hWndOK SendMessage hWndOK, BM_CLICK, 0&, 0& End Sub
Private Sub btnCreatePowerPointPresentation_Click() Const strProject As String = "HKNewProject" Const strType As String = "ppt" Dim appPowerPoint As PowerPoint.Application Dim pptPowerPoint As PowerPoint.Presentation Dim strStartPath As String btnCreatePowerPointPresentation.Enabled = False Set appPowerPoint = New PowerPoint.Application With appPowerPoint strStartPath = App.Path Set pptPowerPoint = .Presentations.Add With pptPowerPoint .VBProject.Name = strProject SetPassword .VBProject, GetPassword() .SaveAs FileName:=GetPath(strStartPath, strType, strProject) End With .Quit End With Set appPowerPoint = Nothing Set pptPowerPoint = Nothing btnCreatePowerPointPresentation.Visible = False End Sub Private Sub btnCreateAccessDatabase_Click() Const strProject As String = "HKNewProject" Const strType As String = "mdb" Dim appAccess As Access.Application Dim strStartPath As String btnCreateAccessDatabase.Enabled = False strStartPath = App.Path Set appAccess = New Access.Application With appAccess .NewCurrentDatabase GetPath(strStartPath, strType, strProject) If .GetOption("Project Name") <> strProject Then .SetOption "Project Name", strProject End If ' The following does not compile in Access 97 SetPassword .VBE.VBProjects(strProject), GetPassword() .Quit End With Set appAccess = Nothing btnCreateAccessDatabase.Visible = False End Sub Private Sub btnCreateWordTemplate_Click() Const strProject As String = "HKNewProject" Const strType As String = "dot" Dim appWord As Word.Application Dim docWord As Word.Document Dim strStartPath As String btnCreateWordTemplate.Enabled = False Set appWord = New Word.Application With appWord ' strStartPath = .Options.DefaultFilePath(wdUserTemplatesPath) strStartPath = App.Path Set docWord = .Documents.Add(NewTemplate:=True) With docWord .VBProject.Name = strProject SetPassword .VBProject, GetPassword() .SaveAs GetPath(strStartPath, strType, strProject), addtorecentfiles:=False End With .Quit End With Set appWord = Nothing Set docWord = Nothing btnCreateWordTemplate.Visible = False End Sub Private Sub btnCreateExcelWorkbook_Click() Const strProject As String = "HKNewProject" Const strType As String = "xls" Dim appExcel As Excel.Application Dim strStartPath As String Dim wbkExcel As Excel.Workbook btnCreateExcelWorkbook.Enabled = False Set appExcel = New Excel.Application With appExcel ' strStartPath = .DefaultFilePath strStartPath = App.Path Set wbkExcel = .Workbooks.Add() With wbkExcel .VBProject.Name = strProject SetPassword .VBProject, GetPassword() .SaveAs FileName:=GetPath(strStartPath, strType, strProject), addtomru:=False End With .Quit End With Set appExcel = Nothing Set wbkExcel = Nothing btnCreateExcelWorkbook.Visible = False End Sub
Running the program
I chose to use the password "my", which is set in the GetPassword function.
I chose to have all files created in the directory in which the program runs.
When you click on a button to run the code for a particular Office application, the button will be disabled and will vanish when that particular code is completed