PDA

View Full Version : Opening a Pdf recieved



benc
10-28-2015, 03:22 PM
Hi , im new to Vba and done know where to start.

I want to open the same pdf sent every hour and display fullscreen, is there anyway I can do this ?

Also if I can open the pdf at 9 if it reopened another attachment at 10 could that close reader before opening another so theres not hundreds of pdfs open ?

Any help really would be appriciated.

gmayor
10-28-2015, 11:46 PM
Closing the PDF would be a stretch, but the following should open the default PDF application full screen and open the PDF in question. If the PDF is already open, you will see a warning message to close it before continuing. You will be locked in a loop until you close the file or click 'Cancel'.


Option Explicit

Private Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Sub ProcessMessage()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
OpenPDFAttachment olMsg
lbl_Exit:
Exit Sub
End Sub

Sub OpenPDFAttachment(Item As Outlook.MailItem)
On Error Resume Next
Dim oAtt As Attachment
Dim FSO As Object
Dim sTempFolder As Object
Dim strFilename As String
Dim iAsk As Long
Set FSO = CreateObject("scripting.filesystemobject")
Set sTempFolder = FSO.GetSpecialFolder(2)

For Each oAtt In Item.Attachments
If oAtt.FileName Like "*.pdf" Then
strFilename = sTempFolder & "\" & oAtt.FileName
Start:
If FileExists(strFilename) Then Kill strFilename
If Err Then
iAsk = MsgBox("The PDF file appears to be open." & vbCr & vbCr & _
"Close the PDF before continuing by clicking 'OK'", vbOKCancel)
If iAsk = vbCancel Then GoTo lbl_Exit
If FileExists(strFilename) Then
Err.Clear
GoTo Start
End If
End If
On Error GoTo Err_Handler:
oAtt.SaveAsFile strFilename
'Open attachment
ShellExecute 0, "open", strFilename, vbNullString, vbNullString, 3
End If
Next oAtt

'Cleanup
If Not FSO Is Nothing Then Set FSO = Nothing
lbl_Exit:
Set FSO = Nothing
Set oAtt = Nothing
Set sTempFolder = Nothing
Exit Sub

Err_Handler:
If Err <> 0 Then
MsgBox Err.Number & " - " & Err.Description
Err.Clear
End If
GoTo lbl_Exit
End Sub

Private Function FileExists(filespec) As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Set FSO = Nothing
Exit Function
End Function