Visual Basic World - Programmierung und BeispieleVisual Basic World - Tipps und TutorialsVisual Basic World - Source-Code und Forum

<leer>

Tipp 047: Common Dialog Control ersetzen und ohne Steuerelement nachbauen

Autor: Thomas Geiger   VB-Version: Visual Basic 6.0   Download: Beispielprojekt Tipp-047

Beschreibung

Das in Visual Studio enthaltene Common Dialog Control hält für den geneigten Programmierer zahlreiche nutzbringende Funktionen parat. So lassen sich beispielsweise die Windows-Standard-Dialoge zum "Datei öffnen" oder "Datei speichern" anzeigen. In aller Regel funktioniert dies auch einwandfrei und einer Verwendung des entsprechenden Steuerelements steht nichts im Wege.

Es kann jedoch Ausnahmesituationen geben in denen ein Rückgriff auf das Standard-Control nicht möglich ist. Wenn Sie in Ihrer Anwendung etwa eine Update-Routine integriert haben welche nur die Anwendung selbst aktualisiert jedoch keine Steuerelemente im System registrieren kann so können Sie wichtige neue Funktionen ggf. nicht per Online-Update nachreichen oder müssen den Benutzer zu einer kompletten Neuinstallation der Anwendung veranlassen.

Umso hilfreicher ist es, wenn Sie die vom Common Dialog Control gebotenen Funktionen mit eigenem Quellcode nachbilden können. Dieser Tipp zeigt wie dies funktioniert, zur einfacheren Verwendung sind dabei die verschiedenen Dialoge in einzelne Klassen gekapselt. Geboten werden die Umsetzungen des "Datei öffnen" und "Datei speichern"-Dialogs und der typische Verzeichnis-Browser.

Quellcode

Form1
CommandButton            Command1
CommandButton            Command2
CommandButton            Command3
Form                     Form1
Frame                    Frame1
Frame                    Frame2
Frame                    Frame3
Label                    Label1
Label                    Label2
' VISUAL BASIC WORLD
' ===========================================
' Das große Portal zum Thema Visual Basic.
'
' Wenn Ihnen dieser Source Code gefallen hat,
' dann empfehlen Sie Visual Basic World bitte
' weiter und/oder setzen Sie einen Link auf:
'
' http://www.visualbasicworld.de/
'
' Vernetzen Sie sich mit uns:
'
' http://twitter.com/visualbasicwrld
'
' Autor: Thomas Geiger

Option Explicit Dim DlgOpen As Dlg_FileOpen Dim DlgSave As Dlg_FileSave Dim DlgBrowse As Dlg_Browse
Private Sub Command1_Click() DlgOpen.CancelError = True 'DlgOpen.DefaultDirectory = "C:\" DlgOpen.DialogTitle = "Datei öffnen" DlgOpen.Filter = "Textdateien (*.txt)|*.txt|Word Dokumente (*.doc)|*.doc|Bitmaps (*.bmp)|*.bmp" DlgOpen.HwndOwner = Me.hWnd On Error GoTo abbr DlgOpen.ShowOpen Label1.Caption = DlgOpen.FileName Exit Sub abbr: MsgBox "Abbrechen wurde gewählt" End Sub
Private Sub Command2_Click() DlgSave.CancelError = True 'DlgOpen.DefaultDirectory = "C:\" DlgSave.DialogTitle = "Datei speichern" DlgSave.Filter = "Textdateien (*.txt)|*.txt|Word Dokumente (*.doc)|*.doc|Bitmaps (*.bmp)|*.bmp" DlgSave.HwndOwner = Me.hWnd On Error GoTo abbr DlgSave.ShowSave Label2.Caption = DlgSave.FileName Exit Sub abbr: MsgBox "Abbrechen wurde gewählt" End Sub
Private Sub Command3_Click() DlgBrowse.CancelError = True DlgBrowse.HwndOwner = Me.hWnd On Error GoTo abbr DlgBrowse.ShowBrowse Label3.Caption = DlgBrowse.FolderName Exit Sub abbr: MsgBox "Abbrechen wurde gewählt" End Sub
Private Sub Form_Load() Set DlgOpen = New Dlg_FileOpen Set DlgSave = New Dlg_FileSave Set DlgBrowse = New Dlg_Browse End Sub
Dlg_Browse
' VISUAL BASIC WORLD
' ===========================================
' Das große Portal zum Thema Visual Basic.
'
' Wenn Ihnen dieser Source Code gefallen hat,
' dann empfehlen Sie Visual Basic World bitte
' weiter und/oder setzen Sie einen Link auf:
'
' http://www.visualbasicworld.de/
'
' Vernetzen Sie sich mit uns:
'
' http://twitter.com/visualbasicwrld
'
' Autor: Thomas Geiger
 
'-----------------------------'
' Dlg_Browse - Version 1.00   '
' Written by Thomas Geiger    '
'-----------------------------'

'Unsere internen Variablen Private tHwndOwner As Long Private tText As String Private tFolderName As String Private tCancelError As Boolean Private tBrowseIn As BrowseFolders 'API Deklarationen Private Declare Function SHGetPathFromIDList Lib _ "shell32.dll" Alias "SHGetPathFromIDListA" _ (ByVal pidl As Long, ByVal pszPath As String) _ As Long Private Declare Function SHGetSpecialFolderLocation Lib _ "shell32.dll" (ByVal HwndOwner As Long, _ ByVal nFolder As Long, pidl As ITEMIDLIST) _ As Long Private Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As _ BROWSEINFO) As Long 'ITEMIDLIST 'Typen, die wir brauchen Private Type SHITEMID cb As Long abID As Byte End Type Private Type ITEMIDLIST mkid As SHITEMID End Type Private Type BROWSEINFO 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 Public Enum BrowseFolders BF_STANDART BF_DESKTOP BF_PROGRAMS BF_CONTROLS BF_PRINTERS BF_PERSONAL BF_FAVORITES BF_STARTUP BF_RECENT BF_SENDTO BF_BITBUCKET BF_STARTMENU BF_DESKTOPDIRECTORY BF_DRIVES BF_NETWORK BF_NETHOOD BF_FONTS BF_TEMPLATES End Enum 'Und jetzt brauchen wir noch mehrere Konstanten Private Const NOERROR = 0 Private Const CSIDL_DESKTOP = &H0 Private Const CSIDL_PROGRAMS = &H2 Private Const CSIDL_CONTROLS = &H3 Private Const CSIDL_PRINTERS = &H4 Private Const CSIDL_PERSONAL = &H5 Private Const CSIDL_FAVORITES = &H6 Private Const CSIDL_STARTUP = &H7 Private Const CSIDL_RECENT = &H8 Private Const CSIDL_SENDTO = &H9 Private Const CSIDL_BITBUCKET = &HA Private Const CSIDL_STARTMENU = &HB Private Const CSIDL_DESKTOPDIRECTORY = &H10 Private Const CSIDL_DRIVES = &H11 Private Const CSIDL_NETWORK = &H12 Private Const CSIDL_NETHOOD = &H13 Private Const CSIDL_FONTS = &H14 Private Const CSIDL_TEMPLATES = &H15 Private Const BIF_RETURNONLYFSDIRS = &H1 Private Const BIF_DONTGOBELOWDOMAIN = &H2 Private Const BIF_STATUSTEXT = &H4 Private Const BIF_RETURNFSANCESTORS = &H8 Private Const BIF_BROWSEFORCOMPUTER = &H1000 Private Const BIF_BROWSEFORPRINTER = &H2000 Private Const CLSCD_ERRNUMUSRCANCEL = 32755 Private Const CLSCD_ERRDESUSRCANCEL = "www.visualbasicworld.de - Version 1.00: Abbrechen wurde angeklickt"
Public Function ShowBrowse() '=============================================' 'Die Hauptfunktion, die das Dialogfeld anzeigt' '=============================================' 'Variablen deklarieren Dim bi As BROWSEINFO Dim idl As ITEMIDLIST Dim rtn&, pidl&, path$, pos% 'Strukturen erstellen und füllen bi.hOwner = tHwndOwner bi.lpszTitle = tText 'Jetzt müssen wir festlegen, wonach wir suchen wollen Select Case tBrowseIn Case BF_STANDART bi.ulFlags = BIF_RETURNONLYFSDIRS Case BF_DESKTOP bi.pidlRoot = CSIDL_DESKTOP bi.ulFlags = BIF_RETURNONLYFSDIRS Case BF_PROGRAMS bi.pidlRoot = CSIDL_PROGRAMS bi.ulFlags = BIF_RETURNONLYFSDIRS Case BF_CONTROLS bi.pidlRoot = CSIDL_CONTROLS bi.ulFlags = BIF_BROWSEFORPRINTER Case BF_PRINTERS bi.pidlRoot = CSIDL_PRINTERS bi.ulFlags = BIF_BROWSEFORPRINTER Case BF_PERSONAL bi.pidlRoot = CSIDL_PERSONAL bi.ulFlags = BIF_RETURNONLYFSDIRS Case BF_FAVORITES bi.pidlRoot = CSIDL_FAVORITES bi.ulFlags = BIF_RETURNONLYFSDIRS Case BF_STARTUP bi.pidlRoot = CSIDL_STARTUP bi.ulFlags = BIF_RETURNONLYFSDIRS Case BF_RECENT bi.pidlRoot = CSIDL_RECENT bi.ulFlags = BIF_RETURNONLYFSDIRS Case BF_SENDTO bi.pidlRoot = CSIDL_SENDTO bi.ulFlags = BIF_RETURNONLYFSDIRS Case BF_BITBUCKET bi.pidlRoot = CSIDL_BITBUCKET bi.ulFlags = BIF_RETURNONLYFSDIRS Case BF_STARTMENU bi.pidlRoot = CSIDL_STARTMENU bi.ulFlags = BIF_RETURNONLYFSDIRS Case BF_DESKTOPDIRECTORY bi.pidlRoot = CSIDL_DESKTOPDIRECTORY bi.ulFlags = BIF_RETURNONLYFSDIRS Case BF_DRIVES bi.pidlRoot = CSIDL_DRIVES bi.ulFlags = BIF_RETURNONLYFSDIRS Case BF_NETWORK bi.pidlRoot = CSIDL_NETWORK bi.ulFlags = BIF_RETURNONLYFSDIRS Case BF_NETHOOD bi.pidlRoot = CSIDL_NETHOOD bi.ulFlags = BIF_RETURNONLYFSDIRS Case BF_FONTS bi.pidlRoot = CSIDL_FONTS bi.ulFlags = BIF_BROWSEFORPRINTER Case BF_TEMPLATES bi.pidlRoot = CSIDL_TEMPLATES bi.ulFlags = BIF_RETURNONLYFSDIRS End Select 'Jetzt holen wir uns den Pfad, falls dies möglich ist pidl& = SHBrowseForFolder(bi) path$ = Space$(512) rtn& = SHGetPathFromIDList(ByVal pidl&, ByVal path$) 'Und zum Schluss analysieren wir noch die Rückgabe If rtn& Then pos% = InStr(path$, Chr$(0)) tFolderName = Left(path$, pos - 1) Else If CancelError = True Then Err.Raise Number:=CLSCD_ERRNUMUSRCANCEL, Description:=CLSCD_ERRDESUSRCANCEL End If Exit Function End If End Function
'============================' 'Eigenschaften unserer Klasse' '============================' Public Property Get HwndOwner() As Long HwndOwner = tHwndOwner End Property
Public Property Let HwndOwner(ByVal vNewValue As Long) tHwndOwner = vNewValue End Property
Public Property Get Text() As String Text = tText End Property
Public Property Let Text(ByVal vNewValue As String) tText = vNewValue End Property
Public Property Get FolderName() As String FolderName = tFolderName End Property
Public Property Get CancelError() As Boolean CancelError = tCancelError End Property
Public Property Let CancelError(ByVal vNewValue As Boolean) tCancelError = vNewValue End Property
Public Property Get BrowseIn() As BrowseFolders BrowseIn = tBrowseIn End Property
Public Property Let BrowseIn(ByVal vNewValue As BrowseFolders) tBrowseIn = vNewValue End Property
Dlg_FileOpen
' VISUAL BASIC WORLD
' ===========================================
' Das große Portal zum Thema Visual Basic.
'
' Wenn Ihnen dieser Source Code gefallen hat,
' dann empfehlen Sie Visual Basic World bitte
' weiter und/oder setzen Sie einen Link auf:
'
' http://www.visualbasicworld.de/
'
' Vernetzen Sie sich mit uns:
'
' http://twitter.com/visualbasicwrld
'
' Autor: Thomas Geiger
 
'-------------------------------'
' Dlg_FileOpen - Version 1.00   '
' Written by Thomas Geiger      '
'-------------------------------'

'Unsere internen Variablen Private tFilter As String Private tDialogTitle As String Private tCancelError As Boolean Private tDefaultDirectory As String Private tFlags As Long Private tFileName As String Private tFileTitle As String Private tHwndOwner As Long 'Windows Api Deklarationen Private Declare Function GetOpenFileNameA Lib _ "comdlg32.dll" (pOpenfilename _ As tOPENFILENAME) As Long Private Declare Function CommDlgExtendedError _ Lib "comdlg32.dll" () As Long 'Konstanten für die Dialogfelder Private Const CLSCD_NOACTION = 0 Private Const CLSCD_SHOWOPEN = 1 Private Const CLSCD_SHOWSAVE = 2 Private Const CLSCD_USERCANCELED = 0 Private Const CLSCD_USERSELECTED = 1 Private Const CLSCD_MAXFILESIZE = 256 Private Const CLSCD_ERRNUMUSRCANCEL = 32755 Private Const CLSCD_ERRDESUSRCANCEL = "www.visualbasicworld.de - Version 1.00: Abbrechen wurde angeklickt" Private Const CLSCD_ERRNUMUSRBUFFER = 32756 Private Const CLSCD_ERRDESUSRBUFFER = "www.visualbasicworld.de - Version 1.00: Puffer zu klein" Private Const FNERR_BUFFERTOOSMALL = &H3003 Private Const FNERR_FILENAMECODES = &H3000 Private Const FNERR_INVALIDFILENAME = &H3002 Private Const FNERR_SUBCLASSFAILURE = &H3001 'Benutzerdefinierte Typen und Enum Typen Private Type tOPENFILENAME 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 DlgFileFlags nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As String End Type Private Enum DlgFileFlags OFN_ALLOWMULTISELECT = &H200 OFN_CREATEPROMPT = &H2000 = &H80 OFN_EXPLORER = &H80000 OFN_EXTENSIONDIFFERENT = &H400 OFN_FILEMUSTEXIST = &H1000 OFN_HIDEREADONLY = &H4 OFN_LONGNAMES = &H200000 OFN_NOCHANGEDIR = &H8 OFN_NODEREFERENCELINKS = &H100000 OFN_NOLONGNAMES = &H40000 OFN_NONETWORKBUTTON = &H20000 OFN_NOREADONLYRETURN = &H8000 OFN_NOTESTFILECREATE = &H10000 OFN_NOVALIDATE = &H100 OFN_OVERWRITEPROMPT = &H2 OFN_PATHMUSTEXIST = &H800 OFN_READONLY = &H1 OFN_SHOWHELP = &H10 End Enum
Public Function ShowOpen() '==========================================' 'Die Hauptfunktion, die den Dialog anzeigt.' '==========================================' 'Variablen deklarieren Dim OpenVar As tOPENFILENAME Dim ApiReturnValue As Long Dim lExtendedError As Long 'Wir füllen die DialogStruktur OpenVar.lpstrTitle = tDialogTitle OpenVar.HwndOwner = tHwndOwner If tFilter <> "" Then OpenVar.lpstrFilter = sAPIFilter(tFilter) End If OpenVar.lpstrInitialDir = tDefaultDirectory OpenVar.Flags = tFlags 'Wir erweitern die Werte der Struktur OpenVar.nMaxFileTitle = CLSCD_MAXFILESIZE OpenVar.nMaxFile = CLSCD_MAXFILESIZE OpenVar.lpstrFileTitle = Space(CLSCD_MAXFILESIZE - 1) & vbNullChar OpenVar.lpstrFile = Space(CLSCD_MAXFILESIZE - Len("") - 1) & vbNullChar 'Größe der Struktur eintragen OpenVar.lStructSize = Len(OpenVar) 'Jetzt können wir die Standartfehlerbehebung starten On Error GoTo UnknownError 'Und nun kommt der entscheidende Moment... wir zeigen das Dialogfeld ApiReturnValue = GetOpenFileNameA(OpenVar) 'Nachdem das Dialogfeld gezeigt wurde, können wir den Rückgabewert und die Fehlermeldungen analysieren If ApiReturnValue = CLSCD_USERSELECTED Then tFileName = sLeftOfNull(OpenVar.lpstrFile) tFileTitle = sLeftOfNull(OpenVar.lpstrFileTitle) Else lExtendedError = CommDlgExtendedError If lExtendedError = FNERR_BUFFERTOOSMALL Then On Error GoTo 0 Err.Raise Number:=CLSCD_ERRNUMUSRBUFFER, Description:=CLSCD_ERRDESUSRBUFFER Exit Function Else If tCancelError = True Then On Error GoTo 0 Err.Raise Number:=CLSCD_ERRNUMUSRCANCEL, Description:=CLSCD_ERRDESUSRCANCEL Exit Function End If End If End If Exit Function UnknownError: End Function
Private Function sAPIFilter(ByVal Filter As String) As String '=====================================' 'Private Funktionen, die wir brauchen.' '=====================================' Dim I As Long Dim C As String * 1 Dim NullFilter As String For I = 1 To Len(Filter) C = Mid(Filter, I, 1) If C = "|" Then NullFilter = NullFilter & Chr(0) Else NullFilter = NullFilter & C End If Next I While Right(NullFilter, 2) <> Chr(0) & Chr(0) NullFilter = NullFilter & Chr(0) Wend sAPIFilter = NullFilter End Function
Private Function sLeftOfNull(ByVal txt As String) Dim I As Long, P As Long Dim ntxt As String, k As String * 1 P = InStr(txt, Chr(0) & Chr(0)) If P > 0 Then For I = 1 To P - 1 k = Mid(txt, I, 1) If k = Chr(0) Then ntxt = ntxt & " " Else ntxt = ntxt & k Next I Else ntxt = Left(txt, InStr(txt, Chr(0)) - 1) End If sLeftOfNull = ntxt End Function
'=============================' 'Eigenschaften unserer Klasse.' '=============================' Public Property Get DialogTitle() As String DialogTitle = tDialogTitle End Property
Public Property Let DialogTitle(ByVal vNewValue As String) tDialogTitle = vNewValue End Property
Public Property Get Filter() As String Filter = tFilter End Property
Public Property Let Filter(ByVal vNewValue As String) tFilter = vNewValue End Property
Public Property Get CancelError() As Boolean CancelError = tCancelError End Property
Public Property Let CancelError(ByVal vNewValue As Boolean) tCancelError = vNewValue End Property
Public Property Get DefaultDirectory() As String DefaultDirectory = tDefaultDirectory End Property
Public Property Let DefaultDirectory(ByVal vNewValue As String) tDefaultDirectory = vNewValue End Property
Public Property Get Flags() As Long Flags = tFlags End Property
Public Property Let Flags(ByVal vNewValue As Long) tFlags = vNewValue End Property
Public Property Get HwndOwner() As Long HwndOwner = tHwndOwner End Property
Public Property Let HwndOwner(ByVal vNewValue As Long) tHwndOwner = vNewValue End Property
Public Property Get FileName() As String FileName = tFileName End Property
Public Property Get FileTitle() As String FileTitle = tFileTitle End Property
Dlg_FileSave
' VISUAL BASIC WORLD
' ===========================================
' Das große Portal zum Thema Visual Basic.
'
' Wenn Ihnen dieser Source Code gefallen hat,
' dann empfehlen Sie Visual Basic World bitte
' weiter und/oder setzen Sie einen Link auf:
'
' http://www.visualbasicworld.de/
'
' Vernetzen Sie sich mit uns:
'
' http://twitter.com/visualbasicwrld
'
' Autor: Thomas Geiger
 
'-------------------------------'
' Dlg_FileSave - Version 1.00   '
' Written by Thomas Geiger      '
'-------------------------------'

'Unsere internen Variablen Private tFilter As String Private tDialogTitle As String Private tCancelError As Boolean Private tDefaultDirectory As String Private tFlags As Long Private tFileName As String Private tFileTitle As String Private tHwndOwner As Long 'Windows Api Deklarationen Private Declare Function GetSaveFileNameA Lib _ "comdlg32.dll" (pOpenfilename _ As tOPENFILENAME) As Long Private Declare Function CommDlgExtendedError _ Lib "comdlg32.dll" () As Long 'Konstanten für die Dialogfelder Private Const CLSCD_NOACTION = 0 Private Const CLSCD_SHOWOPEN = 1 Private Const CLSCD_SHOWSAVE = 2 Private Const CLSCD_USERCANCELED = 0 Private Const CLSCD_USERSELECTED = 1 Private Const CLSCD_MAXFILESIZE = 256 Private Const CLSCD_ERRNUMUSRCANCEL = 32755 Private Const CLSCD_ERRDESUSRCANCEL = "www.visualbasicworld.de - Version 1.00: Abbrechen wurde angeklickt" Private Const CLSCD_ERRNUMUSRBUFFER = 32756 Private Const CLSCD_ERRDESUSRBUFFER = "www.visualbasicworld.de - Version 1.00: Puffer zu klein" Private Const FNERR_BUFFERTOOSMALL = &H3003 Private Const FNERR_FILENAMECODES = &H3000 Private Const FNERR_INVALIDFILENAME = &H3002 Private Const FNERR_SUBCLASSFAILURE = &H3001 'Benutzerdefinierte Typen und Enum Typen Private Type tOPENFILENAME 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 DlgFileFlags nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As String End Type Private Enum DlgFileFlags OFN_ALLOWMULTISELECT = &H200 OFN_CREATEPROMPT = &H2000 = &H80 OFN_EXPLORER = &H80000 OFN_EXTENSIONDIFFERENT = &H400 OFN_FILEMUSTEXIST = &H1000 OFN_HIDEREADONLY = &H4 OFN_LONGNAMES = &H200000 OFN_NOCHANGEDIR = &H8 OFN_NODEREFERENCELINKS = &H100000 OFN_NOLONGNAMES = &H40000 OFN_NONETWORKBUTTON = &H20000 OFN_NOREADONLYRETURN = &H8000 OFN_NOTESTFILECREATE = &H10000 OFN_NOVALIDATE = &H100 OFN_OVERWRITEPROMPT = &H2 OFN_PATHMUSTEXIST = &H800 OFN_READONLY = &H1 OFN_SHOWHELP = &H10 End Enum
Public Function ShowSave() '==========================================' 'Die Hauptfunktion, die den Dialog anzeigt.' '==========================================' 'Variablen deklarieren Dim OpenVar As tOPENFILENAME Dim ApiReturnValue As Long Dim lExtendedError As Long 'Wir füllen die DialogStruktur OpenVar.lpstrTitle = tDialogTitle OpenVar.HwndOwner = tHwndOwner If tFilter <> "" Then OpenVar.lpstrFilter = sAPIFilter(tFilter) End If OpenVar.lpstrInitialDir = tDefaultDirectory OpenVar.Flags = tFlags OpenVar.lpstrDefExt = ".X" 'Wir erweitern die Werte der Struktur OpenVar.nMaxFileTitle = CLSCD_MAXFILESIZE OpenVar.nMaxFile = CLSCD_MAXFILESIZE OpenVar.lpstrFileTitle = Space(CLSCD_MAXFILESIZE - 1) & vbNullChar OpenVar.lpstrFile = Space(CLSCD_MAXFILESIZE - Len("") - 1) & vbNullChar 'Größe der Struktur eintragen OpenVar.lStructSize = Len(OpenVar) 'Jetzt können wir die Standartfehlerbehebung starten On Error GoTo UnknownError 'Und nun kommt der entscheidende Moment... wir zeigen das Dialogfeld ApiReturnValue = GetSaveFileNameA(OpenVar) 'Nachdem das Dialogfeld gezeigt wurde, können wir den Rückgabewert und die Fehlermeldungen analysieren If ApiReturnValue = CLSCD_USERSELECTED Then tFileName = sLeftOfNull(OpenVar.lpstrFile) tFileTitle = sLeftOfNull(OpenVar.lpstrFileTitle) Else lExtendedError = CommDlgExtendedError If lExtendedError = FNERR_BUFFERTOOSMALL Then On Error GoTo 0 Err.Raise Number:=CLSCD_ERRNUMUSRBUFFER, Description:=CLSCD_ERRDESUSRBUFFER Exit Function Else If tCancelError = True Then On Error GoTo 0 Err.Raise Number:=CLSCD_ERRNUMUSRCANCEL, Description:=CLSCD_ERRDESUSRCANCEL Exit Function End If End If End If Exit Function UnknownError: End Function
Private Function sAPIFilter(ByVal Filter As String) As String '=====================================' 'Private Funktionen, die wir brauchen.' '=====================================' Dim I As Long Dim C As String * 1 Dim NullFilter As String For I = 1 To Len(Filter) C = Mid(Filter, I, 1) If C = "|" Then NullFilter = NullFilter & Chr(0) Else NullFilter = NullFilter & C End If Next I While Right(NullFilter, 2) <> Chr(0) & Chr(0) NullFilter = NullFilter & Chr(0) Wend sAPIFilter = NullFilter End Function
Private Function sLeftOfNull(ByVal txt As String) Dim I As Long, P As Long Dim ntxt As String, k As String * 1 P = InStr(txt, Chr(0) & Chr(0)) If P > 0 Then For I = 1 To P - 1 k = Mid(txt, I, 1) If k = Chr(0) Then ntxt = ntxt & " " Else ntxt = ntxt & k Next I Else ntxt = Left(txt, InStr(txt, Chr(0)) - 1) End If sLeftOfNull = ntxt End Function
'============================' 'Eigenschaften unserer Klasse' '============================' Public Property Get DialogTitle() As String DialogTitle = tDialogTitle End Property
Public Property Let DialogTitle(ByVal vNewValue As String) tDialogTitle = vNewValue End Property
Public Property Get Filter() As String Filter = tFilter End Property
Public Property Let Filter(ByVal vNewValue As String) tFilter = vNewValue End Property
Public Property Get CancelError() As Boolean CancelError = tCancelError End Property
Public Property Let CancelError(ByVal vNewValue As Boolean) tCancelError = vNewValue End Property
Public Property Get DefaultDirectory() As String DefaultDirectory = tDefaultDirectory End Property
Public Property Let DefaultDirectory(ByVal vNewValue As String) tDefaultDirectory = vNewValue End Property
Public Property Get Flags() As Long Flags = tFlags End Property
Public Property Let Flags(ByVal vNewValue As Long) tFlags = vNewValue End Property
Public Property Get HwndOwner() As Long HwndOwner = tHwndOwner End Property
Public Property Let HwndOwner(ByVal vNewValue As Long) tHwndOwner = vNewValue End Property
Public Property Get FileName() As String FileName = tFileName End Property
Public Property Get FileTitle() As String FileTitle = tFileTitle End Property

ANZEIGE <leer>
<leer> Aktuelle Seite Back To Top
Druckansicht | Feedback | Favoriten
Copyright © Visual Basic World, 2000-2014 | Kontakt | Impressum

Visual Basic World @ Twitter

Folgen Sie Visual Basic World!

Visual Basic World @ Twitter
Wenn Ihnen Visual Basic World gefällt, dann folgen Sie uns doch bei Twitter (@visualbasicwrld).
Vielen Dank!



Unterstützen Sie VB-World!

Wenn Ihnen Visual Basic World gefällt, dann unterstützen Sie uns!



Das geht am einfachsten, indem Sie einen Link auf visualbasicworld.de setzen oder senden Sie doch folgende QR-Grafik an Ihre Freunde:

Visual Basic World

Außerdem würden wir uns sehr freuen, wenn Sie uns bei Twitter (@visualbasicwrld) folgen.
Vielen Dank!


Mitarbeiter gesucht

Für das aktuelle Redesign und die zukünftige Betreuung von visualbasicworld.de suchen wir Unterstützung und Verstärkung für unser Team.

Wenn Sie über fundierte Programmierkenntnisse im Bereich Visual Basic und/oder HTML/CSS verfügen und Spaß daran haben in Ihrer Freizeit anderen Ihr Wissen zu vermitteln, dann Sie uns und werden Sie ein Teil des Visualbasicworld-Teams.