smderfan
پنج شنبه 03 اسفند 1385, 20:24 عصر
با سلام
خسته نباشید ...
یک پروژه برای OLE گیر اوردم .... فقط می خوام اگر زحمتی نیست برام تکمیلش کنید.
پیشاپیش از زحمتی که می کشید متشکرم...
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.
Create a new Standard EXE project.
Add a code module.
Include five command buttons on the Form. I chose to use the followng Names and Captions:
btnByeBye, caption "Bye Bye!"
btnCreateAccessDatabase, caption "Create Access Database"
btnCreateExcelWorkbook, caption "Create Excel Workbook"
btnCreatePowerPointPresentation, caption "Create PowerPoint Presentation"
btnCreateWordTemplate, caption "Create Word Template"
Add project references for the Office object library and the VBA Extensibilty 5.3 library. In Office 97, use a reference to the VBA Extensibility library instead of a reference to the VBA Extensibility 5.3 library.
Insert the following code in the code module:
' 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
Insert the following code in the Form:
' 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
For each application you wish to use, include the appropriate sub in the code for the Form and include references to the needed libraries for Access, Excel, PowerPoint, and Word.
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
خسته نباشید ...
یک پروژه برای OLE گیر اوردم .... فقط می خوام اگر زحمتی نیست برام تکمیلش کنید.
پیشاپیش از زحمتی که می کشید متشکرم...
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.
Create a new Standard EXE project.
Add a code module.
Include five command buttons on the Form. I chose to use the followng Names and Captions:
btnByeBye, caption "Bye Bye!"
btnCreateAccessDatabase, caption "Create Access Database"
btnCreateExcelWorkbook, caption "Create Excel Workbook"
btnCreatePowerPointPresentation, caption "Create PowerPoint Presentation"
btnCreateWordTemplate, caption "Create Word Template"
Add project references for the Office object library and the VBA Extensibilty 5.3 library. In Office 97, use a reference to the VBA Extensibility library instead of a reference to the VBA Extensibility 5.3 library.
Insert the following code in the code module:
' 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
Insert the following code in the Form:
' 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
For each application you wish to use, include the appropriate sub in the code for the Form and include references to the needed libraries for Access, Excel, PowerPoint, and Word.
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