Darren Bartrup
Well-known Member
- Joined
- Mar 13, 2006
- Messages
- 1,296
- Office Version
- 365
- Platform
- 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:
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:
Class Module:
Any help greatly appreciated!!
Darren.
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
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.