Ole

با سلام
یک پروسه 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

---