SaveAs method vbcode 3

[aspag]

Need help!! vb code

It is urgent, please help

This code is a macro under MS OUTLOOK

It works, but I need to save strreport info into word/excel/text file

Tried to enter a line as
strreport.saveasfile "c:\report.txt" give me an compile error.
instead of " MsgBox strReport "

It is urgent, please help

Sub SendersInFolder()
Dim onsMapi As Outlook.NameSpace
Dim ofolderSource As Outlook.MAPIFolder
Dim omsgItem As Outlook.MailItem
Dim strReport As String
' Get the current Folder
Set onsMapi = Application.GetNamespace("MAPI")
Set ofolderSource = Application.ActiveExplorer.CurrentFolder
' Check for messages in Folder
If ofolderSource.Items.Count = 0 Then
strReport = "No Mail Items in current Folder"
Else
For Each omsgItem In ofolderSource.Items
' Get the Sender's name and Email address
strReport = strReport & omsgItem.SenderName & " / " & GetSenderID(omsgItem) & vbCrLf
Next
End If

MsgBox strReport

' Clean Up
Set ofolderSource = Nothing
Set onsMapi = Nothing
Set omsgItem = Nothing
End Sub

Thanks for you help in advance.
aspag

 

[garths2]

aspag,

Strings do not have a "saveAsFile" method, that would be my guess why you are getting a compile error. The code below would save the string to a text file. The code would go where the "MsgBox StrReport" line is.

' start code
Dim fileNumber As Integer

fileNumber = FreeFile

Open writePath & "filename.txt" For Output As #fileNumber
Print #fileNumber, strReport
Close #fileNumber

' end code

-GS

 

[garths2]

For clarification:

In the code I posted above "writePath" in the "Open" statement is a string that is meant to hold the path of the file to be stored.

-GS

 

[aspag]

Thanks a lot, it works. I just need to twig a little to obtain dates in year 2004 and also try a input box to pickfolder.

Next step is to count emails by month

Thanks a lot.

spag

 

[nicknicknick]

hi

i am getting used to outlook macros.
i am trying to design one which will depending on the name of the sender put the attachment in a specific folder on the hard disk!!
any ideas how i can do this - only thing is i have around 3,000 names and files -- gulp!!

pls help
thanks

 

[aspag]

OPEN VISUAL BASIC EDITOR MODIFY COPY AND PASTE AND RUN

Sub SendersInFolder()
Dim onsMapi As Outlook.NameSpace
Dim oFolderSource As Outlook.MAPIFolder
'Dim oFolder1 As Outlook.MAPIFolder ' ENTER ACTUAL NAME FROM FOLDER ABC
'Dim oFolder2 As Outlook.MAPIFolder ' DEC
Dim oFolder3 As Outlook.MAPIFolder ' EFG
DIM As Outlook.MAPIFolder ' ZYZ
'Dim ofolderSource As Outlook.MAPIFolder
Dim oMsgItem As Outlook.MailItem
Dim strReport1, strReport2, strReport3, strReport4 As String
Dim fileNumber1, fileNumber2, fileNumber3, fileNumber4 As Integer

' Get the current Folder
Set onsMapi = Application.GetNamespace("MAPI")
Set oFolderSource = onsMapi.Session.Folders("Personal Folders - A_Completed ASD") 'ENTER FOLDER NAME AS SEEN IN OUTLOOK
'Set oFolder1 = oFolderSource.Folders("ABC")
'Set oFolder2 = oFolderSource.Folders("DEC")
Set oFolder3 = oFolderSource.Folders("EFC")
'Set oFolder4 = oFolderSource.Folders("ZYZ")

'fileNumber1 = FreeFile
'fileNumber2 = FreeFile
fileNumber3 = FreeFile
'fileNumber4 = FreeFile

''Check for messages in Folder
''NEED TO FORMAT RECEIVEDTIME
'If oFolder1.Items.Count = 0 Then
' strReport1 = "No Mail Items in current Folder"
'Else
' For Each oMsgItem In oFolder1.Items
' If oMsgItem.ReceivedTime >= #1/1/2004# And oMsgItem.ReceivedTime <= #12/31/2004# Then
' If oMsgItem.SenderName = "ABC" Or oMsgItem.SenderName = "QRS" Then
' strReport1 = strReport1 & oMsgItem.SenderName & "~" & oMsgItem.To & "~" & oMsgItem.Subject & _
"~" & DateValue(oMsgItem.ReceivedTime) & _
"~" & (Month(oMsgItem.ReceivedTime) & "/" & "01" & "/" & Year(oMsgItem.ReceivedTime)) & _
vbCrLf
' End If
' End If
' Next
'End If
'If oFolder2.Items.Count = 0 Then
' strReport2 = "No Mail Items in current Folder"
'Else
' For Each oMsgItem In oFolder2.Items
' If oMsgItem.ReceivedTime >= #1/1/2004# And oMsgItem.ReceivedTime <= #12/31/2004# Then
' If oMsgItem.SenderName = "DEC" Then
' strReport2 = strReport2 & oMsgItem.SenderName & "~" & oMsgItem.To & "~" & oMsgItem.Subject & _
"~" & DateValue(oMsgItem.ReceivedTime) & _
"~" & (Month(oMsgItem.ReceivedTime) & "/" & "01" & "/" & Year(oMsgItem.ReceivedTime)) & _
vbCrLf
' End If
' End If
' Next
'End If
If oFolder3.Items.Count = 0 Then
strReport3 = "No Mail Items in current Folder"
Else
For Each oMsgItem In oFolder3.Items
If oMsgItem.ReceivedTime >= #1/1/2004# And oMsgItem.ReceivedTime <= #12/31/2004# Then
If oMsgItem.SenderName = "EFG" Then
strReport3 = strReport3 & oMsgItem.SenderName & "~" & oMsgItem.To & "~" & oMsgItem.Subject & _
"~" & DateValue(oMsgItem.ReceivedTime) & _
"~" & (Month(oMsgItem.ReceivedTime) & "/" & "01" & "/" & Year(oMsgItem.ReceivedTime)) & _
vbCrLf
End If
End If
Next
End If
'If oFolder4.Items.Count = 0 Then
' strReport4 = "No Mail Items in current Folder"
'Else
' For Each oMsgItem In oFolder4.Items
' If oMsgItem.ReceivedTime >= #1/1/2004# And oMsgItem.ReceivedTime <= #12/31/2004# Then
' If oMsgItem.SenderName = "ZYZ" Then
' strReport4 = strReport4 & oMsgItem.SenderName & "~" & oMsgItem.To & "~" & oMsgItem.Subject & _
"~" & DateValue(oMsgItem.ReceivedTime) & _
"~" & (Month(oMsgItem.ReceivedTime) & "/" & "01" & "/" & Year(oMsgItem.ReceivedTime)) & _
vbCrLf
' End If
' End If
' Next
'End If
'' Save strreport to a text file
' Open writePath & "C:\ABC.Txt" For Output As #fileNumber1
' Print #fileNumber1, strReport1
' Close #fileNumber1
' Open writePath & "C:\DEC.txt" For Output As #fileNumber2
' Print #fileNumber2, strReport2
' Close #fileNumber2
Open writePath & "C:\EFC.txt" For Output As #fileNumber3
Print #fileNumber3, strReport3
Close #fileNumber3
'Open writePath & "C:\ZYZ.txt" For Output As #fileNumber4
'Print #fileNumber4, strReport4
'Close #fileNumber4
'MsgBox strReport
' Clean Up
Set oFolderSource = Nothing
'Set oFolder4 = Nothing
Set oFolder3 = Nothing
'Set oFolder2 = Nothing
'Set oFolder1 = Nothing
Set onsMapi = Nothing
Set oMsgItem = Nothing
End Sub


Please try this, maybe there is an easier way to handle the routine

hope this helps

anji

 

[nicknicknick]

thanks anji

this gives me more of an insight!!

what i really want to do is -

depending on the sender,save attachment to a file on the c drive.
i.e

bob - c:\bob
ben - c:\ben

etc

only prob is i have a lot to cope with - 3,000

any help will gain u a star - lol

 

[aspag]

Option Explicit
'-----------------------------------------------------------------
Private Const MAX_PATH = 255
'-----------------------------------------------------------------
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'-----------------------------------------------------------------
Public Function Saveattachments(Optional PathName As String) As Boolean

Dim oOutlook As Outlook.Application
Dim oNs As Outlook.NameSpace
Dim oFldr As Outlook.MAPIFolder
Dim oMessage As Object
Dim sPathName As String
Dim oAttachment As Outlook.Attachment
Dim iCtr As Integer
Dim iAttachCnt As Integer

On Error GoTo ErrHandler

If PathName = "" Then
sPathName = GetTempDir
Else
sPathName = PathName
End If

If Right(sPathName, 1) <> "\" Then sPathName = sPathName & "\"
If Dir(sPathName, vbDirectory) = "" Then Exit Function

Set oOutlook = New Outlook.Application
Set oNs = oOutlook.GetNamespace("MAPI")
Set oFldr = oNs.GetDefaultFolder(olFolderInbox)
For Each oMessage In oFldr.Items
With oMessage.Attachments
iAttachCnt = .Count
If iAttachCnt > 0 Then
For iCtr = 1 To iAttachCnt
.Item(iCtr).SaveAsFile sPathName _
& .Item(iCtr).FileName
Next iCtr
End If
End With
DoEvents

Next oMessage
Saveattachments = True

ErrHandler:
Set oMessage = Nothing
Set oFldr = Nothing
Set oNs = Nothing
Set oOutlook = Nothing
End Function
'-----------------------------------------------------------------
Public Function GetTempDir() As String
Dim sRet As String, lngLen As Long
'create buffer
sRet = String(MAX_PATH, 0)
lngLen = GetTempPath(MAX_PATH, sRet)
If lngLen = 0 Then Err.Raise Err.LastDllError
GetTempDir = Left$(sRet, lngLen)
End Function


SEE IF THIS HELP - I GOT TIME FROM SOME VB INTERNET SITE

GOOD LUCK

SPAG

 

[garths2]

I didn't do any error checking or cleanup but here is what I think you are after.

' begin code
Dim oFolderSource As Outlook.MAPIFolder
Dim oFolder As Outlook.MAPIFolder
Dim oMsgItem As Outlook.MailItem
Dim NewFileName As String


Set onsMapi = Application.GetNamespace("MAPI")
Set oFolderSource = onsMapi.Session.Folders("mailBox name here") 'ENTER FOLDER NAME AS SEEN IN OUTLOOK
Set oFolder = oFolderSource.Folders("mail box folderName here")

For Each oMsgItem In oFolder.Items
For AttachmentCntr = 1 To oMsgItem.Attachments.Count
' assign FileName here
NewFileName = "C:\" & oMsgItem.SenderName & "\" & oMsgItem.Attachments.Item(AttachmentCntr).FileName
oMsgItem.Attachments.Item(AttachmentCntr).SaveAsFile (NewFileName)
Next
Next

' end code

-GS

 

[nicknicknick]

thanks gs

thats 99% of the way

do u know how to get it to also create the folder name as for this to work at the moment i need to create the folder myself manually?

cheers
nick

 

[garths2]

nick,

This should get you the rest of the way. Use the "mkdir" method to create the folder. Here is an example:

folderName = "c:\bob"
mkdir(folderName)

-GS

 

[nicknicknick]

thanks thats great

now all i want to do is have this macro run based on the open or close event in outlook.
any ideas?
i have tried the item_open and item_close but to no avail.