Unlock VBA project using SendKeys.

Darren Bartrup

Well-known Member
Joined
Mar 13, 2006
Messages
1,296
Office Version
  1. 365
Platform
  1. Windows
I've got a 1000+ spreadsheets held within email attachments which I need to import into Access tables.
Unfortunately they're not in a format where I can easily import into Access (i.e. they're not in a list/table format).

I've written the code to save the attachments to a folder, open the workbook, copy the relevant data to a table and then close & delete the workbook.

The Workbook_BeforeClose event has code which saves the workbook before it closes though, and confirms this with the user by way of a messagebox... this code fires everytime the a workbook is closed. VERY annoying when there's so many workbooks to process. The code is also password protected.

Now in hindsight, I would've taken better care when building this lot - i.e. trusted the users to save the workbook each time (yeah, right.... trust the user???!!!).

I understand the only way to unprotect a VBA project is to use SendKeys, but this doesn't seem to be working. My code in Access isn't making Excel the active window I guess.

The code I'm using is:
Code:
                    '//Unprotect VBA for Workbook.
                    AppActivate "Microsoft Excel"
                    SendKeys "%{F11}"   'Open VBE
                    SendKeys "%T"       'Select Tools toolbar
                    SendKeys "%E"       'Select VBAProject Properties
                    SendKeys "MyPassword" 'Enter password into dialog box
                    SendKeys "{Enter}"  'Press OK
                    'RemoveAllCode XLApp
But this isn't working - the idea is to unlock the code and delete the part that forces the workbook to save.

Is this feasible? Or is there a way to stop the macro from running? I set the security to Very High, but as I wrote the code then it trusts me so it runs it anyway.

Can I get at the data without opening the workbook - taking into account I need to access the cell references.

My complete code is:
Code:
Sub Test()
    ExtractEmailAttachments "Mailbox - ASC Process Improvement Project", _
        "FAT Returns", "xls", "J:\BST\Systems\Projects\Functional Analysis Study\Returns"
End Sub

Sub ExtractEmailAttachments(InBoxFolder As String, OutlookSubFolder As String, _
    ExtString As String, DestFolder As String)
    Dim ns          As Namespace
    Dim MailBox     As MAPIFolder
    Dim Inbox       As MAPIFolder
    Dim SubFolder   As MAPIFolder
    Dim Item        As Object
    Dim Atmt        As Attachment
    Dim I           As Integer
    Dim FileName    As String
    Dim MyDocPath   As String
    Dim wsh         As Object
    Dim fs          As Object
    Dim XLApp       As Excel.Application
    Dim sSQL        As String
    
    '//Set references to email.
    Set ns = GetNamespace("MAPI")
    Set MailBox = ns.Folders(InBoxFolder)
    Set Inbox = MailBox.Folders("Inbox")
    Set SubFolder = Inbox.Folders(OutlookSubFolder)

    I = 0
    '//Check subfolder for messages and exit if none found.
    If SubFolder.Items.Count = 0 Then
        MsgBox "There are no messages in this folder: " & OutlookSubFolder, _
            vbInformation, "Nothing Found"
        Set SubFolder = Nothing
        Set Inbox = Nothing
        Set ns = Nothing
        Exit Sub
    End If

    '//Create DestFolder if DestFolder = ""
    If DestFolder = "" Then
        Set wsh = CreateObject("WScript.Shell")
        Set fs = CreateObject("Scripting.FileSystemObject")
        MyDocPath = wsh.specialfolders.Item("mydocuments")
        DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
        If Not fs.folderexists(DestFolder) Then
            fs.createfolder DestFolder
        End If
        Exit Sub
    End If

    If Right(DestFolder, 1) <> "\" Then
        DestFolder = DestFolder & "\"
    End If
    
    '//Create a new instance of the worker class.
    Dim Wrkr As clsWorker
    Set Wrkr = New clsWorker
        
    '//Check each message for attachments and extensions.
    For Each Item In SubFolder.Items
        For Each Atmt In Item.Attachments
            If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
                '//Save file to DestFolder.
                FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
                Atmt.SaveAsFile FileName
                I = I + 1
                '//Check if Excel is running and set a reference to it.
                If IsAppRunning("Excel.Application") = False Then
                    Set XLApp = CreateObject("Excel.Application")
                Else
                    Set XLApp = GetObject(, "Excel.Application")
                End If
                XLApp.Visible = True  'Comment out on final run.
                With XLApp
                    '//Open workbook for data collection.
                    .Workbooks.Open FileName
                    With .ActiveWorkbook.Worksheets("MONDAY Analysis")
                        Wrkr.Name = .Cells(3, 3)
                        Wrkr.JobTitle = .Cells(3, 7)
                        Wrkr.Team = .Cells(4, 7)
                        Wrkr.ContractedHours = .Cells(4, 4)
                        Wrkr.TermTime = .Cells(5, 4)
                    End With
                    '//Insert details into database.
                    sSQL = "INSERT INTO tblWorkerDetails " & _
                        "VALUES ('" & Wrkr.Name & "', '" _
                        & Wrkr.JobTitle & "', '" _
                        & Wrkr.ContractedHours & "', '" _
                        & Wrkr.TermTime & "');"
                    DoCmd.SetWarnings False
                    DoCmd.RunSQL (sSQL)
                    DoCmd.SetWarnings True
                    
                    '//Unprotect VBA for Workbook.
                    AppActivate "Microsoft Excel"
                    SendKeys "%{F11}"   'Open VBE
                    SendKeys "%T"       'Select Tools toolbar
                    SendKeys "%E"       'Select VBAProject Properties
                    SendKeys "MyPassword" 'Enter password into dialog box
                    SendKeys "{Enter}"  'Press OK
                    'RemoveAllCode XLApp
                    '//Close workbook.
'                    .ActiveWorkbook.Close
'                    Kill FileName
                End With
            End If
        Next Atmt
    Next Item


End Sub

Function IsAppRunning(ByVal sAppName) As Boolean
    Dim oApp As Object
    On Error Resume Next
    Set oApp = GetObject(, sAppName)
    If Not oApp Is Nothing Then
        Set oApp = Nothing
        IsAppRunning = True
    End If
End Function

Class Module:
Code:
Private pWrkrName           As String
Private pWrkrTitle          As String
Private pWrkrTeam           As String
Private pContractedHrs      As Double
Private pTermTime           As String

'//Name property
Public Property Get Name() As String
    Name = pWrkrName
End Property
Public Property Let Name(Value As String)
    pWrkrName = StrConv(Value, vbProperCase)
End Property

'//Job Title property
Public Property Get JobTitle() As String
    JobTitle = pWrkrTitle
End Property
Public Property Let JobTitle(Value As String)
    pWrkrTitle = Value
End Property

'//Worker Team property
Public Property Get Team() As String
    Team = pWrkrTeam
End Property
Public Property Let Team(Value As String)
    pWrkrTeam = Value
End Property

'//Contracted Hours property
Public Property Get ContractedHours() As Double
    ContractedHours = pContractedHrs
End Property
Public Property Let ContractedHours(Value As Double)
    pContractedHrs = Value
End Property

'//Term Time property
Public Property Get TermTime() As String
    TermTime = pTermTime
End Property
Public Property Let TermTime(Value As String)
    pTermTime = Value
End Property

Any help greatly appreciated!!
Darren.
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
Hadn't thought of that one.

I'll try it tomorrow at work.
Thanks.
Darren.
 
Upvote 0

Forum statistics

Threads
1,213,534
Messages
6,114,184
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top