Re: COMDLG32.ocx: Open/Save-Dialog

Hallo vielleicht hilft dir diese API-Implementation

Private Declare Function GetOpenFileName Lib "COMDLG32" Alias "GetOpenFileNameA" (file As OPENFILENAME) As Long
Private Declare Function CommDlgExtendedError Lib "COMDLG32" () As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function ChooseColor Lib "COMDLG32.DLL" Alias "ChooseColorA" (COLOR As TCHOOSECOLOR) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Type OPENFILENAME
lStructSize As Long ' Filled with UDT size
hWndOwner As Long ' Tied to Owner
hInstance As Long ' Ignored (used only by templates)
lpstrFilter As String ' Tied to Filter
lpstrCustomFilter As String ' Ignored (exercise for reader)
nMaxCustFilter As Long ' Ignored (exercise for reader)
nFilterIndex As Long ' Tied to FilterIndex
lpstrFile As String ' Tied to FileName
nMaxFile As Long ' Handled internally
lpstrFileTitle As String ' Tied to FileTitle
nMaxFileTitle As Long ' Handled internally
lpstrInitialDir As String ' Tied to InitDir
lpstrTitle As String ' Tied to DlgTitle
flags As Long ' Tied to Flags
nFileOffset As Integer ' Ignored (exercise for reader)
nFileExtension As Integer ' Ignored (exercise for reader)
lpstrDefExt As String ' Tied to DefaultExt
lCustData As Long ' Ignored (needed for hooks)
lpfnHook As Long ' Ignored (good luck with hooks)
lpTemplateName As Long ' Ignored (good luck with templates)
End Type

Private Enum EOpenFile
OFN_READONLY = &H1
OFN_HIDEREADONLY = &H4
OFN_ENABLEHOOK = &H20
OFN_ENABLETEMPLATE = &H40
OFN_ALLOWMULTISELECT = &H200
OFN_FILEMUSTEXIST = &H1000
'OFN_OVERWRITEPROMPT = &H2
'OFN_NOCHANGEDIR = &H8
'OFN_SHOWHELP = &H10
'OFN_ENABLETEMPLATEHANDLE = &H80
'OFN_NOVALIDATE = &H100
'OFN_EXTENSIONDIFFERENT = &H400
'OFN_PATHMUSTEXIST = &H800
'OFN_CREATEPROMPT = &H2000
'OFN_SHAREAWARE = &H4000
'OFN_NOREADONLYRETURN = &H8000
'OFN_NOTESTFILECREATE = &H10000
'OFN_NONETWORKBUTTON = &H20000
'OFN_NOLONGNAMES = &H40000
'OFN_EXPLORER = &H80000
'OFN_NODEREFERENCELINKS = &H100000
'OFN_LONGNAMES = &H200000
End Enum

Private Enum EChooseColor
CC_RGBInit = &H1
CC_FullOpen = &H2
CC_PreventFullOpen = &H4
CC_ENABLEHOOK = &H10
CC_ENABLETEMPLATE = &H20
'CC_ColorShowHelp = &H8
'CC_EnableTemplateHandle = &H40
' Win95 only
CC_SolidColor = &H80
CC_AnyColor = &H100
' End Win95 only
End Enum

Private Type TCHOOSECOLOR
lStructSize As Long
hWndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As Long
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
End Type

Private Const MAX_PATH = 260

Private m_lApiReturn As Long
Private m_lExtendedError As Long

' Array of custom colors lasts for life of app
Private alCustom(0 To 15) As Long
Private m_bNotFirst As Boolean
Option Explicit

Public Function VBGetOpenFileName(Filename$, Optional FileTitle$, Optional FileMustExist As Boolean = True, _
Optional MultiSelect As Boolean = False, Optional ReadOnly As Boolean = False, _
Optional HideReadOnly As Boolean = False, Optional Filter$ = "All (*.*)| *.*", _
Optional FilterIndex& = 1, Optional InitDir$, Optional DlgTitle$, _
Optional DefaultExt$, Optional Owner& = -1, Optional flags& = 0) As Boolean

Dim opfile As OPENFILENAME, i&, afFlags&, lMax&, ch$, s$

m_lApiReturn = 0: m_lExtendedError = 0

With opfile
.lStructSize = Len(opfile)
' Add in specific flags and strip out non-VB flags
.flags = (-FileMustExist * OFN_FILEMUSTEXIST) Or (-MultiSelect * OFN_ALLOWMULTISELECT) Or _
(-ReadOnly * OFN_READONLY) Or (-HideReadOnly * OFN_HIDEREADONLY) Or _
(flags And CLng(Not (OFN_ENABLEHOOK Or OFN_ENABLETEMPLATE)))

If Owner -1 Then .hWndOwner = Owner 'Owner can take handle of owning window
.lpstrInitialDir = InitDir 'InitDir can take initial directory string
.lpstrDefExt = DefaultExt 'DefaultExt can take default extension
.lpstrTitle = DlgTitle 'DlgTitle can take dialog box title
'To make Windows-style filter, replace | and : with nulls
For i = 1 To Len(Filter)
ch = Mid$(Filter, i, 1)
If ch = "|" Or ch = ":" Then s = s & vbNullChar Else s = s & ch
Next i
s = s & vbNullChar & vbNullChar 'Put double null at end
.lpstrFilter = s: .nFilterIndex = FilterIndex
lMax = MAX_PATH 'Pad file and file title buffers to maximum path
If (.flags And OFN_ALLOWMULTISELECT) = OFN_ALLOWMULTISELECT Then lMax = 8192
s = Filename & String$(lMax - Len(Filename), 0)
.lpstrFile = s
.nMaxFile = lMax
s = FileTitle & String$(lMax - Len(FileTitle), 0)
.lpstrFileTitle = s: .nMaxFileTitle = lMax
m_lApiReturn = GetOpenFileName(opfile) 'All other fields set to zero
Select Case m_lApiReturn
Case 1 'Success
VBGetOpenFileName = True
If (.flags And OFN_ALLOWMULTISELECT) = OFN_ALLOWMULTISELECT Then
FileTitle = ""
lMax = InStr(.lpstrFile, Chr$(0) & Chr$(0))
If (lMax = 0) Then
Filename = StrZToStr(.lpstrFile)
Else
Filename = Left$(.lpstrFile, lMax - 1)
End If
Else
Filename = StrZToStr(.lpstrFile)
FileTitle = StrZToStr(.lpstrFileTitle)
End If
flags = .flags: FilterIndex = .nFilterIndex 'Return the filter Index
Filter = FilterLookup(.lpstrFilter, FilterIndex) 'Look up the filter the user selected and return that
If (.flags And OFN_READONLY) Then ReadOnly = True
Case 0 'Cancelled
VBGetOpenFileName = False
Filename = "": FileTitle = "": flags = 0
FilterIndex = -1: Filter = ""
Case Else 'Extended error
m_lExtendedError = CommDlgExtendedError()
VBGetOpenFileName = False
Filename = "": FileTitle = "": flags = 0
FilterIndex = -1: Filter = ""
End Select
End With: End Function

Private Function StrZToStr(s$) As String
StrZToStr = Left$(s, lstrlen(s))
End Function

Private Function FilterLookup(ByVal sFilters$, ByVal iCur&

As String
Dim iStart&, iEnd&, s$

iStart = 1
If sFilters = "" Then Exit Function
Do 'Cut out both parts marked by null character
iEnd = InStr(iStart, sFilters, vbNullChar)
If iEnd = 0 Then Exit Function
iEnd = InStr(iEnd + 1, sFilters, vbNullChar)
If iEnd Then
s = Mid$(sFilters, iStart, iEnd - iStart)
Else
s = Mid$(sFilters, iStart)
End If
iStart = iEnd + 1
If iCur = 1 Then
FilterLookup = s
Exit Function
End If
iCur = iCur - 1
Loop While iCur
End Function

Function VBChooseColor(COLOR&, Optional AnyColor As Boolean = True, Optional FullOpen As Boolean = False, _
Optional DisableFullOpen As Boolean = False, Optional Owner& = -1, Optional flags&

As Boolean
Dim chclr As TCHOOSECOLOR, afMask&

chclr.lStructSize = Len(chclr)
If Owner -1 Then chclr.hWndOwner = Owner
chclr.rgbResult = COLOR 'Assign color (default uninitialized value of zero is good default)
afMask = CLng(Not (CC_ENABLEHOOK Or CC_ENABLETEMPLATE)) 'Mask out unwanted bits
'Pass in flags
chclr.flags = afMask And (CC_RGBInit Or IIf(AnyColor, CC_AnyColor, CC_SolidColor) Or _
(-FullOpen * CC_FullOpen) Or (-DisableFullOpen * CC_PreventFullOpen))

If m_bNotFirst = False Then InitColors 'If first time, initialize to white
chclr.lpCustColors = VarPtr(alCustom(0))
m_lApiReturn = ChooseColor(chclr) 'All other fields zero
Select Case m_lApiReturn
Case 1 'Success
VBChooseColor = True
COLOR = chclr.rgbResult
Case 0 'Cancelled
VBChooseColor = False
COLOR = -1
Case Else 'Extended error
m_lExtendedError = CommDlgExtendedError()
VBChooseColor = False: COLOR = -1
End Select
End Function

Private Sub InitColors()
Dim i%
' Initialize with first 16 system interface colors
For i = 0 To 15: alCustom(i) = GetSysColor(i): Next i
m_bNotFirst = True
End Sub