Question

我的Google-Fu今天很弱，希望这很简单。

我需要将VB6 CommonDialog控件的InitDir属性设置为从[My] Computer开始。如果我将InitDir设置为空字符串，它只是默认为上一个打开的对话框中的当前目录。

我的代码：

With MyCommonDialogControl
    .DialogTitle = "Choose Import File"
    .Filter = "Import Files|*.dbf"
    .InitDir = Environ("HOMEDRIVE") //Needs to be "My Computer"
    .CancelError = False
    .ShowOpen
    If Len(.Filename) = 0 Then Exit Sub
    InputFile = .Filename
End With

提前感谢您的任何帮助。

Answer 1

我遇到过几种方法 - 一种是通过Environ方法，它似乎在VB6和VBA中都有效 - 尽管我从未使用过这种方法，另一种是通过p / Invoke引用： shell32.dll中的SHGetSpecialFolderLocation和SHGetPathFromIDList。

我手边没有代码，所以我从其他网站http://en.kioskea.net/faq/sujet-951-vba-vb6-my-documents-environment-variables

复制并粘贴了

我无法保证正确性，但它看起来与我过去使用的代码非常相似，所以它应该以最少的调试工作......无论如何，至少它指向正确的方向。

Option Explicit
Private Type SHITEMID
    cb As Long
    abID As Byte
End Type
Private Type ITEMIDLIST
    mkid As SHITEMID
End Type
Private Const CSIDL_PERSONAL As Long = &H5
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _
                        (ByVal hwndOwner As Long, ByVal nFolder As Long, _
                         pidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
                        (ByVal pidl As Long, ByVal pszPath As String) As Long


Public Function Rep_Documents() As String
    Dim lRet As Long, IDL As ITEMIDLIST, sPath As String
    lRet = SHGetSpecialFolderLocation(100&, CSIDL_PERSONAL, IDL)
    If lRet = 0 Then
        sPath = String$(512, Chr$(0))
        lRet = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath)
        Rep_Documents = Left$(sPath, InStr(sPath, Chr$(0)) - 1)
    Else
        Rep_Documents = vbNullString
    End If
End Function

引用Rep_Documents（）将为您提供一个字符串，其中包含My Documents文件夹的路径名。这只是将它分配给文件对话框的InitDir属性的一种情况。

Answer 2

问题是我的电脑是virtual folder，它没有等效的物理目录路径。 Googling出现在下面，这在Windows XP上适用于我。

  CommonDialog1.InitDir = "::{20D04FE0-3AEA-1069-A2D8-08002B30309D}"
  CommonDialog1.ShowOpen

Apparently这是使用CLSID作为“我的电脑”命名空间。有谁可以解释这个东西吗？我只是发布了我并不理解的谷歌搜索结果：）

Answer 3

当天，一群程序员创建了现已解散的CCRP项目。但是，在免费下载中，他们有扩展文件对话框OCX / DLL，它可以为您提供所需的内容，以及更多内容。

http://ccrp.mvps.org/index.html?http://ccrp.mvps.org/download/ccrpdownloads.htm

Answer 4

效果很好，谢谢！（WinXP SP3）

Option Explicit '

    Private getdir As String
    '

    '

    Private Sub Command1_Click()

      Dim strFilter As String
    Dim lngFlags As Long
    strFilter = thAddFilterItem(strFilter, "Excel Files (*.xls)", "*.XLS")
    'strFilter = thAddFilterItem(strFilter, "Text Files(*.txt)", "*.TXT")
    'strFilter = thAddFilterItem(strFilter, "All Files (*.*)", "*.*")
 ' MsgBox thCommonFileOpenSave(InitialDir:=App.Path, Filter:=strFilter, FilterIndex:=3, Flags:=lngFlags, DialogTitle:="File Browser")
   MsgBox thCommonFileOpenSave(InitialDir:="::{20D04FE0-3AEA-1069-A2D8-08002B30309D}", Filter:=strFilter, FilterIndex:=3, Flags:=lngFlags, DialogTitle:="File Browser")

   Debug.Print Hex(lngFlags)
End Sub

Option Explicit

Type thOPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    strFilter As String
    strCustomFilter As String
    nMaxCustFilter As String
    nFilterIndex As Long
    strFile As String
    nMaxFile As Long
    strFileTitle As String
    nMaxFileTitle As Long
    strInitialDir As String
    strTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    strDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

Declare Function th_apiGetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (OFN As thOPENFILENAME) As Boolean
Declare Function th_apiGetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (OFN As thOPENFILENAME) As Boolean
Declare Function CommDlgExtendetError Lib "commdlg32.dll" () As Long

Private Const thOFN_READONLY = &H1
Private Const thOFN_OVERWRITEPROMPT = &H2
Private Const thOFN_HIDEREADONLY = &H4
Private Const thOFN_NOCHANGEDIR = &H8
Private Const thOFN_SHOWHELP = &H10
Private Const thOFN_NOVALIDATE = &H100
Private Const thOFN_ALLOWMULTISELECT = &H200
Private Const thOFN_EXTENSIONDIFFERENT = &H400
Private Const thOFN_PATHMUSTEXIST = &H800
Private Const thOFN_FILEMUSTEXIST = &H1000
Private Const thOFN_CREATEPROMPT = &H2000
Private Const thOFN_SHAREWARE = &H4000
Private Const thOFN_NOREADONLYRETURN = &H8000
Private Const thOFN_NOTESTFILECREATE = &H10000
Private Const thOFN_NONETWORKBUTTON = &H20000
Private Const thOFN_NOLONGGAMES = &H40000
Private Const thOFN_EXPLORER = &H80000
Private Const thOFN_NODEREFERENCELINKS = &H100000
Private Const thOFN_LONGNAMES = &H200000

Function StartIt()
    Dim strFilter As String
    Dim lngFlags As Long
    strFilter = thAddFilterItem(strFilter, "Excel Files (*.xls)", "*.XLS")
    strFilter = thAddFilterItem(strFilter, "Text Files(*.txt)", "*.TXT")
    strFilter = thAddFilterItem(strFilter, "All Files (*.*)", "*.*")
    Startform.filenameinput.Value = thCommonFileOpenSave(InitialDir:="x:\Anlagen_PG80", Filter:=strFilter, FilterIndex:=3, Flags:=lngFlags, DialogTitle:="File Browser")
    Debug.Print Hex(lngFlags)
End Function

Function GetOpenFile(Optional varDirectory As Variant, Optional varTitleForDialog As Variant) As Variant
    Dim strFilter As String
    Dim lngFlags As Long
    Dim varFileName As Variant
    lngFlags = thOFN_FILEMUSTEXIST Or thOFN_HIDEREADONLY Or thOFN_NOCHANGEDIR

    If IsMissing(varDirectory) Then varDirectory = ""
    End If

    If IsMissing(varTitleForDialog) Then varTitleForDialog = ""
    End If

    strFilter = thAddFilterItem(strFilter, "Excel (*.xls)", "*.XLS")
    varFileName = thCommonFileOpenSave(OpenFile:=True, InitialDir:=varDirectory, Filter:=strFilter, Flags:=lngFlags, DialogTitle:=varTitleForDialog)

    If Not IsNull(varFileName) Then varFileName = TrimNull(varFileName)
    End If

    GetOpenFile = varFileName

End Function

Function thCommonFileOpenSave(Optional ByRef Flags As Variant, Optional ByVal InitialDir As Variant, Optional ByVal Filter As Variant, _
                               Optional ByVal FilterIndex As Variant, Optional ByVal DefaultEx As Variant, Optional ByVal fileName As Variant, _
                               Optional ByVal DialogTitle As Variant, Optional ByVal hwnd As Variant, Optional ByVal OpenFile As Variant) As Variant

    Dim OFN As thOPENFILENAME
    Dim strFileName As String
    Dim FileTitle As String
    Dim fResult As Boolean

    If IsMissing(InitialDir) Then InitialDir = CurDir
    If IsMissing(Filter) Then Filter = ""
    If IsMissing(FilterIndex) Then FilterIndex = 1
    If IsMissing(Flags) Then Flags = 0&
    If IsMissing(DefaultEx) Then DefaultEx = ""
    If IsMissing(fileName) Then fileName = ""
    If IsMissing(DialogTitle) Then DialogTitle = ""
    If IsMissing(hwnd) Then hwnd = 0
    If IsMissing(OpenFile) Then OpenFile = True

    strFileName = Left(fileName & String(256, 0), 256)
    FileTitle = String(256, 0)

    With OFN
        .lStructSize = Len(OFN)
        .hwndOwner = hwnd
        .strFilter = Filter
        .nFilterIndex = FilterIndex
        .strFile = strFileName
        .nMaxFile = Len(strFileName)
        .strFileTitle = FileTitle
        .nMaxFileTitle = Len(FileTitle)
        .strTitle = DialogTitle
        .Flags = Flags
        .strDefExt = DefaultEx
        .strInitialDir = InitialDir
        .hInstance = 0
        .lpfnHook = 0
        .strCustomFilter = String(255, 0)
        .nMaxCustFilter = 255
    End With

    If OpenFile Then fResult = th_apiGetOpenFileName(OFN) Else fResult = th_apiGetSaveFileName(OFN)


    If fResult Then
        If Not IsMissing(Flags) Then Flags = OFN.Flags
        thCommonFileOpenSave = TrimNull(OFN.strFile)
        Else
        thCommonFileOpenSave = vbNullString
    End If

End Function

Function thAddFilterItem(strFilter As String, strDescription As String, Optional varItem As Variant) As String

    If IsMissing(varItem) Then varItem = "*.*"
    thAddFilterItem = strFilter & strDescription & vbNullChar & varItem & vbNullChar

End Function

Private Function TrimNull(ByVal strItem As String) As String
    Dim intPos As Integer
    intPos = InStr(strItem, vbNullChar)
    If intPos > 0 Then
        TrimNull = Left(strItem, intPos - 1)
        Else
        TrimNull = strItem
    End If

End Function

如何将CommonDialog控件的InitDir属性设置为“我的电脑”

4 个答案: