You cannot use FileDialog in MS Project, alas. You can use the following code instead; copy it to the top of a module:
Code: Select all
' Code for the Open and Save As dialogs
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_EXPLORER = &H80000
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_NODEREFERENCELINKS = &H100000
Public Const OFN_NONETWORKBUTTON = &H20000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_READONLY = &H1
Public Const OFN_SHOWHELP = &H10
Private Declare Function GetOpenFileNameA Lib "comdlg32.dll" _
(OFN As OPENFILENAME) As Boolean
Private Declare Function GetSaveFileNameA Lib "comdlg32.dll" _
(OFN As OPENFILENAME) As Boolean
Private Const ALLFILES = "All Files"
Function MakeFilterString(ParamArray varFilt() As Variant) As String
' Creates a filter string.
' Returns "" if there are no arguments.
' Expects an even number of argumenten (filter name, extension).
' Adds *.* if the number of arguments is odd.
Dim strFilter As String
Dim intRes As Integer
Dim intNum As Integer
intNum = UBound(varFilt)
If intNum <> -1 Then
For intRes = 0 To intNum
strFilter = strFilter & varFilt(intRes) & vbNullChar
Next
If intNum Mod 2 = 0 Then
strFilter = strFilter & "*.*" & vbNullChar
End If
strFilter = strFilter & vbNullChar
End If
MakeFilterString = strFilter
End Function
Private Sub InitOFN(OFN As OPENFILENAME)
With OFN
' Initialize fields
.hwndOwner = 0
.hInstance = 0
.lpstrCustomFilter = vbNullString
.nMaxCustFilter = 0
.lpfnHook = 0
.lpTemplateName = 0
.lCustData = 0
.nMaxFile = 511
.lpstrFileTitle = String(512, 0)
.nMaxFileTitle = 511
.lStructSize = Len(OFN)
If .lpstrFilter = "" Then
.lpstrFilter = MakeFilterString(ALLFILES)
End If
.lpstrFile = .lpstrFile & String(512 - Len(.lpstrFile), 0)
End With
End Sub
Private Sub ProcessOFN(OFN As OPENFILENAME)
With OFN
.lpstrFile = Left$(.lpstrFile, InStr(.lpstrFile, vbNullChar) - 1)
End With
End Sub
Function OpenDialog(OFN As OPENFILENAME) As Boolean
' Display the Open dialog.
Dim intRes As Integer
InitOFN OFN
intRes = GetOpenFileNameA(OFN)
If intRes Then
ProcessOFN OFN
End If
OpenDialog = intRes
End Function
Function SaveDialog(OFN As OPENFILENAME) As Boolean
' Display the Save As dialog.
Dim intRes As Integer
InitOFN OFN
intRes = GetSaveFileNameA(OFN)
If intRes Then
ProcessOFN OFN
End If
SaveDialog = intRes
End Function
Function GetOpenFileName(Optional FileFilter As String, Optional FilterIndex As Long, Optional Title As String = "Select a File") As String
Dim OFN As OPENFILENAME
With OFN
If FileFilter <> "" Then
.lpstrFilter = Replace(FileFilter, ",", vbNullChar) & vbNullChar
End If
.nFilterIndex = FilterIndex
.lpstrTitle = Title
End With
If OpenDialog(OFN) Then
GetOpenFileName = OFN.lpstrFile
End If
End Function
Function GetSaveAsFileName(InitialFileName As String, Optional FileFilter As String, Optional FilterIndex As Long, Optional Title As String = "Select a File") As String
Dim OFN As OPENFILENAME
With OFN
.lpstrFile = InitialFileName
If FileFilter <> "" Then
.lpstrFilter = Replace(FileFilter, ",", vbNullChar) & vbNullChar
End If
.nFilterIndex = FilterIndex
.lpstrTitle = Title
End With
If SaveDialog(OFN) Then
GetSaveAsFileName = OFN.lpstrFile
End If
End Function
Remove the lines
and
Code: Select all
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.Filters.Clear
fd.Filters.Add "Microsoft Project Files", "*.mpp"
fd.AllowMultiSelect = False
fd.Show
If (fd.SelectedItems.Count = 0) Then
Application.GetOpenFilename ("Microsoft Project Files (*.mpp), *.mpp")
pjApp.Quit
Set pjApp = Nothing
Exit Sub
End If
pjApp.FileOpen fd.SelectedItems(1)
from your code, and replace the latter with
Code: Select all
Dim strFile As String
strFile = GetOpenFileName("Microsoft Project Files,*.mpp")
If strFile = "" Then
MsgBox "You didn't select a file!", vbExclamation
pjApp.Quit
Set pjApp = Nothing
Exit Sub
End If
pjApp.FileOpen strFile