明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 495|回复: 3

64位VBA打开文件对话框

  [复制链接]
发表于 2023-3-22 10:46 | 显示全部楼层 |阅读模式
感谢作者
出处:http://www.cnblogs.com/liweis/

Option Explicit

Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long

Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidList As LongPtr, ByVal lpBuffer As String) As Long

Private Declare PtrSafe Function SendMessageA Lib "user32" (ByVal Hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr

Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As LongPtr)

Private Const BIF_RETURNONLYFSDIRS As Long = 1
Private Const CSIDL_DRIVES As Long = &H11
Private Const WM_USER As Long = &H400
Private Const MAX_PATH As Long = 260            '// message from browser
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SELCHANGED As Long = 2
Private Const BFFM_VALIDATEFAILEDA As Long = 3  '// lParam:szPath ret:1(cont),0(EndDialog)
Private Const BFFM_VALIDATEFAILEDW As Long = 4  '// lParam:wzPath ret:1(cont),0(EndDialog)
Private Const BFFM_IUNKNOWN As Long = 5         '// provides IUnknown to client. lParam: IUnknown*
'// messages to browser
Private Const BFFM_SETSTATUSTEXTA As Long = WM_USER + 100
Private Const BFFM_ENABLEOK As Long = WM_USER + 101
Private Const BFFM_SETSELECTIONA As Long = WM_USER + 102
Private Const BFFM_SETSELECTIONW As Long = WM_USER + 103
Private Const BFFM_SETSTATUSTEXTW As Long = WM_USER + 104
Private Const BFFM_SETOKTEXT As Long = WM_USER + 105 '// Unicode only
Private Const BFFM_SETEXPANDED As Long = WM_USER + 106 '// Unicode only

Private Const OFN_ALLOWMULTISELECT As Long = &H200
Private Const OFN_CREATEPROMPT As Long = &H2000
Private Const OFN_ENABLEHOOK As Long = &H20
Private Const OFN_ENABLETEMPLATE As Long = &H40
Private Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
Private Const OFN_EXPLORER As Long = &H80000
Private Const OFN_EXTENSIONDIFFERENT As Long = &H400
Private Const OFN_FILEMUSTEXIST As Long = &H1000
Private Const OFN_HIDEREADONLY As Long = &H4
Private Const OFN_LONGNAMES As Long = &H200000
Private Const OFN_NOCHANGEDIR As Long = &H8
Private Const OFN_NODEREFERENCELINKS As Long = &H100000
Private Const OFN_NOLONGNAMES As Long = &H40000
Private Const OFN_NONETWORKBUTTON As Long = &H20000
Private Const OFN_NOREADONLYRETURN As Long = &H8000& '*see comments
Private Const OFN_NOTESTFILECREATE As Long = &H10000
Private Const OFN_NOVALIDATE As Long = &H100
Private Const OFN_OVERWRITEPROMPT As Long = &H2
Private Const OFN_PATHMUSTEXIST As Long = &H800
Private Const OFN_READONLY As Long = &H1
Private Const OFN_SHAREAWARE As Long = &H4000
Private Const OFN_SHAREFALLTHROUGH As Long = 2
Private Const OFN_SHAREWARN As Long = 0
Private Const OFN_SHARENOWARN As Long = 1
Private Const OFN_SHOWHELP As Long = &H10
Private Const OFN_ENABLESIZING As Long = &H800000
Private Const OFS_MAXPATHNAME As Long = 260

'OFS_FILE_OPEN_FLAGS:
Private Const OFS_FILE_OPEN_FLAGS = OFN_EXPLORER Or _
             OFN_LONGNAMES Or _
             OFN_CREATEPROMPT Or _
             OFN_NODEREFERENCELINKS

Private Type OPENFILENAME
    lStructSize As Long
    hWndOwner As LongPtr
    hInstance As LongPtr
    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 LongPtr
    lpTemplateName As String
End Type

Private Type BrowseInfo
    hWndOwner As LongPtr
    pIDLRoot As LongPtr
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfnCallback As LongPtr
    lParam As LongPtr
    iImage As Long
End Type

'====== File Browsers for 64 bit VBA 7 ========

'选择文件
Public Function FileBrowseOpen(ByVal sInitFolder As String, ByVal sTitle As String, ByVal sFilter As String, ByVal nFilterIndex As Integer, Optional ByVal multiSelect = False) As String

    Dim OpenFile As OPENFILENAME
    Dim lReturn As Long

    sInitFolder = CorrectPath(sInitFolder)
    OpenFile.lpstrInitialDir = sInitFolder

    ' Swap filter separator for api separator
    sFilter = Replace(sFilter, "|", VBA.Chr(0))

    OpenFile.lpstrFilter = sFilter
    OpenFile.nFilterIndex = nFilterIndex
    OpenFile.lpstrTitle = sTitle



    OpenFile.hWndOwner = 0
    OpenFile.lpstrFile = VBA.String(257, 0)
    OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
    OpenFile.lStructSize = LenB(OpenFile)

    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile

    If Not multiSelect Then
        OpenFile.flags = 0
    Else
        OpenFile.flags = OFS_FILE_OPEN_FLAGS + OFN_ALLOWMULTISELECT
    End If

    lReturn = GetOpenFileName(OpenFile)

    Dim result As String
    If lReturn = 0 Then
        FileBrowseOpen = ""
    Else
        If multiSelect Then
            Dim str As String
            str = VBA.Trim(Replace(VBA.Trim(OpenFile.lpstrFile), vbNullChar, ","))
            Dim ed As String
            ed = VBA.Mid(str, Len(str))
            While (ed = ",")
                str = VBA.Trim(VBA.Left(str, Len(str) - 1))
                ed = VBA.Mid(str, VBA.Len(str))
            Wend
            FileBrowseOpen = str
        Else
            FileBrowseOpen = VBA.Trim(VBA.Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
        End If
    End If
End Function

'获取文件列表
Public Function GetFiles( _
    ByVal sInitFolder As String, _
    ByVal sTitle As String, _
    ByVal sFilter As String, _
    ByVal nFilterIndex As Integer) As String()

    Dim strReturn As String

    strReturn = FileBrowseOpen(sInitFolder, sTitle, sFilter, nFilterIndex, True)
    GetFiles = Split(strReturn, ",")

End Function
'保存文件
Public Function FileBrowseSave(ByVal sDefaultFilename As String, ByVal sInitFolder As String, ByVal sTitle As String, ByVal sFilter As String, ByVal nFilterIndex As Integer, Optional ByVal overwritePrompt = False) As String

    Dim PadCount As Integer
    Dim OpenFile As OPENFILENAME
    Dim lReturn As Long

    sInitFolder = CorrectPath(sInitFolder)

    ' Swap filter separator for api separator
    sFilter = Replace(sFilter, "|", Chr(0))

    OpenFile.lpstrFilter = sFilter
    OpenFile.nFilterIndex = 1
    OpenFile.hWndOwner = 0

    PadCount = 260 - Len(sDefaultFilename)
    OpenFile.lpstrFile = sDefaultFilename & String(PadCount, Chr(0))
    'OpenFile.lpstrFile = String(257, 0)
    OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
    OpenFile.lStructSize = LenB(OpenFile)

    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile
    OpenFile.lpstrInitialDir = sInitFolder
    OpenFile.lpstrTitle = sTitle
    If Not IsMissing(overwritePrompt) And overwritePrompt Then
        OpenFile.flags = OFN_OVERWRITEPROMPT
    Else
        OpenFile.flags = 0
    End If
    lReturn = GetSaveFileName(OpenFile)

    If lReturn = 0 Then
        FileBrowseSave = ""
    Else
        FileBrowseSave = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
    End If

End Function

Private Function CorrectPath(ByVal sPath As String) As String
    If VBA.Right$(sPath, 1) = "\" Then
        If Len(sPath) > 3 Then sPath = VBA.Left$(sPath, Len(sPath) - 1) ' Strip backslash from non-root
    Else
        If Len(sPath) = 2 Then sPath = sPath & "\" ' Append backslash to root
    End If
    CorrectPath = sPath
End Function

'文件夹是否存在
Public Function FolderExists(ByVal sFolderName As String) As Boolean
    Dim att As Long
    On Error Resume Next
    att = GetAttr(sFolderName)
    If Err.Number = 0 Then
    FolderExists = True
    Else
    Err.Clear
    FolderExists = False
    End If
    On Error GoTo 0
End Function


发表于 2023-3-22 11:55 | 显示全部楼层
看不懂
学习学习
发表于 2023-3-23 11:46 | 显示全部楼层
用的API的,代码确实有点繁琐。桌子就没给vba留个接口。
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-28 17:36 , Processed in 0.161080 second(s), 22 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表