outlook vba quesiton...

[SEBNN]

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.

[Sidewinder]

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.

[blastman]

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??

cheers

[SEBNN]

I'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.

[blastman]

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 = "[email protected]"

   
   
    '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



[blastman]

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 Function

[blastman]

batch 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!!! 

[Sidewinder]

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!