Да и в стандарном контроле можно выделять несколько. Только флаги выставить надо.

API

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_ENABLEHOOK = &H20
Const OFN_ENABLETEMPLATE = &H40
Const OFN_ENABLETEMPLATEHANDLE = &H80
Const OFN_EXTENSIONDIFFERENT = &H400
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHAREAWARE = &H4000
Const OFN_SHOWHELP = &H10

Private 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

Sub Form_Load()
Dim filebox As OPENFILENAME
Dim fname As String
Dim retval As Long

filebox.lStructSize = Len(filebox)
filebox.hwndOwner = Me.hWnd
filebox.lpstrTitle = "Открываем файл..."
filebox.lpstrFilter = "Текст" & vbNullChar & "*.txt" & vbNullChar & "Все файлы" & vbNullChar & "*.*" & vbNullChar & vbNullChar
filebox.lpstrFile = Space(255)
filebox.nMaxFile = 255
filebox.lpstrFileTitle = Space(255)
filebox.nMaxFileTitle = 255
filebox.flags = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST

retval = GetOpenFileName(filebox)
If retval <> 0 Then
  fname = Left(filebox.lpstrFile, InStr(filebox.lpstrFile, vbNullChar) - 1)
  Debug.Print "Вы открыли файл: "; fname
End If
End Sub

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  ataBindingBehavior = 0  'vbNone
  ataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsDialog"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'General Declarations
Private Type BROWSEINFO  ' Folder Dialog
   hOwner           As Long
   pidlRoot         As Long
   pszDisplayName   As String
   lpszTitle        As String
   ulFlags          As Long
   lpfn             As Long
   lParam           As Long
   iImage           As Long
End Type
Private Type OPENFILENAME 'Open & Save Dialog
    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

Private Type CHOOSECOLOR 'Color Dialog
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    RGBResult As Long
    lpCustColors As String
    flags As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

Const LF_FACESIZE = 32 'Font Dialog
Private Type LOGFONT 'Font Dialog
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE) As Byte
End Type

Private Type ChooseFont 'Font Dialog
    lStructSize As Long
    hwndOwner As Long
    hDC As Long
    lpLogFont As Long
    iPointSize As Long
    flags As Long
    rgbColors As Long
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
    hInstance As Long
    lpszStyle As String
    nFontType As Integer
    MISSING_ALIGNMENT As Integer
    nSizeMin As Long
    nSizeMax As Long
End Type
' extra font constant
Const CF_INITTOLOGFONTSTRUCT = &H40&
Const SCREEN_FONTTYPE = &H2000
Const BOLD_FONTTYPE = &H100
Const FW_BOLD = 700

Private Type PrintDlg 'PrintDialog
    lStructSize As Long
    hwndOwner As Long
    hDevMode As Long
    hDevNames As Long
    hDC As Long
    flags As Long
    nFromPage As Integer
    nToPage As Integer
    nMinPage As Integer
    nMaxPage As Integer
    nCopies As Integer
    hInstance As Long
    lCustData As Long
    lpfnPrintHook As Long
    lpfnSetupHook As Long
    lpPrintTemplateName As String
    lpSetupTemplateName As String
    hPrintTemplate As Long
    hSetupTemplate As Long
End Type

Const CCHDEVICENAME = 32 'PrintDialog
Const CCHFORMNAME = 32 'PrintDialog
Private Type DEVMODE 'PrintDialog
    dmDeviceName As String * CCHDEVICENAME
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName As String * CCHFORMNAME
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type

Private Type DEVNAMES 'PrintDialog
    wDriverOffset As Integer
    wDeviceOffset As Integer
    wOutputOffset As Integer
    wDefault As Integer
    extra As String * 100
End Type
'extra printer constants - for Printer Dialog
Const DM_DUPLEX = &H1000&
Const DM_ORIENTATION = &H1&
' memory management constants - for Printer Dialog
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40


' ------------- Dialog calling functions
' -------------- Standard
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function ChooseColorAPI Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
Private Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As ChooseFont) As Long
Private Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PrintDlg) As Long
Private Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hOwner As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long
' ------------- Extended
Private Declare Function SHShutDownDialog Lib "shell32" Alias "#60" (ByVal YourGuess As Long) As Long
Private Declare Function SHRestartSystem Lib "shell32" Alias "#59" (ByVal hOwner As Long, ByVal sPrompt As String, ByVal uFlags As Long) As Long
Private Declare Function SHRunDialog Lib "shell32" Alias "#61" (ByVal hOwner As Long, ByVal hIcon As Long, ByVal sDir As Long, ByVal szTitle As String, ByVal szPrompt As String, ByVal uFlags As Long) As Long
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwndOwner As Long, ByVal iDrive As Long, ByVal iCapacity As Long, ByVal iFormatType As Long) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHChangeIconDialog Lib "shell32" Alias "#62" (ByVal hOwner As Long, ByVal szFilename As String, ByVal Reserved As Long, lpIconIndex As Long) As Long
'Private Declare Function SHFindFiles Lib "Shell32" Alias "#90" (ByVal pidlRoot As Long, ByVal pidlSavedSearchas As Long) As Boolean
Private Declare Function SHObjectProperties Lib "shell32" Alias "#178" (ByVal hOwner As Long, ByVal uFlags As Long, ByVal sName As String, ByVal sParam As String) As Long
'Private Declare Function GetFileNameFromBrowse Lib "shell32" Alias "#63" (ByVal hWndOwner As Long, ByVal sFile As String, ByVal nMaxFile As Long, ByVal sInitDir As String, ByVal sDefExt As String, ByVal sFilter As String, ByVal sTitle As String) As Boolean
Private Declare Function SHAbout Lib "shell32" Alias "ShellAboutA" (ByVal hOwner As Long, ByVal sAppName As String, ByVal sPrompt As String, ByVal hIcon As Long) As Long
' -------------- Extra functions for FolderDialog
Private Declare Function SHSimpleIDListFromPath Lib "shell32" Alias "#162" (ByVal szPath As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHFree Lib "shell32" Alias "#196" ()
Private Declare Function ILFree Lib "shell32" Alias "#195" (ByVal pidlFree As Long)
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
' -------------- Extra functions for IconDialog
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function CopyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Declare Function ExtractIconEx Lib "shell32" Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal nIconIndex As Long, phiconLarge As Long, phiconSmall As Long, ByVal nIcons As Long) As Long

' GDI functions
' For Font Dialog
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetTextFace Lib "gdi32" Alias "GetTextFaceA" (ByVal hDC As Long, ByVal nCount As Long, ByVal lpFacename As String) As Long
' For Font and Printer Dialog
Private Declare Function GetDC Lib "user32" (ByVal hOwner As Long) As Long

' user32 functions
'Private Declare Function GetActiveWindow Lib "user32" () As Long

' kernel32 functions
' For Font Dialog
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (p1 As Any, p2 As Any) As Long
' For Printer Dialog
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)


' common dialog action types
'Const ShowOpen = 1
'Const ShowSave = 2
'Const ShowColor = 3
'Const ShowFont = 4
'Const ShowPrinter = 5
'Const ShowHelp = 6

' --------------- Enum Flags
Public Enum CdlgExt_Flags
 ' Open & Save Dialog
 cdlOFNAllowMultiselect = &H200
 cdlOFNCreatePrompt = &H2000
 cdlOFNExplorer = &H80000
 cdlOFNExtensionDifferent = &H400
 cdlOFNFileMustExist = &H1000
 cdlOFNHelpButton = &H10
 cdlOFNHideReadOnly = &H4
 cdlOFNLongNames = &H200000
 cdlOFNNoChangeDir = &H8
 cdlOFNNoDereferenceLinks = &H100000
 cdlOFNNoLongNames = &H40000
 cdlOFNNoReadOnlyReturn = &H8000
 cdlOFNNoValidate = &H100
 cdlOFNOverwritePrompt = &H2
 cdlOFNPathMustExist = &H800
 cdlOFNReadOnly = &H1
 cdlOFNShareAware = &H4000
 'Color Dialog
 cdlCCFullOpen = &H2
 cdlCCHelpButton = &H8
 cdlCCPreventFullOpen = &H4
 cdlCCRGBInit = &H1
' Printer Dialog
 cdlPDAllPages = &H0
 cdlPDCollate = &H10
 cdlPDDisablePrintToFile = &H80000
 cdlPDHelpButton = &H800
 cdlPDHidePrintToFile = &H100000
 cdlPDNoPageNums = &H8
 cdlPDNoSelection = &H4
 cdlPDNoWarning = &H80
 cdlPDPageNums = &H2
 cdlPDPrintSetup = &H40
 cdlPDPrintToFile = &H20
 cdlPDReturnDC = &H100
 cdlPDReturnDefault = &H400
 cdlPDReturnIC = &H200
 cdlPDSelection = &H1
 cdlPDUseDevModeCopies = &H40000
' Font Dialog
 cdlCFANSIOnly = &H400
 cdlCFApply = &H200
 cdlCFBoth = &H3
 cdlCFEffects = &H100
 cdlCFFixedPitchOnly = &H4000
 cdlCFForceFontExist = &H10000
 cdlCFHelpButton = &H4
 cdlCFLimitSize = &H2000
 cdlCFNoFaceSel = &H80000
 cdlCFNoSimulations = &H1000
 cdlCFNoSizeSel = &H200000
 cdlCFNoStyleSel = &H100000
 cdlCFNoVectorFonts = &H800
 cdlCFPrinterFonts = &H2
 cdlCFScalableOnly = &H20000
 cdlCFScreenFonts = &H1
 cdlCFTTOnly = &H40000
 cdlCFWYSIWYG = &H8000
' Other Dialog
 'Restart Dialog
 Restart_Logoff = &H0
 Restart_ShutDown = &H1
 Restart_Reboot = &H2
 Restart_Force = &H4
 ' Run Dialog
 Run_NoBrowse = &H10
 Run_NoDefault = &H20
 Run_CalcDir = &H40
 Run_NoLable = &H80
 ' Properties Dialog
 ObjProp_Printer = &H100
 ObjProp_File = &H200
 ObjProp_System = &H400
 ObjProp_RecBin = &H700
 ObjProp_Screen = &H800
 ' Browse for Folder Dialog
 Folder_COMPUTER = &H1000
 Folder_PRINTER = &H2000
 Folder_INCLUDEFILES = &H4001
End Enum
'Enum Help Commands
Public Enum CdlgExt_HelpCommand
 HelpCommandHelp = &H102&
 HelpContents = &H3&
 HelpContext = &H1
 HelpContextPOPUP = &H8&
 HelpForceFile = &H9&
 HelpHelpOnHelp = &H4
 HelpIndex = &H3
 HelpKeyHelp = &H101
 HelpPartialKey = &H105&
 HelpQuit = &H2
 HelpSetContents = &H5&
 HelpSetIndex = &H5
 HelpMultiKey = &H201&
 HelpSetWinPos = &H203&
End Enum

Private RetValue As Long 'General
Const MAX_PATH = 260 'General
Private OFN As OPENFILENAME ' Open & Save Dialog

'Внутренние переменные для свойств:
Private mFileName As String
Private mFileTitle As String
Private mhOwner As Long
Private mDialogTitle As String
Private mFilter As String
Private mInitDir As String
Private mDefaultExt As String
Private mFilterIndex As Long
Private mHelpFile As String
Private mHelpCommand As CdlgExt_HelpCommand
Private mHelpKey As Long
Private mRGBResult As Long
Private mItalic As Boolean
Private mUnderline As Boolean
Private mStrikethru As Boolean
Private mFontName As String
Private mFontSize As Long
Private mBold As Boolean
Private mDialogPrompt As String
Private mFlags As CdlgExt_Flags
Private mCancelError As Boolean
Private mhIcon As Long
Private mAppName As String

' Let/Get Properties: General
Public Property Let CancelError(ByVal vData As Boolean)
   mCancelError = vData
End Property

Public Property Get CancelError() As Boolean
  CancelError = mCancelError
End Property

Public Property Get hOwner() As Long
    hOwner = mhOwner
End Property

Public Property Let hOwner(ByVal New_hOwner As Long)
    mhOwner = New_hOwner
End Property

Public Property Get flags() As CdlgExt_Flags
    flags = mFlags
End Property

Public Property Let flags(ByVal New_Flags As CdlgExt_Flags)
    mFlags = New_Flags
End Property

Public Property Get DialogTitle() As String
   ialogTitle = mDialogTitle
End Property

Public Property Let DialogTitle(sTitle As String)
   mDialogTitle = sTitle
End Property

Public Property Get DialogPrompt() As String
    ialogPrompt = mDialogPrompt
End Property

Public Property Let DialogPrompt(ByVal New_Prompt As String)
    mDialogPrompt = New_Prompt
End Property

Public Property Get AppName() As String
    AppName = mAppName
End Property

Public Property Let AppName(ByVal New_AppName As String)
    mAppName = New_AppName
End Property

Public Property Let hIcon(ByVal vData As Long)
    mhIcon = vData
End Property

Public Property Get hIcon() As Long
   hIcon = mhIcon
End Property

' Font Properties
Public Property Get Bold() As Boolean
  Bold = mBold
End Property

Public Property Let Bold(bBold As Boolean)
   mBold = bBold
End Property

Public Property Get FontName() As String
   FontName = mFontName
End Property

Public Property Let FontName(sName As String)
   mFontName = sName
End Property

Public Property Get FontSize() As Long
  FontSize = mFontSize
End Property

Public Property Let FontSize(lSize As Long)
   mFontSize = lSize
End Property

Public Property Get Italic() As Boolean
  Italic = mItalic
End Property

Public Property Let Italic(BItalic As Boolean)
   mItalic = BItalic
End Property

Public Property Get StrikeThru() As Boolean
   StrikeThru = mStrikethru
End Property

Public Property Let StrikeThru(bStrikethru As Boolean)
   mStrikethru = bStrikethru
End Property

Public Property Get Underline() As Boolean
   Underline = mUnderline
End Property

Public Property Let Underline(bUnderline As Boolean)
   mUnderline = bUnderline
End Property

' Open , Save, Folder, Icon

Public Property Get DefaultExt() As String
   efaultExt = mDefaultExt
End Property

Public Property Let DefaultExt(sDefExt As String)
   mDefaultExt = DefaultExt
End Property

Public Property Get FileName() As String
   FileName = mFileName
End Property

Public Property Let FileName(sFileName As String)
   mFileName = sFileName
End Property

Public Property Get FileTitle() As String
   FileTitle = mFileTitle
End Property

Public Property Let FileTitle(sTitle As String)
   mFileTitle = sTitle
End Property

Public Property Get Filter() As String
   Filter = mFilter
End Property

Public Property Let Filter(sFilter As String)
   mFilter = sFilter
End Property

Public Property Get FilterIndex() As Long
   FilterIndex = mFilterIndex
End Property

Public Property Let FilterIndex(lIndex As Long)
    mFilterIndex = lIndex
End Property

Public Property Get InitDir() As String
   InitDir = mInitDir
End Property

Public Property Let InitDir(sDir As String)
    mInitDir = sDir
End Property

' Help Properties
Public Property Get HelpCommand() As CdlgExt_HelpCommand
   HelpCommand = mHelpCommand
End Property

Public Property Let HelpCommand(lCommand As CdlgExt_HelpCommand)
   mHelpCommand = lCommand
End Property

Public Property Get HelpFile() As String
   HelpFile = mHelpFile
End Property

Public Property Let HelpFile(sFile As String)
   mHelpFile = sFile
End Property

Public Property Get HelpKey() As Long
   HelpKey = mHelpKey
End Property

Public Property Let HelpKey(sKey As Long)
   mHelpKey = sKey
End Property

'Color Dialog
Public Property Get RGBResult() As Long
   RGBResult = mRGBResult
End Property

Public Property Let RGBResult(lValue As Long)
   mRGBResult = lValue
End Property
' ShutDown Dialog
Public Function ShowShutDown()
   SHShutDownDialog mhOwner
End Function
' Restart Dialog
Public Function ShowRestart()
  Dim uFlag As Long
  uFlag = mFlags And (&H0 Or &H1 Or &H2 Or &H4)
  SHRestartSystem mhOwner, mDialogPrompt, uFlag
End Function
' Run Dialog
Public Function ShowRun(Optional ByVal hIcon As Long)
  Dim uFlag As Long
  uFlag = mFlags And (&H10 Or &H20 Or &H40 Or &H80)
  uFlag = uFlag / 16
  SHRunDialog mhOwner, mhIcon, 0, mDialogTitle, mDialogPrompt, uFlag
End Function
' FormatFloppy  ialog
Public Function ShowFormat(Optional ByVal iDrive As Long, Optional ByVal iCapacity As Long, Optional ByVal iFormatType As Long) As Long
  ShowFormat = SHFormatDrive(mhOwner, iDrive, iCapacity, iFormatType)
End Function

' SelectIcon Dialog
Public Function ShowIcon(Optional ByVal LargeIcon As Boolean)
   Dim nIconIdx As Long, OldFileName As String
   Dim hSmallIcon As Long, hLargeIcon As Long, NewIcon As Long
   If Right(mFileName, 1) = "\" Then Exit Function
   OldFileName = mFileName
   mFileName = mFileName & String$(MAX_PATH - Len(mFileName), 0) 'FileName  must be maximum lenth
   If SHChangeIconDialog(0, mFileName, 0, nIconIdx) Then
      If ExtractIconEx(mFileName, nIconIdx, hLargeIcon, hSmallIcon, 1) > 0 Then
         NewIcon = IIf(LargeIcon, hLargeIcon, hSmallIcon)
         mhIcon = CopyIcon(NewIcon)
         estroyIcon hSmallIcon
         estroyIcon hLargeIcon
      End If
   End If
   mFileName = OldFileName
End Function
'SelectFolder  ialog
Public Function ShowFolder(Optional ByVal TopFolder As String) As String
  Dim bi As BROWSEINFO
  Dim pidl As Long, path As String, pos As Integer, uFlag As Long
  TopFolder = TopFolder & Chr$(0)
  bi.hOwner = mhOwner
  bi.pidlRoot = SHSimpleIDListFromPath(TopFolder) 'Translate String (Path) to pointer (pidl)
  bi.lpszTitle = mDialogPrompt
  uFlag = mFlags And (&H1000 Or &H2000 Or &H4001)
  If uFlag < Folder_COMPUTER Then
     bi.ulFlags = &H1
  Else
     bi.ulFlags = uFlag
  End If
  pidl = SHBrowseForFolder(bi) ' Get pidl for selected folder
  path = String$(MAX_PATH, 0)
  ' translate pidl to Path
  If SHGetPathFromIDList(ByVal pidl, ByVal path) Then
     pos = InStr(path, Chr$(0))
     InitDir = Left(path, pos - 1)
  End If
  Call CoTaskMemFree(pidl) ' Free Memory
End Function

' ObjectProp  ialog
Public Function ShowObjectProp(Optional ByVal sObjectName As String, Optional ByVal sTab As String)
  Dim uFlag As Long, sObj As String
  Dim pidl As Long, sPath As String
  uFlag = mFlags And (&H100 Or &H200 Or &H400 Or &H700 Or &H800)
  uFlag = uFlag / 256
  Select Case uFlag
         Case 1, 2
              sObj = sObjectName 'File or Printer selected
         Case 7
              uFlag = 2
              sObj = "c:\recycled"
         Case 8
              uFlag = 0 'Screen Selected
              Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", vbNormalFocus)
         Case Else ' In all other cases show system properties
              uFlag = 2
              sObj = ""
  End Select
  If uFlag > 0 Then SHObjectProperties mhOwner, uFlag, sObj, sTab
End Function

'About Dialog
Public Function ShowAbout()
    If mAppName = "" Then mAppName = Chr$(0)
    SHAbout mhOwner, mAppName, mDialogPrompt, mhIcon
End Function
' Standard  ialogs
Public Sub ShowOpen()
  Dim iDelim As Integer
  InitOFN
  RetValue = GetOpenFileName(OFN)
  If RetValue > 0 Then
     iDelim = InStr(OFN.lpstrFileTitle, vbNullChar)
     If iDelim Then mFileTitle = Left$(OFN.lpstrFileTitle, iDelim - 1)
     iDelim = InStr(OFN.lpstrFile, vbNullChar)
     If iDelim Then mFileName = Left$(OFN.lpstrFile, iDelim - 1)
  Else
     If mCancelError Then Err.Raise 0
  End If
End Sub
Public Sub ShowSave()
  Dim iDelim As Integer
  InitOFN
  RetValue = GetSaveFileName(OFN)
  If RetValue > 0 Then
     iDelim = InStr(OFN.lpstrFileTitle, vbNullChar)
     If iDelim Then mFileTitle = Left$(OFN.lpstrFileTitle, iDelim - 1)
     iDelim = InStr(OFN.lpstrFile, vbNullChar)
     If iDelim Then mFileName = Left$(OFN.lpstrFile, iDelim - 1)
  Else
     If mCancelError Then Err.Raise 0
  End If
End Sub
Private Sub InitOFN()
  Dim sTemp As String, i As Integer
  Dim uFlag As Long
  uFlag = mFlags And (&H1 Or &H2 Or &H4 Or &H8 Or &H10 Or &H100 Or &H200 Or &H400 Or &H800 Or &H1000 Or &H2000 Or &H4000 Or &H8000 Or &H40000 Or &H80000 Or &H100000 Or &H200000)
  With OFN
       .lStructSize = Len(OFN)
       .hwndOwner = mhOwner
       .flags = uFlag
       .lpstrDefExt = mDefaultExt
       sTemp = mInitDir
       If sTemp = "" Then sTemp = App.path
       .lpstrInitialDir = sTemp
       sTemp = mFileName
       .lpstrFile = sTemp & String$(255 - Len(sTemp), 0)
       .nMaxFile = 255
       .lpstrFileTitle = String$(255, 0)
       .nMaxFileTitle = 255
        sTemp = mFilter
        For i = 1 To Len(sTemp)
            If Mid(sTemp, i, 1) = "|" Then
               Mid(sTemp, i, 1) = vbNullChar
            End If
        Next
        sTemp = sTemp & String$(2, 0)
        .lpstrFilter = sTemp
        .nFilterIndex = mFilterIndex
        .lpstrTitle = mDialogTitle
        .hInstance = App.hInstance
 End With
End Sub
Public Sub ShowHelp()
 mHelpKey = &H101
 RetValue = WinHelp(mhOwner, mHelpFile, mHelpCommand, mHelpKey)
End Sub
Public Sub ShowColor()
  Dim CC As CHOOSECOLOR
  Dim CustomColors() As Byte
  Dim uFlag As Long
  ReDim CustomColors(0 To 16 * 4 - 1) As Byte
  For i = LBound(CustomColors) To UBound(CustomColors)
     CustomColors(i) = 255 ' white
  Next i
  uFlag = mFlags And (&H1 Or &H2 Or &H4 Or &H8)
  With CC
       .lStructSize = Len(CC)
       .hwndOwner = mhOwner
       .hInstance = App.hInstance
       .lpCustColors = StrConv(CustomColors, vbUnicode)
       .flags = uFlag
       .RGBResult = mRGBResult
       RetValue = ChooseColorAPI(CC)
       If RetValue = 0 Then
          If mCancelError Then Err.Raise (RetValue)
       Else
          CustomColors = StrConv(.lpCustColors, vbFromUnicode)
          mRGBResult = .RGBResult
       End If
  End With
End Sub
Public Sub ShowFont()
  Dim CF As ChooseFont
  Dim LF As LOGFONT
  Dim TempByteArray() As Byte
  Dim ByteArrayLimit As Long
  Dim OldhDC As Long
  Dim FontToUse As Long
  Dim tbuf As String * 80
  Dim x As Long
  Dim uFlag As Long
  uFlag = mFlags And (&H1 Or &H2 Or &H3 Or &H4 Or &H100 Or &H200 Or &H400 Or &H800 Or &H1000 Or &H2000 Or &H4000 Or &H8000 Or &H10000 Or &H20000 Or &H40000 Or &H80000 Or &H100000 Or &H200000)
  TempByteArray = StrConv(mFontName & vbNullChar, vbFromUnicode)
  ByteArrayLimit = UBound(TempByteArray)
  With LF
     For x = 0 To ByteArrayLimit
        .lfFaceName(x) = TempByteArray(x)
     Next
    .lfHeight = mFontSize * 1.3
    .lfItalic = mItalic * -1
    .lfUnderline = mUnderline * -1
    .lfStrikeOut = mStrikethru * -1
    If mBold Then .lfWeight = FW_BOLD
  End With
  With CF
      .lStructSize = Len(CF)
      .hwndOwner = mhOwner
      .hDC = GetDC(mhOwner)
      .lpLogFont = lstrcpy(LF, LF)
      If Not uFlag Then
         .flags = cdlCFScreenFonts
      Else
         .flags = uFlag Or cdlCFWYSIWYG
      End If
     .flags = .flags Or cdlCFEffects Or CF_INITTOLOGFONTSTRUCT
     .rgbColors = mRGBResult
     .lCustData = 0
     .lpfnHook = 0
     .lpTemplateName = 0
     .hInstance = 0
     .lpszStyle = 0
     .nFontType = SCREEN_FONTTYPE
     .nSizeMin = 0
     .nSizeMax = 0
     .iPointSize = mFontSize * 10
    End With
    RetValue = ChooseFont(CF)
    If RetValue = 0 Then
       If mCancelError Then Err.Raise (RetValue)
    Else
       With LF
            mItalic = .lfItalic * -1
            mUnderline = .lfUnderline * -1
            mStrikethru = .lfStrikeOut * -1
       End With
       With CF
            mFontSize = .iPointSize \ 10
            mRGBResult = .rgbColors
            If .nFontType And BOLD_FONTTYPE Then
                mBold = True
            Else
                mBold = False
            End If
       End With
       FontToUse = CreateFontIndirect(LF)
       If FontToUse = 0 Then Exit Sub
          OldhDC = SelectObject(CF.hDC, FontToUse)
          RetValue = GetTextFace(CF.hDC, 79, tbuf)
          mFontName = Mid$(tbuf, 1, RetValue)
       End If
End Sub
Public Sub ShowPrinter()
  Dim PD As PrintDlg
  Dim DM As DEVMODE
  Dim DN As DEVNAMES
  Dim lpDevMode As Long, lpDevName As Long
  Dim objPrinter As Printer, NewPrinterName As String
  Dim strSetting As String
  Dim uFlag As Long
  uFlag = mFlags And (&H0 Or &H1 Or &H2 Or &H4 Or &H8 Or &H10 Or &H20 Or &H40 Or &H80 Or &H100 Or &H200 Or &H400 Or &H800 Or &H40000 Or &H80000 Or &H100000)
  ' Use PrintDialog to get the handle to a memory
  ' block with a DevMode and DevName structures
    With PD
      .lStructSize = Len(PD)
      .hwndOwner = mhOwner
      .hDC = GetDC(mhOwner)
      .flags = uFlag
    End With
  ' Set the current orientation and duplex setting
    On Error GoTo ErrorHandler
    With DM
        .dmDeviceName = Printer.DeviceName
        .dmSize = Len(DM)
        .dmFields = DM_ORIENTATION Or DM_DUPLEX
        .dmOrientation = Printer.Orientation
         On Error Resume Next
        .dmDuplex = Printer.Duplex
         On Error GoTo 0
    End With
  ' Allocate memory for the initialization hDevMode structure
  ' and copy the settings gathered above into this memory
    PD.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DM))
    lpDevMode = GlobalLock(PD.hDevMode)
    If lpDevMode > 0 Then
       CopyMemory ByVal lpDevMode, DM, Len(DM)
       RetValue = GlobalUnlock(lpDevMode)
    End If
  ' Set the current driver, device, and port name strings
    With DN
        .wDriverOffset = 8
        .wDeviceOffset = .wDriverOffset + 1 + Len(Printer.DriverName)
        .wOutputOffset = .wDeviceOffset + 1 + Len(Printer.Port)
        .wDefault = 0
    End With
    With Printer
         N.extra = .DriverName & vbNullChar & .DeviceName & vbNullChar & .Port & vbNullChar
    End With
  ' Allocate memory for the initial hDevName structure
  ' and copy the settings gathered above into this memory
    PD.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DN))
    lpDevName = GlobalLock(PD.hDevNames)
    If lpDevName > 0 Then
       CopyMemory ByVal lpDevName, DN, Len(DN)
       RetValue = GlobalUnlock(lpDevName)
    End If
  ' Call the print dialog up and let the user make changes
    RetValue = PrintDlg(PD)
    If RetValue = 0 Then
      If mCancelError Then Err.Raise (RetValue)
    Else
   ' get the DC for user API operations
       mhOwner = PD.hDC
   ' get the DevName structure.
       lpDevName = GlobalLock(PD.hDevNames)
       CopyMemory DN, ByVal lpDevName, 45
       RetValue = GlobalUnlock(lpDevName)
       GlobalFree PD.hDevNames
   ' Next get the DevMode structure and set the printer
   ' properties appropriately
       lpDevMode = GlobalLock(PD.hDevMode)
       CopyMemory DM, ByVal lpDevMode, Len(DM)
       RetValue = GlobalUnlock(PD.hDevMode)
       GlobalFree PD.hDevMode
       NewPrinterName = UCase$(Left(DM.dmDeviceName, InStr(DM.dmDeviceName, vbNullChar) - 1))
       If Printer.DeviceName <> NewPrinterName Then
          For Each objPrinter In Printers
              If UCase$(objPrinter.DeviceName) = NewPrinterName Then
                 Set Printer = objPrinter
               End If
          Next
       End If
       On Error Resume Next
     ' Set printer object properties according to selections made
     ' by user
       With Printer
           .Copies = DM.dmCopies
           .Duplex = DM.dmDuplex
           .Orientation = DM.dmOrientation
       End With
       On Error GoTo 0
    End If
ExitSub:
    Exit Sub
ErrorHandler:
    MsgBox Err.Description, vbExclamation, "Printer Error"
    Resume ExitSub
End Sub

' Использование: Private dlg As New clsDialog

Только проект, когда отображается диалог завершить нельзя

Arseny, это жесть, я преклоняюсь перед людьми у которых хватает терпения столько написать