Issue using msodialoFilePicker used in Ms Project

[chamdan]

Hi Hans,
I have an error that keep on showing each time I run the macro. Here blow is the macro that I am using with msproject.

Code: Select all

Sub LoadProjectFile()

Dim pjApp As MSProject.Application
Dim FileToOpen
Dim Proj As MSProject.Project
Dim Project_Task As Task
Dim fd As FileDialog

Set pjApp = New MSProject.Application

If pjApp Is Nothing Then
MsgBox "Project is not installed"
End
End If

pjApp.Visible = True
AppActivate "Microsoft Project"

[b]Set fd = Application.FileDialog(msoFileDialogFilePicker)[/b]  ' the error happens here
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)
Debug.Print "Project_Task_Name~CustomField"

Dim ass As Assignment
For Each Project_Task In pjApp.ActiveProject.Tasks
            If Not Project_Task Is Nothing Then

                For Each ass In Project_Task.Assignments
                    assignCFVal = assignCFVal & "," & ass.VBATestField '<<PROBLEM Line
                Next ass

               Debug.Print Project_Task.Name & "~" & assignCFVal
               assignCFVal = ""
            End If
        Next Project_Task

pjApp.FileClose pjDoNotSave
pjApp.Quit
Set pjApp = Nothing

End Sub

The error is shown in the attached image.

your help is needed. Thanks in advance.

Chuck

[HansV]

Where are you running this code? In MS Project? Or ...?

[chamdan]

I checked whether the object library 12 is referenced and yes I did. Yes in ms project!

[HansV]

What do you mean by "object library 12"? That could be Word, Excel, Access, Outlook, Publisher, Visio, Project, Office, ...

[HansV]

I'm confused, since Application.GetOpenFilename is Excel VBA, not Project VBA. That's why I asked in which application you are creating and running the macro.

[chamdan]

Hans I meant Microsoft Office object Library and regarding the Application.GetOpenFilename I thought VBA would be for either one excel, msword, or ms project as well.

[HansV]

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

Code: Select all

Dim fd As FileDialog

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

[chamdan]

Hans,

It worked like a charm!



Chuck