Jeffrey Mahoney
Well-known Member
- Joined
- May 31, 2015
- Messages
- 3,142
- Office Version
- 365
- Platform
- Windows
I use the code below to embed a PDF file as an object into my workbook. It works fine unless I have the same file open in Adobe Reader. The macro tells me that.
What I need is to open the file as read only so I don't have to always close it in Adobe Reader. Any suggestions?
What I need is to open the file as read only so I don't have to always close it in Adobe Reader. Any suggestions?
VBA Code:
Sub AddQuote()
Dim FileToOpen As String
Dim asht As Worksheet
Dim osht As Worksheet
Dim Cel As Range
Dim qCel As Range
Dim oCel As Range
Dim oPDF As Variant
Dim oPDFName As String
Dim cLeft As Double
Dim cTop As Double
Dim MaxONum As Long
Dim MaxOFormat As String
Dim FltrDesc As String
Dim FltrExt As String
Set asht = ActiveSheet
Set qCel = Selection.Resize(1, 1)
On Error GoTo HellFire
Set qCel = Intersect(asht.Range("Quote_hdr").EntireColumn, qCel.EntireRow)
On Error GoTo 0
Set osht = Sheets("Objects")
Set oCel = osht.Cells(osht.Cells.Rows.Count, 2).End(xlUp).Offset(5, 0)
cLeft = oCel.Offset(0, 1).Left
cTop = oCel.Offset(0, 1).Top
FileToOpen = SelectPDFOpen(False, "Choose a PDF Quote File")
If FileToOpen = "" Then Exit Sub
EventsOff
With osht
On Error Resume Next
Set oPDF = .OLEObjects.Add(filename:=FileToOpen, Link:=False, DisplayAsIcon:=True, IconFileName:= _
"C:\WINDOWS\Installer\{AC76BA86-1033-FFFF-7760-000000000006}\_PDFFile.ico", _
IconIndex:=0, IconLabel:="Adobe Acrobat Document", Left:=cLeft, Top:=cTop, Height:=50, Width:=50)
On Error GoTo 0
If IsFileOpen(FileToOpen) = True Then
MsgBox "That file is opened in another application. please close it and try again"
EventsOn
Exit Sub
End If
If oPDF Is Nothing Then
EventsOn
Exit Sub
End If
MaxONum = Application.Max(osht.Range("A:A")) + 1
MaxOFormat = Format(MaxONum, "000")
oPDFName = "Quote " & MaxOFormat
oPDF.Name = oPDFName
'.Shapes(oPDFName).LockAspectRatio = msoFalse
' .Shapes(oPDFName).Left = cLeft
' .Shapes(oPDFName).Top = cTop
' .Shapes(oPDFName).Height = 30
' .Shapes(oPDFName).Width = 200
oCel.Value = oPDFName
oCel.Offset(0, -1).Value = MaxONum
End With
qCel.Value = oPDFName
HellFire:
EventsOn
End Sub
Function SelectPDFOpen(MS As Boolean, Titl As String) As String
Dim fd As FileDialog, selectedFile As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = MS
.Title = Titl '"Select PDF file to insert"
.Filters.Clear
.Filters.Add "PDF Documents", "*.pdf"
If Not .Show Then
'MsgBox "User cancelled"
Exit Function
End If
SelectPDFOpen = .SelectedItems(1)
End With
End Function
Function IsFileOpen(filename As String) As Boolean
Dim filenum As Integer
Dim errnum As Integer
On Error Resume Next ' Turn error checking off.
filenum = FreeFile() ' Get a free file number.
' Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum
Close filenum ' Close the file.
errnum = Err ' Save the error number that occurred.
On Error GoTo 0 ' Turn error checking back on.
' Check to see which error occurred.
Select Case errnum
' No error occurred.
' File is NOT already open by another user.
Case 0
IsFileOpen = False
' Error number for "Permission Denied."
' File is already opened by another user.
Case 70
IsFileOpen = True
' Another error occurred.
Case Else
Error errnum
End Select
End Function