VBA 中有没有公共对话框？

Question

如题。

Answer 1

API版的：
'调用系统“浏览文件夹”对话框的模块，并可选择起始路径
Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
    ByVal hWnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As String) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" ( _
    ByVal pidl As Long, _
    ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" ( _
    lpBrowseInfo As BROWSEINFO) As Long
Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type
Dim xStartPath As StringFunction SelectDir(Optional StartPath As String, _
                   Optional Titel As String) As String
    Dim iBROWSEINFO As BROWSEINFO
    With iBROWSEINFO
        .lpszTitle = IIf(Len(Titel), Titel, "【请选择文件夹】")
        .ulFlags = 7
        If Len(StartPath) Then
        xStartPath = StartPath & vbNullChar
        .lpfnCallback = GetAddressOf(AddressOf CallBack)
        End If
    End With
    Dim xPath As String, NoErr As Long: xPath = Space$(512)
    NoErr = SHGetPathFromIDList(SHBrowseForFolder(iBROWSEINFO), xPath)
    SelectDir = IIf(NoErr, Left$(xPath, InStr(xPath, Chr(0)) - 1), "")
End FunctionFunction GetAddressOf(Address As Long) As Long
    GetAddressOf = Address
End FunctionFunction CallBack(ByVal hWnd As Long, _
                  ByVal Msg As Long, _
                  ByVal pidl As Long, _
                  ByVal pData As Long) As Long
    Select Case Msg
        Case 1
            Call SendMessage(hWnd, 1126, 1, xStartPath)
        Case 2
            Dim sDir As String * 64, tmp As Long
            tmp = SHGetPathFromIDList(pidl, sDir)
            If tmp = 1 Then SendMessage hWnd, 1124, 0, sDir
    End Select
End Function

Answer 2

高。
开心。
谢谢　dongge2000(秋日私语：非[版务].灌！) 。再帮帮，好吗？
打开、颜色、字体对话框又如何？本帖已增至40分，会不会少了点？

Answer 3

计有文件打开/存盘话框，字体对话框，打印机对话框，颜色对话框.做法： 
加一个FORM1，在FORM1理放5个按钮名字为command1到5 
再加上下列代码 Option Explicit 
Private Sub Command1_Click() 
Dim sOpen As SelectedFile 
Dim Count As Integer 
Dim FileList As StringOn Error GoTo e_Trap FileDialog.sFilter = "Text Files (*.txt)" & Chr$(0) & "*.sky" & Chr$(0
) & "All Files (*.*)" & Chr$(0) & "*.*" ' See Standard CommonDialog Flags for all options 
FileDialog.flags = OFN_EXPLORER Or OFN_LONGNAMES Or OFN_HIDEREADONLY O
r OFN_ALLOWMULTISELECT 
FileDialog.sDlgTitle = "Show Open" 
FileDialog.sInitDir = App.Path & "\" 
sOpen = ShowOpen(Me.hWnd) 
If Err.Number <> 32755 And sOpen.bCanceled = False Then 
FileList = "Directory : " & sOpen.sLastDirectory & vbCr 
For Count = 1 To sOpen.nFilesSelected 
FileList = FileList & sOpen.sFiles(Count) & vbCr 
Next Count 
Call MsgBox(FileList, vbOKOnly + vbInformation, "Show Open Selected") End If 
Exit Sub 
e_Trap: 
Exit Sub 
Resume 
End Sub 

Answer 4

续上：
Private Sub Command2_Click() 
Dim sSave As SelectedFile 
Dim Count As Integer 
Dim FileList As String 
On Error GoTo e_Trap FileDialog.sFilter = "Text Files (*.txt)" & Chr$(0) & "*.sky" & Chr$(0
) & "All Files (*.*)" & Chr$(0) & "*.*" ' See Standard CommonDialog Flags for all options 
FileDialog.flags = OFN_HIDEREADONLY 
FileDialog.sDlgTitle = "Show Save" 
FileDialog.sInitDir = App.Path & "\" 
sSave = ShowSave(Me.hWnd) 
If Err.Number <> 32755 And sSave.bCanceled = False Then 
FileList = "Directory : " & sSave.sLastDirectory & vbCr 
For Count = 1 To sSave.nFilesSelected 
FileList = FileList & sSave.sFiles(Count) & vbCr 
Next Count 
Call MsgBox(FileList, vbOKOnly + vbInformation, "Show Save Selected") End If 
Exit Sub 
e_Trap: 
Exit Sub 
Resume 
End Sub 

Answer 5

续上：
Private Sub Command3_Click() 
Dim sFont As SelectedFont 
On Error GoTo e_Trap 
FontDialog.iPointSize = 12 * 10 
sFont = ShowFont(Me.hWnd, "Times New Roman") 
Exit Sub 
e_Trap: 
Exit Sub 
End Sub 
Private Sub Command4_Click() 
On Error GoTo e_Trap 
Call ShowPrinter(Me.hWnd) 
Exit Sub 
e_Trap: 
Exit Sub 
End Sub 
Private Sub Command5_Click() 
Dim sColor As SelectedColor 
On Error GoTo e_Trap 
sColor = ShowColor(Me.hWnd) 
Exit Sub 
e_Trap: 
Exit Sub 
End Sub ========================================== 

Answer 6

楼上的代码得引用：“部件-Microsoft Common Dialog Control 6.0”

Answer 7

To : creazyfish(梳分头的鱼) 
谢谢。能不能帮我测试，在 VBA For PowerPoint 中如何打开这些对话框？

Answer 8

公共对话框控件：
Microsoft Common Dialog Control 6.0好用，易用。