Home Menu

Menu


ExcelBanter » Excel Newsgroups » Excel Programming > Auto Running a macro on open
Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 191
Default Auto Running a macro on open
Hi There

I have put together the following macro that searches my inbox for specific
subject line content and attachments. It then saves all these attachments to
a specific folder, opens each attachment, copies and pastes certain details
into th espreadsheet that I run the macro from and then closes.

This macro works fine when I run it through toolsmacrorun macro etc but
what I really need is for it to run automatically when the sheet is opened.
Can anyone tell me how to do this?


Sub SaveAttachments()

Windows("EIS Job Log test.xls").Activate
Range("B2").Select



Dim olApp As Outlook.Application
Dim olNs As NameSpace
Dim Fldr As MAPIFolder
Dim MoveToFldr As MAPIFolder
Dim olMi As MailItem
Dim olAtt As Attachment
Dim MyPath As String
Dim i As Long

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set MoveToFldr = Fldr.Folders("eisreq")
MyPath = "I:\EIS\Forms\EIS Requests\"
dattim = Format(Date, "yyyymmdd") & " " & "Time-" & Format(Time, "hhmmss")


For i = Fldr.Items.Count To 1 Step -1
Range("A1").Select


rowlength = Selection.CurrentRegion.Rows.Count
Set olMi = Fldr.Items(i)
If InStr(1, olMi.Subject, "EIS") 0 Then
For Each olAtt In olMi.Attachments
If olAtt.Filename = "EIS Request.xls" Then
olAtt.SaveAsFile MyPath & Fldr.Items.Count & " " &
olMi.SenderName & " " & "Date-" & dattim & ".xls"
open1 = MyPath & Fldr.Items.Count & " " &
olMi.SenderName & " " & "Date-" & dattim & ".xls"
filenm = Fldr.Items.Count & " " & olMi.SenderName & "
" & "Date-" & dattim & ".xls"
End If

Next olAtt
olMi.Save
olMi.Move MoveToFldr
Workbooks.Open Filename:=open1

'copies and pastes date received
Range("B5").Select
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("A1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 1).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes Requester
Windows(filenm).Activate
Range("B13").Activate
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("B1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 2).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes Eis Staff Member
Windows(filenm).Activate
Range("B15").Activate
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("C1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 3).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes Description
Windows(filenm).Activate
Range("A20").Activate
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("D1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 4).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes Deadline
Windows(filenm).Activate
Range("B17").Activate
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("D1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 5).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes filename
Range("E1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 6).Select
End If
Next x
ActiveCell = filenm

Windows(filenm).Activate
ActiveWorkbook.Close False

End If
Next i

Set olAtt = Nothing
Set olMi = Nothing
Set Fldr = Nothing
Set MoveToFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing

End Sub
Reply With QuoteReply With Quote
  #2   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 1,080
Default Auto Running a macro on open
Sub Workbook_Open
'your code here
End Sub

Paste this into the code module associated with the ThisWorkbook object.

--

Vasant


"Jamie" wrote in message
...
Hi There

I have put together the following macro that searches my inbox for
specific
subject line content and attachments. It then saves all these attachments
to
a specific folder, opens each attachment, copies and pastes certain
details
into th espreadsheet that I run the macro from and then closes.

This macro works fine when I run it through toolsmacrorun macro etc but
what I really need is for it to run automatically when the sheet is
opened.
Can anyone tell me how to do this?


Sub SaveAttachments()

Windows("EIS Job Log test.xls").Activate
Range("B2").Select



Dim olApp As Outlook.Application
Dim olNs As NameSpace
Dim Fldr As MAPIFolder
Dim MoveToFldr As MAPIFolder
Dim olMi As MailItem
Dim olAtt As Attachment
Dim MyPath As String
Dim i As Long

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set MoveToFldr = Fldr.Folders("eisreq")
MyPath = "I:\EIS\Forms\EIS Requests\"
dattim = Format(Date, "yyyymmdd") & " " & "Time-" & Format(Time,
"hhmmss")


For i = Fldr.Items.Count To 1 Step -1
Range("A1").Select


rowlength = Selection.CurrentRegion.Rows.Count
Set olMi = Fldr.Items(i)
If InStr(1, olMi.Subject, "EIS") 0 Then
For Each olAtt In olMi.Attachments
If olAtt.Filename = "EIS Request.xls" Then
olAtt.SaveAsFile MyPath & Fldr.Items.Count & " " &
olMi.SenderName & " " & "Date-" & dattim & ".xls"
open1 = MyPath & Fldr.Items.Count & " " &
olMi.SenderName & " " & "Date-" & dattim & ".xls"
filenm = Fldr.Items.Count & " " & olMi.SenderName & "
" & "Date-" & dattim & ".xls"
End If

Next olAtt
olMi.Save
olMi.Move MoveToFldr
Workbooks.Open Filename:=open1

'copies and pastes date received
Range("B5").Select
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("A1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 1).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes Requester
Windows(filenm).Activate
Range("B13").Activate
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("B1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 2).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes Eis Staff Member
Windows(filenm).Activate
Range("B15").Activate
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("C1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 3).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes Description
Windows(filenm).Activate
Range("A20").Activate
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("D1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 4).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes Deadline
Windows(filenm).Activate
Range("B17").Activate
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("D1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 5).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes filename
Range("E1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 6).Select
End If
Next x
ActiveCell = filenm

Windows(filenm).Activate
ActiveWorkbook.Close False

End If
Next i

Set olAtt = Nothing
Set olMi = Nothing
Set Fldr = Nothing
Set MoveToFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing

End Sub


Reply With QuoteReply With Quote
  #3   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 1,120
Default Auto Running a macro on open
You need worksheet evnts. Take a look at
http://www.cpearson.com/excel/events.htm

--
HTH

Bob Phillips

"Jamie" wrote in message
...
Hi There

I have put together the following macro that searches my inbox for
specific
subject line content and attachments. It then saves all these attachments
to
a specific folder, opens each attachment, copies and pastes certain
details
into th espreadsheet that I run the macro from and then closes.

This macro works fine when I run it through toolsmacrorun macro etc but
what I really need is for it to run automatically when the sheet is
opened.
Can anyone tell me how to do this?


Sub SaveAttachments()

Windows("EIS Job Log test.xls").Activate
Range("B2").Select



Dim olApp As Outlook.Application
Dim olNs As NameSpace
Dim Fldr As MAPIFolder
Dim MoveToFldr As MAPIFolder
Dim olMi As MailItem
Dim olAtt As Attachment
Dim MyPath As String
Dim i As Long

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox)
Set MoveToFldr = Fldr.Folders("eisreq")
MyPath = "I:\EIS\Forms\EIS Requests\"
dattim = Format(Date, "yyyymmdd") & " " & "Time-" & Format(Time,
"hhmmss")


For i = Fldr.Items.Count To 1 Step -1
Range("A1").Select


rowlength = Selection.CurrentRegion.Rows.Count
Set olMi = Fldr.Items(i)
If InStr(1, olMi.Subject, "EIS") 0 Then
For Each olAtt In olMi.Attachments
If olAtt.Filename = "EIS Request.xls" Then
olAtt.SaveAsFile MyPath & Fldr.Items.Count & " " &
olMi.SenderName & " " & "Date-" & dattim & ".xls"
open1 = MyPath & Fldr.Items.Count & " " &
olMi.SenderName & " " & "Date-" & dattim & ".xls"
filenm = Fldr.Items.Count & " " & olMi.SenderName & "
" & "Date-" & dattim & ".xls"
End If

Next olAtt
olMi.Save
olMi.Move MoveToFldr
Workbooks.Open Filename:=open1

'copies and pastes date received
Range("B5").Select
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("A1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 1).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes Requester
Windows(filenm).Activate
Range("B13").Activate
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("B1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 2).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes Eis Staff Member
Windows(filenm).Activate
Range("B15").Activate
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("C1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 3).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes Description
Windows(filenm).Activate
Range("A20").Activate
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("D1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 4).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes Deadline
Windows(filenm).Activate
Range("B17").Activate
Selection.Copy
Windows("EIS Job Log test.xls").Activate
Range("D1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 5).Select
End If
Next x
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone,
SkipBlanks:= _
False, Transpose:=False

'copies and pastes filename
Range("E1").Select
For x = 1 To rowlength
If ActiveCell.Cells < "" Then
Cells(ActiveCell.Row + 1, 6).Select
End If
Next x
ActiveCell = filenm

Windows(filenm).Activate
ActiveWorkbook.Close False

End If
Next i

Set olAtt = Nothing
Set olMi = Nothing
Set Fldr = Nothing
Set MoveToFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing

End Sub


Reply With QuoteReply With Quote
Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes
Linear Mode Linear Mode

Posting Rules
Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On

Similar Threads
Thread Thread Starter Forum Replies Last Post
Macro to allow auto filter after running password protect Roady Excel Discussion (Misc queries) 1 July 17th 08 06:34 PM
Running macro on file open excelnerd Excel Discussion (Misc queries) 3 March 12th 08 10:51 PM
Auto running a macro on closing Jimmy D Excel Discussion (Misc queries) 6 November 22nd 07 01:58 AM
Running a macro from an auto-refresh Chris Youlden Excel Worksheet Functions 2 October 7th 07 04:22 PM
Stoping an Auto Open macro from running RzB Excel Programming 7 December 5th 03 02:36 AM


All times are GMT +1. The time now is 12:17 AM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Contact Us ExcelBanter forum home Privacy Statement