如何在 Fortran 中更改 SHBrowseForFolder 的初始目录

Question

现在我尝试编写一个 Fortran 代码，该代码可以显示一个对话框，用于使用 SHBrowseForFolder 选择目录。但是我不知道更改SHBrowseForFolder 中初始目录的过程。有人不知道Fortran吗？我当前的 Fortran 代码如下所示。

program selectFolder
  use ifwinty
  use ifcom, only: COMInitialize, COMUnInitialize
  implicit none
  integer, parameter :: BIF_RETURNONLYFSDIRS  = Z'00000001'
  integer, parameter :: BIF_DONTGOBELOWDOMAIN = Z'00000002'
  integer,parameter :: BIF_STATUSTEXT         = Z'00000004'
  integer,parameter :: BIF_RETURNFSANCESTORS  = Z'00000008'
  integer,parameter :: BIF_EDITBOX            = Z'00000010'
  integer,parameter :: BIF_VALIDATE           = Z'00000020'
  integer,parameter :: BIF_NEWDIALOGSTYLE     = Z'00000040'
  integer,parameter :: BIF_USENEWUI           = ior(BIF_NEWDIALOGSTYLE,BIF_EDITBOX)
  integer,parameter :: BIF_BROWSEINCLUDEURLS  = Z'00000080'
  integer,parameter :: BIF_UAHINT             = Z'00000100'
  integer,parameter :: BIF_NONEWFOLDERBUTTON  = Z'00000200'
  integer,parameter :: BIF_NOTRANSLATETARGETS = Z'00000400' 
  integer,parameter :: BIF_BROWSEFORCOMPUTER  = Z'00001000'
  integer,parameter :: BIF_BROWSEFORPRINTER   = Z'00002000'
  integer,parameter :: BIF_BROWSEINCLUDEFILES = Z'00004000'
  integer,parameter :: BIF_SHAREABLE          = Z'00008000'
  integer,parameter :: BFFM_INITIALIZED       = 1

  type :: t_browseinfo  
!    sequence
    integer(HANDLE) :: hwndOwner = NULL
    integer(LPINT)  :: pidlRoot  = NULL
    integer(LPSTR)  :: pszDisplayName 
    integer(LPCSTR) :: lpszTitle  
    integer(UINT)   :: ulFlags = BIF_RETURNONLYFSDIRS
    integer(UINT)   :: lpfn = NULL 
    integer(HANDLE) :: lParam = 0
    integer         :: iImage = 0
  end type t_browseinfo
  type(t_browseinfo) :: test

  interface
    integer function SHBrowseForFolder(t)
      !DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'SHBrowseForFolder' :: SHBrowseForFolder
      import
      integer(LPINT), intent(in) :: t
    end function SHBrowseForFolder

    integer function SHGetPathFromIDList(pidl, pszPath)
      !DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'SHGetPathFromIDList' :: SHGetPathFromIDList
      import
      integer(LPINT), intent(in) :: pidl
      integer(LPINT), intent(in) :: pszPath
    end function SHGetPathFromIDList

    integer function CoTaskMemFree(pv)
      !DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'CoTaskMemFree' :: CoTaskMemFree
      import
      integer(LPINT), intent(in) :: pv
    end function CoTaskMemFree
  end interface

  character(len = *), parameter :: msg = "Select a directory！"C
  character(len = 512) :: buff, path
  integer(LPINT) :: status
  integer(BOOL)  :: iret
! 
  test%lpszTitle = loc(msg)
  test%pszDisplayName = loc(buff)
  status = SHBrowseForFolder(loc(test))
!  print *, 'status=', status
  if (status /= 0) then
    iret = SHGetPathFromIDList(status, loc(path))
    print *, path(:index(path, ""C))
    print *, buff(:index(buff, ""C))
    iret = CoTaskMemFree(status)
  else
    print *, 'No directory was selected !!'
  end if  
end program selectFolder

Answer 1

这是您的程序的修改版本，可以满足您的需求。请注意添加了 BrowseCallbackFunction，它按照@Daniel Sęk 的建议发送 BFFM_SETSELECTION 消息。我没有添加对 MS 文档推荐的 ComInitialize 和 ComUnIntialize 的调用（我看到它们在 USE 中提到，但你没有调用它们。）

program selectFolder
  use ifwinty
  use ifcom, only: COMInitialize, COMUnInitialize
  implicit none
  integer, parameter :: BIF_RETURNONLYFSDIRS  = Z'00000001'
  integer, parameter :: BIF_DONTGOBELOWDOMAIN = Z'00000002'
  integer,parameter :: BIF_STATUSTEXT         = Z'00000004'
  integer,parameter :: BIF_RETURNFSANCESTORS  = Z'00000008'
  integer,parameter :: BIF_EDITBOX            = Z'00000010'
  integer,parameter :: BIF_VALIDATE           = Z'00000020'
  integer,parameter :: BIF_NEWDIALOGSTYLE     = Z'00000040'
  integer,parameter :: BIF_USENEWUI           = ior(BIF_NEWDIALOGSTYLE,BIF_EDITBOX)
  integer,parameter :: BIF_BROWSEINCLUDEURLS  = Z'00000080'
  integer,parameter :: BIF_UAHINT             = Z'00000100'
  integer,parameter :: BIF_NONEWFOLDERBUTTON  = Z'00000200'
  integer,parameter :: BIF_NOTRANSLATETARGETS = Z'00000400' 
  integer,parameter :: BIF_BROWSEFORCOMPUTER  = Z'00001000'
  integer,parameter :: BIF_BROWSEFORPRINTER   = Z'00002000'
  integer,parameter :: BIF_BROWSEINCLUDEFILES = Z'00004000'
  integer,parameter :: BIF_SHAREABLE          = Z'00008000'
  integer,parameter :: BFFM_INITIALIZED       = 1


  type, bind(C) :: t_browseinfo  
   ! sequence
    integer(HANDLE) :: hwndOwner = NULL
    integer(LPINT)  :: pidlRoot  = NULL
    integer(LPSTR)  :: pszDisplayName 
    integer(LPCSTR) :: lpszTitle  
    integer(UINT)   :: ulFlags = BIF_RETURNONLYFSDIRS
    integer(LPVOID)   :: lpfn = NULL 
    integer(HANDLE) :: lParam = 0
    integer         :: iImage = 0
  end type t_browseinfo
  type(t_browseinfo) :: test

  interface
    integer(LPINT) function SHBrowseForFolder(t)
      !DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'SHBrowseForFolder' :: SHBrowseForFolder
      import
      integer(LPINT), intent(in) :: t
    end function SHBrowseForFolder

    integer(BOOL) function SHGetPathFromIDList(pidl, pszPath)
      !DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'SHGetPathFromIDList' :: SHGetPathFromIDList
      import
      integer(LPINT), intent(in) :: pidl
      integer(LPINT), intent(in) :: pszPath
    end function SHGetPathFromIDList

    integer function CoTaskMemFree(pv)
      !DEC$ ATTRIBUTES DEFAULT, STDCALL, DECORATE, ALIAS:'CoTaskMemFree' :: CoTaskMemFree
      import
      integer(LPINT), intent(in) :: pv
    end function CoTaskMemFree
  end interface

  character(len = *), parameter :: msg = "Select a directory!"C
  character(len = 512) :: buff, path
  integer(LPINT) :: status
  integer(BOOL)  :: iret

  character(len = *), parameter :: initial_folder = "C:\\Windows"C
! 
  test%lpszTitle = loc(msg)
  test%pszDisplayName = loc(buff)
  test%lpfn = loc(BrowseCallbackProc)
  test%lparam = loc(initial_folder)
  status = SHBrowseForFolder(loc(test))
!  print *, 'status=', status
  if (status /= 0) then
    iret = SHGetPathFromIDList(status, loc(path))
    print *, path(:index(path, ""C))
    print *, buff(:index(buff, ""C))
    iret = CoTaskMemFree(status)
  else
    print *, 'No directory was selected !!'
  end if  

    contains

    function BrowseCallbackProc (hwnd,umsg,lparam,lpdata)
    use user32, only: SendMessage
    implicit none
    integer(UINT) :: BrowseCallbackProc
    !DEC$ ATTRIBUTES STDCALL :: BrowseCallbackProc
    integer(HANDLE), intent(in) :: hwnd
    integer(UINT), intent(in) :: umsg
    integer(fLPARAM), intent(in) :: lparam, lpdata

    ! message from browser
    integer, parameter :: BFFM_INITIALIZED        = 1
    integer, parameter :: BFFM_SELCHANGED         = 2
    integer, parameter :: BFFM_VALIDATEFAILEDA    = 3   ! lParam:szPath ret:1(cont),0(EndDialog)
    integer, parameter :: BFFM_VALIDATEFAILEDW    = 4   ! lParam:wzPath ret:1(cont),0(EndDialog)
    integer, parameter :: BFFM_IUNKNOWN           = 5   ! provides IUnknown to client. lParam: IUnknown*
    ! messages to browser
    integer, parameter :: BFFM_SETSTATUSTEXTA     = (WM_USER + 100)
    integer, parameter :: BFFM_ENABLEOK           = (WM_USER + 101)
    integer, parameter :: BFFM_SETSELECTIONA      = (WM_USER + 102)
    integer, parameter :: BFFM_SETSELECTIONW      = (WM_USER + 103)
    integer, parameter :: BFFM_SETSTATUSTEXTW     = (WM_USER + 104)
    integer, parameter :: BFFM_SETOKTEXT          = (WM_USER + 105) ! Unicode only
    integer, parameter :: BFFM_SETEXPANDED        = (WM_USER + 106) ! Unicode only

    integer(LRESULT) :: ret

    if (uMsg==BFFM_INITIALIZED) ret = SendMessage(hwnd, BFFM_SETSELECTIONA, TRUE, lpData)
    BrowseCallbackProc = 0
    end function BrowseCallbackProc

    end program selectFolder