Folgendes Problem:
Ich habe ein Modul geschrieben mit dem aus einer Steuertabelle anhand einer Bezeichnung ein Dateipfad ausgelesen werden soll und die Datei geöffnet werden. Dafür erschien mir die ShellExecute Funktion am besten, da ich damit die verschiedensten Dateitypen öffnen kann ohne konkrete Kenntnisse vom System zu haben. Dies funktioniert auch für jeden Dateityp, abgesehen von jeglichen Excel Dateien. Nach dem alles regulär ausgeführt wird hängt sich Excel Bei dem ShellExecute Command auf und reagiert teilweise noch, aber lässt sich z.B. nicht mehr schließen und öffnet auch keine weiter Excel-Datei.
Hier ist der Quellcode:
Option Explicit
'* ShellExecute Initalization *
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hWnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nshowcmd As Long) As Long
Public Declare Function apiFindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpclassname As Any, _
ByVal lpCaption As Any) As Long
Public Const SW_HIDE = 0
Public Const SW_MAXIMIZE = 3
Public Const SW_MINIMIZE = 6
Public Const SW_NORMAL = 1
Public Const SW_SHOW = 5
Public Const SW_RESTORE = 9
Public Const SW_SHOWMAXIMIZED = 3
Public Const SW_SHOWMINIMIZED = 2
Public Const SW_SHOWMINNOACTIVE = 7
Public Const SW_SHOWNA = 8
Public Const SW_SHOWNOACTIVATE = 4
Public Const SW_SHOWNORMAL = 1
Public Const ERROR_BAD_FORMAT = 11&
Public Const SE_ERR_ACCESSDENIED = 5
Public Const SE_ERR_ASSOCINCOMPLETE = 27
Public Const SE_ERR_DDEBUSY = 30
Public Const SE_ERR_DDEFAIL = 29
Public Const SE_ERR_DDETIMEOUT = 28
Public Const SE_ERR_DLLNOTFOUND = 32
Public Const SE_ERR_FNF = 2
Public Const SE_ERR_NOASSOC = 31
Public Const SE_ERR_OOM = 8
Public Const SE_ERR_PNF = 3
Public Const SE_ERR_SHARE = 26
Public Const ControlWks As String = "Directory"
Public Const NameRange As String = "A1:A10000"
Public Const LocationRange As String = "B"
'* FileOpen Function *
Public Function FileOpen(ByVal Location As String) As Boolean
Dim ReturnValue As Long
Dim hWnd As Long
hWnd = apiFindWindow("OPUSAPP", "0")
ReturnValue = ShellExecute(hWnd, "open", Location, "", "C:\", SW_SHOW)
Select Case ReturnValue
Case ERROR_BAD_FORMAT
MsgBox "Datei ist keine Win32 Anwendung.", vbInformation, "Fehler"
FileOpen = False
Case SE_ERR_ACCESSDENIED
MsgBox "Zugriff verweigert.", vbInformation, "Fehler"
FileOpen = False
Case SE_ERR_ASSOCINCOMPLETE
MsgBox "Datei-Assoziation ist unvollständig.", vbInformation, "Fehler"
FileOpen = False
Case SE_ERR_DDEBUSY
MsgBox "DDE ist nicht bereit.", vbInformation, "Fehler"
FileOpen = False
Case SE_ERR_DDEFAIL
MsgBox "DDE-Vorgang gescheitert.", vbInformation, "Fehler"
FileOpen = False
Case SE_ERR_DDETIMEOUT
MsgBox "DDE-Zeitlimit wurde erreicht.", vbInformation, "Fehler"
FileOpen = False
Case SE_ERR_DLLNOTFOUND
MsgBox "benötigte DLL wurde nicht gefunden.", vbInformation, "Fehler"
FileOpen = False
Case SE_ERR_FNF
MsgBox "Datei wurde nicht gefunden.", vbInformation, "Fehler"
FileOpen = False
Case SE_ERR_NOASSOC
MsgBox "Datei ist nicht Assoziiert.", vbInformation, "Fehler"
FileOpen = False
Case SE_ERR_OOM
MsgBox "Nicht genügend Speicher.", vbInformation, "Fehler"
FileOpen = False
Case SE_ERR_PNF
MsgBox "Pfad wurde nicht gefunden.", vbInformation, "Fehler"
FileOpen = False
Case SE_ERR_SHARE
MsgBox "Sharing-Verletzung.", vbInformation, "Fehler"
FileOpen = False
Case Else
FileOpen = True
End Select
End Function
'* NewEntry Function *
Public Function NewEntry() As String
Dim ReturnMsg As Long
ReturnMsg = MsgBox("Eintrag nicht gefunden. Neuer Eintrag?", vbYesNoCancel, "Neuer Eintrag")
Select Case ReturnMsg
Case 2
NewEntry = "0"
Case 6
NewEntry = LocationInput("")
Case 7
NewEntry = "0"
Case Else
NewEntry = "0"
End Select
End Function
'* LocationInput Function *
Public Function LocationInput(Location As String)
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "Dateipfad"
.ButtonName = "Auswählen"
If Location "" Then
.InitialFileName = Location
Else
.InitialFileName = "file:\\"
End If
If .Show = -1 Then
LocationInput = .SelectedItems(1)
Else
End
End If
End With
End Function
'* GetLocation Function *
Public Function GetLocation(Name As String) As String
Dim RowNum As Long
Dim LastRow As Long
Dim NameEntries() As Variant
NameEntries = Worksheets(ControlWks).Range(NameRange).Value
On Error GoTo NotFound
RowNum = WorksheetFunction.Match(Name, NameEntries, False)
GetLocation = Worksheets(ControlWks).Range(LocationRange & RowNum).Value
Exit Function
NotFound:
Dim Location As String
Location = NewEntry()
If Location "0" Then
LastRow = Worksheets(ControlWks).Range("A10000").End(xlUp).Row + 1
Worksheets(ControlWks).Range("A" & LastRow).Value = Name
Worksheets(ControlWks).Range("B" & LastRow).Value = Location
GetLocation = GetLocation(Name)
Else
End
End If
End Function
'* Execute Sub *
Sub Execute(Name As String)
Dim ReturnValue As Boolean
Dim Location As String
Name = "Versuch"
Location = GetLocation(Name)
ReturnValue = FileOpen(Location)
End Sub
Was mach ich hier falsch?
Gruß Hagen