title image


Smiley Ich poste dir mal meine Lösung......
.....die Anderen sollen ja auch etwas davon haben!

;.)







Als erstes erstellst Du ein Klassenmodul in VBA, speicherst dies unter dem Namen "CCommonDialog" und 

fügst folgenden Inhalt ein (die Klasse wird benötigt für das Explorer-Fenster zum Dateien auswählen):



Option Compare Database

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

' class module CCommonDialog, adds Windows CommonDialogs to Access.

' Copyright (c) 1998 Thomas Prötzsch

' ********************************************************************************

' Usage:

'

' Sub xx()

' Dim CDL As New CCommonDialog

' Dim Dateiname as String



' short version:

' Dateiname = CDL.ShowOpen ' or .ShowSave

' if Dateiname = "" then exit sub ' canceled by user

' .....

'

' without any variables:

' CDL.ShowOpen ' or .ShowSave

' if CDL.FileName = "" then exit sub ' canceled by user

' .....

'

' detailed:

'

' With CDL

' .DialogTitle = "Mein Titel"

' .DefaultExt = "TXT" 'Default-extension, if nothing else was specified by user.

' .InitDir = "d:\"

' .Flags = OFN_FILEMUSTEXIST Or OFN_PATHMUSTEXIST Or OFN_READONLY

' .Filter = "Textdateien (*.txt)|*.txt|MyFileType (*.my)|*.my"

' .ShowOpen ' or .ShowSave

' End With

' End Sub

'

'************************************************************************************



' Public variables, can be accessed as Properties from outside

Public FileName As String ' filename

Public InitDir As String ' initial directory

Public DefaultExt As String ' default extension

Public DialogTitle As String ' dialog title

Public Filter As String ' filter string

Public FilterIndex As Long

Public Flags As Long ' flags



Private Type TOpenFileName

lStructSize As Long ' lenth of this data type OPENFILENAME

hwndOwner As Long ' owning window of this dialog

hInstance As Long ' not used

lpstrFilter As String ' filterstring of display filters in dialog

lpstrCustomFilter As String ' not used

nMaxCustFilter As Long ' not used

nFilterIndex As Long ' 1 for initial using the first filter, 2 for the second...

lpstrFile As String ' return value containing user selection

nMaxFile As Long ' lenght of lpstrFile

lpstrFileTitle As String ' filename without Path (can also detemined in VB, therefore not userd here)

nMaxFileTitle As Long ' not used

lpstrInitialDir As String ' folder in which this Dialog should start browsing

lpstrTitle As String ' titel of the dialog window

Flags As Long ' several options, set by a combinaton of constants

nFileOffset As Integer ' not used

nFileExtension As Integer ' not used

lpstrDefExt As String ' default extension, if no other extension has been entered by user

lCustData As Long ' not used

lpfnHook As Long ' Hook not used

lpTemplateName As Long ' not used

End Type



Private Declare Function API_GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As TOpenFileName) As Long

Private Declare Function API_GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As TOpenFileName) As Long



Public Function ShowOpen _

( _

Optional sFileName, _

Optional sFilterString, _

Optional sInitDir, _

Optional sDialogTitle, _

Optional lFlags, _

Optional lFilterIndex, _

Optional sDefaultExt _

) As String

Dim OpenDlg As TOpenFileName



If Not IsMissing(sFileName) Then FileName = sFileName

If Not IsMissing(sFilterString) Then Filter = sFilterString

If Not IsMissing(sInitDir) Then InitDir = sInitDir

If Not IsMissing(sDialogTitle) Then DialogTitle = sDialogTitle

If Not IsMissing(lFlags) Then Flags = lFlags

If Not IsMissing(lFilterIndex) Then FilterIndex = lFilterIndex

If Not IsMissing(sDefaultExt) Then DefaultExt = sDefaultExt



On Error GoTo Error_ShowOpen

With OpenDlg

.lStructSize = Len(OpenDlg)

.hwndOwner = Application.hWndAccessApp

.lpstrFilter = BuildFilter()

.nFilterIndex = FilterIndex

.lpstrFile = Left$(FileName & String$(API_STRING_LEN, vbNullChar), API_STRING_LEN)

.nMaxFile = Len(.lpstrFile) - 1

.lpstrInitialDir = InitDir & vbNullChar

If Len(DialogTitle) Then

.lpstrTitle = DialogTitle & vbNullChar

Else

.lpstrTitle = "Datei öffnen" & vbNullChar

End If

If Flags = 0 Then

.Flags = OFN_FILEMUSTEXIST Or OFN_PATHMUSTEXIST Or OFN_READONLY

Else

.Flags = Flags

End If

.lpstrDefExt = DefaultExt & vbNullChar



If API_GetOpenFileName(OpenDlg) <> 0 Then ' Aufruf erfolgreich

' man kann beides machen:

' Datei= fd.ShowOpen oder fd.ShowOpen : Datei=fd.FileName

FileName = Left$(.lpstrFile, InStr(.lpstrFile, vbNullChar) - 1) ' restliche NUL-Werte abschneiden

ShowOpen = FileName

Else

FileName = vbNullString

ShowOpen = vbNullString

End If

End With



Exit_ShowOpen:

Exit Function



Error_ShowOpen:

MsgBox Err.Description, vbCritical, "Error: ShowOpen"

Resume Exit_ShowOpen

End Function



Function ShowSave _

( _

Optional sFileName, _

Optional sFilterString, _

Optional sInitDir, _

Optional sDialogTitle, _

Optional lFlags, _

Optional lFilterIndex, _

Optional sDefaultExt _

) As String



Dim OpenDlg As TOpenFileName



If Not IsMissing(sFileName) Then FileName = sFileName

If Not IsMissing(sFilterString) Then Filter = sFilterString

If Not IsMissing(sInitDir) Then InitDir = sInitDir

If Not IsMissing(sDialogTitle) Then DialogTitle = sDialogTitle

If Not IsMissing(lFlags) Then Flags = lFlags

If Not IsMissing(lFilterIndex) Then FilterIndex = lFilterIndex

If Not IsMissing(sDefaultExt) Then DefaultExt = sDefaultExt



On Error GoTo Error_ShowSave



With OpenDlg

.lStructSize = Len(OpenDlg)

.hwndOwner = Application.hWndAccessApp

.lpstrFilter = BuildFilter()

.nFilterIndex = FilterIndex

.lpstrFile = Left$(FileName & String$(API_STRING_LEN, vbNullChar), API_STRING_LEN)

.nMaxFile = Len(.lpstrFile) - 1

.lpstrInitialDir = InitDir & vbNullChar

If Len(DialogTitle) Then

.lpstrTitle = DialogTitle & vbNullChar

Else

.lpstrTitle = "Datei speichern unter" & vbNullChar

End If

If Flags = 0 Then

.Flags = OFN_PATHMUSTEXIST Or OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT

Else

.Flags = Flags

End If

.lpstrDefExt = DefaultExt & vbNullChar



If API_GetSaveFileName(OpenDlg) <> 0 Then ' Successfull

' man kann beides machen:

' Datei= fd.ShowSave oder fd.ShowSave; Datei=fd.FileName

FileName = Left$(.lpstrFile, InStr(.lpstrFile, vbNullChar) - 1) ' restliche NUL-Werte abschneiden

ShowSave = FileName

Else

FileName = vbNullString

ShowSave = vbNullString

End If

End With



Exit_ShowSave:

Exit Function



Error_ShowSave:

MsgBox Err.Description, vbCritical, "Error: ShowOpen"

Resume Exit_ShowSave

End Function



Private Sub Class_Initialize()

On Error GoTo Err_Class_Init



FileName = vbNullString



' Current Directory

InitDir = CurDir$



' no Default Extension

DefaultExt = vbNullString



DialogTitle = vbNullString

Filter = vbNullString

FilterIndex = 0



Flags = 0



Exit_Class_Init:

Exit Sub



Err_Class_Init:

MsgBox Err.Description, vbCritical

Resume Exit_Class_Init

End Sub

Private Function BuildFilter() As String

Dim locFilter As String

Dim i As Integer



locFilter = Filter

If Len(locFilter) Then

i = InStr(locFilter, "|")

Do While i

locFilter = Left$(locFilter, i - 1) & vbNullChar & Mid$(locFilter, i + 1)

i = InStr(locFilter, "|")

Loop

Else

locFilter = "Alle Dateien (*.*)" & vbNullChar & "*.*"

End If

BuildFilter = locFilter & vbNullChar & vbNullChar

End Function





Als nächste erstellst Du ein Modul in VBA und fügst folgenden Code ein (Funktion ShellExecute - damit 

öffnest du später mal die Dateien und Funktion DoesFileExist - damit prüft man ob Dateien vorhanden sind):



'ShellExecute

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal Hwnd As Long, ByVal Ipoperation As String, _

ByVal Ipfile As String, ByVal Ipparameters As String, ByVal Ipdirectory As String, ByVal nshowcmd As Long) As Long





'DoesFileExist

'* FF01.1 **************************************************

'Description:  Überprüfen ob eine Datei oder ein Ordner vorhanden ist

'Parameters:   strFilename, [bolDirectory]

'API-Calls:

'References:

'Functions:

'Classes:

'Types:

'Enums:

'Constants:

'Return:       Boolean

'* FF01.1 **************************************************

Public Function DoesFileExist( _

  ByVal strFileName As String, _

  Optional ByVal bolDirectory As Boolean) As Boolean

   

  On Error GoTo DoesFileExist_Error

   

  If Nz(strFileName, "") = "" Then Exit Function

 

  If bolDirectory = True Then

 

    ' Überprüfen ob strFilename als Verzeichnis aber

    ' nicht als Datei existiert. Die Parameter sind

    ' immer additiv zu sehen, d.h. vbDirectory liefert

    ' Datei oder Ordner

    If Len(Dir(strFileName, vbDirectory)) <> 0 And _

      Len(Dir(strFileName)) = 0 Then

      

      DoesFileExist = True

      

    End If

    

  Else

 

    If Len(Dir(strFileName)) <> 0 Then

      DoesFileExist = True

    End If

    

  End If

 

DoesFileExist_Error:

 

End Function









So weit ´mal die Vorbereitungen in VBA.

Jetzt solltest du deine Tabelle um X Felder erweitern (je nachdem wieviele "Anhänge" bzw. "Pfäde" du 

zulassen möchtest. Ich habe die Felder in meinem Beispiel enfach Pfad1, Pfad2, und Pfad3 genannt.

In meinem Form, in dem ich Anhänge anfügen lasse habe ich einen Button "Anhang einfügen" mit folgendem Code:



Private Sub Befehl14_Click()

If Not IsNull(Me.Pfad1) And Not IsNull(Me.Pfad2) And Not IsNull(Me.Pfad3) Then

MsgBox "Sie können maximal 3 Anhänge je Aktion/ Maßnahme hinzufügen!" & vbCrLf & "Tauschen Sie gegebenfalls eine Anlage aus.", vbExclamation, "ANHÄNGEN NICHT MÖGLICH"

Exit Sub

End If



 Dim CDL As New CCommonDialog

 Dim Dateiname As String



 With CDL

 .DialogTitle = "Anhang für EASYPROT@2004 auswählen" 

 .InitDir = "W:\Public\" 'In diesem Verzeichnis öffnet sich dann der Explorer

 .Flags = OFN_FILEMUSTEXIST Or OFN_PATHMUSTEXIST Or OFN_READONLY

 .ShowOpen

 End With

 

Dateiname = CDL.FileName `Hier wird der Pfad der ausgewählten Datei an die Variable Dateiname als String übergeben

If Dateiname = "" Then Exit Sub



If Left(Dateiname, 9) <> "W:\Public" Then 'Hier wird geprüft ob die ausgewählte Datei wirklich auf dem Netlaufwerk liegt

    MsgBox "Es dürfen nur Anhänge aus 'W:\Public\...' ausgewählt" & vbCrLf & "werden. Bitte wählen Sie eine zugelassene Datei aus!", vbExclamation

    Exit Sub

End If



'Hier werden die einzelnen Felder im Formular geprüft, ob diese bereits einen Inhalt haben

'Das erste leere Feld bekommt dann den Pfad aus der Variable übergeben

If Not IsNull(Me.Pfad1) Then

    Me.Pfad1 = Dateiname

If Not IsNull(Me.Pfad2) Then

    Me.Pfad2 = Dateiname

If Not IsNull(Me.Pfad3) Then

    Me.Pfad3 = Dateiname

End If



End Sub





Und zu guter Letzt noch der Code aus dem Formular, mit dem du dann die Dateien anhand des Pfades öffnen kannst:



Private Sub Befehl15_Click()

On Error Resume Next



'Prüft erst mal ob es die Datei noch gibt (könnte ja mittlerweile verschoben/ gelöscht sein)

If DoesFileExist(Me.Pfad1) = False Then

MsgBox "Die Datei ist nicht mehr vorhanden oder der Dateiname" & vbCrLf & "wurde geändert! Anhang kann nicht geöffnet werden." & vbCrLf & _

       "Setzen Sie sich bitte mit dem Autor in Verbindung.", vbExclamation, "DATEI NICHT VORHANDEN"

Exit Sub

End If



Dim DoOpenFile As Long, OpenFileVar As String



'Damit wird die Datei aus dem Feld Pfad1 geöffnet

If Not IsNull(Me!Pfad1) Then

OpenFileVar = Me!Pfad1

DoOpenFile = ShellExecute(Me.Hwnd, vbNullString, OpenFileVar, vbNullString, vbNullString, 1)

Else: MsgBox "Ein Problem mit dem Anhang ist aufgetreten." & vbCrLf & "Bitte informieren Sie den Support!", vbExclamation

End If

End Sub



Code eingefügt mit Syntaxhighlighter 2.5







Hoffe für dich, dass du alles so hinbekommst!

Viel Erfolg!




Schönen Gruß Andrej ___________________________________________________________ Access2000 / 2003 Windows XP VB6

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: