1.

Solve : outlook vba quesiton...?

Answer»

Ok, I was thinking of running the vba in powerpoint so as to leave outlook free, though I do not know what effect looping code in VBA with one microsoft program does to the functionality of other MS programs. I GUESS unless you were willing to let the vba in outlook start up powerpoint and then let it go "hands fee" you would probably have the same problem no matter which ms program was running the original code.Quote

Since it's working now and it 's only intended to be used for the next 2-3 weeks I'll probably leave it there, but not bad for a first timer!!!

Congrats! You'll be a whiz by the time March Madness 2009 rolls around. Quote from: Sidewinder on March 11, 2008, 03:47:27 PM
Congrats! You'll be a whiz by the time March Madness 2009 rolls around.

There is talk of leaving one of the machines with this on, as the sales manager is well impressed. I think he's trying to blag a 50" screen for the display as we speak.

I might have ago at tiding it up a little.

If I posted all the code, would you guys run your eye's over it?? let me know if I could make any changes to improve it??

cheersI'm willing to look it over, and not just because I could use it to set up a movie clip to play on my comp everytime I get new mail . I figure it helps to have someone else go through your code as their logic may be different from your own and they may also know of shortcuts that you don't.outlook code (main PAGE)

Code: [Select]Public WithEvents TargetFolderItems As Items
Public path As String


Private Sub Application_Startup()

'Declare MAPI folder
Dim ns As Outlook.NameSpace

'Set the default folder
Set ns = Application.GetNamespace("MAPI")
Set TargetFolderItems = ns.GetDefaultFolder(olFolderInbox).Items


Set ns = Nothing


End Sub

Private Sub TargetFolderItems_ItemAdd(ByVal Item As Object)



'Declare attachment & sender variables
Dim olAtt As Attachment
Dim olApp As Outlook.Application
Dim olNs As Outlook.NameSpace

Dim olMyParentFolder As MAPIFolder
Dim olMoveToFolder As MAPIFolder

Dim olNewItem As Object
Dim olSubject As String
Dim olsubjectna As String
Dim olsubjectna1 As String
Dim olsubjectna2 As String
Dim olAttach As String
Dim sender As String

Dim olDate As Date

'exit sub if undeliverable message as errors
olsubjectna = "Undeliverable*"
olsubjectna1 = "Read:*"
olsubjectna2 = "Not Read:*"

If Item.Subject Like olsubjectna Then
Exit Sub
End If
If Item.Subject Like olsubjectna1 Then
Exit Sub
End If
If Item.Subject Like olsubjectna2 Then
Exit Sub
End If



'Declare the sender address
'sender = "[emailprotected]"



'declare subject criteria (march madness File)
' looks for subject containing "Projection"
olSubject = "*March Madness*"

'If Item.SenderEmailAddress = sender Then
'When a new mail comes into the inbox check to see if it has an attachment and evaluate the sender
'Select Case Item.Subject
'is the mail subject _SALES_TARGET_UPLOAD?
'MsgBox "Mail Received!"

If Item.Subject Like olSubject Then


'pass file/path VARIABLE to IsFileOpen function. If True
If IsFileOpen("C:\march madness\March.ppt") = True Then

'MsgBox "condition correct!"
'saves and close's current open ppt
Set objppt = CreateObject("PowerPoint.Application")
objppt.Visible = True
Set objPresentation = objppt.Presentations("C:\march madness\MM Projection v 2.ppt")
objPresentation.Saved = True
objPresentation.Close
objppt.Quit


'MsgBox "Powerpoint closed"

create_directory


End If

Set olAtt = Item.Attachments(1)
olAtt.SaveAsFile "C:\March Madness\" & olAtt

'MsgBox "file saved"

Set objshell = CreateObject("Wscript.Shell")
objshell.Run "C:\powerSTART.bat"

End If

Set olApp = Nothing
Set olNs = Nothing
Set olMyParentFolder = Nothing
Set olMoveToFolder = Nothing
Set olNewItem = Nothing
Set olAtt = Nothing


End Sub

outlook modual code;

Code: [Select]'declare application and workbook variables
Public objExcel As PowerPoint.Application
Public objWB As PowerPoint.Presentation
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub create_directory()

'MsgBox "GOT to create directory"

'checks if the march madness folder exist

Dim PoExists As Boolean

'pass arguments to function
PoExists = FileOrDirExists("C:\march madness\")

'if the path(s) don't exist, create directories
If PoExists = FALSE Then
MkDir ("C:\march madness\")
End If


End Sub




Public Function IsFileOpen(FileName As String) As Boolean

'this function checks to see if a file is already open
'returns true if open

'declare variables
Dim iFilenum As Long
Dim iErr As Long

'check for lock file
On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
'assign number
iErr = Err
On Error GoTo 0

'select the outcome
Select Case iErr
Case 0: IsFileOpen = False
Case 70: IsFileOpen = True
'file not found
Case 53: IsFileOpen = False
Case Else: Error iErr
End Select

End Function

Sub delete_from_imported_dir()

On Error GoTo ErrHandler

'delete all files from imported extracts directory
Kill "C:\Oracle VB\Sales Target Upload\Imported Extracts\*"

'if no files in the directory exit sub (err_number 53)
ErrHandler:
Exit Sub

End Sub

End Sub

Function FileOrDirExists(PathName As String) As Boolean

'function returns true if the specified directory/file exists

Dim sTemp As String

'Ignore errors to allow for error evaluation
On Error Resume Next
sTemp = GetAttr(PathName)

'Check if error exists (0 = exists)
Select Case Err.Number
Case Is = 0
FileOrDirExists = True
Case Else
FileOrDirExists = False
End Select

'Resume error checking
On Error GoTo 0

End Functionbatch file starting vbs:

Code: [Select]@echo off

ping localhost 2 >nul

start c:\power.vbs

exit


vbs code starting powerpoint:

Code: [Select]Dim strComputer, strProcess, strProcessID

strComputer = "."
strProcess = "wscript.exe"

Function IsProcessRunning( strComputer, strProcess )
Dim Process, strObject
IsProcessRunning = False
strObject = "winmgmts://" & strComputer
For Each Process in GetObject( strObject ).InstancesOf( "win32_process" )
If UCase( Process.name ) = UCase( strProcess ) Then
IsProcessRunning = True
strProcessID = Process.ProcessID
' Wscript.Echo "Process ID: " & strProcessID
Exit Function
End If
Next
End Function





If( IsProcessRunning( strComputer, strProcess ) = True ) Then

' Wscript.Echo "Killing " & strProcessID

' ------ SCRIPT CONFIGURATION ------
intPID = strProcessID

' ------ END CONFIGURATION ---------
' WScript.Echo "Process PID: " & intPID
set objWMIProcess = GetObject("winmgmts:\\" & strComputer & _
"\root\cimv2:Win32_Process.Handle='" & intPID & "'")
' WScript.Echo "Process name: " & objWMIProcess.Name
intRC = objWMIProcess.Terminate()
if intRC = 0 Then
powerpoint
end if
End If


sub powerpoint()

' Wscript.echo ("starting powerpoint")

Const ppAdvanceOnTime = 2
Const ppShowTypeKiosk = 3
Const ppSlideShowDone = 5

Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True

Set objPresentation = objPPT.Presentations.Open("C:\march madness\MM Projection v 2.ppt")

objPresentation.Slides.Range.SlideShowTransition.AdvanceTime = 5
objPresentation.Slides.Range.SlideShowTransition.AdvanceOnTime = True

objPresentation.SlideShowSettings.AdvanceMode = ppAdvanceOnTime
objPresentation.SlideShowSettings.ShowType = ppShowTypeKiosk
objPresentation.SlideShowSettings.StartingSlide = 1
objPresentation.SlideShowSettings.EndingSlide = 2
objpresentation.slideshowsettings.loopuntilstopped = True


Set objSlideShow = objPresentation.SlideShowSettings.Run.View


Do Until objppt = SlideShowEnd
If Err <> 0 Then
Exit Do
End If
Loop

WScript.Quit

end sub


enjoy!!! Yikes! You certainly do get knee deep into the code. If it works, don't change a thing. Perhaps you could persuade your boss to pay you by the word!


Discussion

No Comment Found

Related InterviewSolutions