Automatisches Suchen und Speichern von Filmen

Hallo zusammen,
noch immer sitze ich an meiner Datei für meinen Arbeitgeber. Nachdem ich nun per Makro alle Symbol- und Menüleisten beim Start ausblende, habe ich massig Platz, jede Menge Daten anzuzeigen.
Durch anklicken einer Graphik (Firmenlogo) wird ein Film mittels Hyperlink gestartet. Dies funkioniert bei mir auch einwandfrei!
Jetzt ergibt sich jedoch folgendes Problem:
Bei vielen Kollegen ist der Film ("Unternehmen.mpg") in einem anderen Ordner der Festplatte (C:\) gespeichert, wodurch der Hyperlink vor der ersten Benutzung angepasst werden müsste. Dies ist jedoch nicht ganz einfach, da die Arbeitsblätter jeweils mit einem Blattschutz versehen sind und alle Menü- und Symbolleisten ausgeblendet sind.
Gibt es vielleicht die Möglichkeit, dieses Problem mittels VBA zu lösen?
Im Grunde müsste hier ein Makro arbeiten, das
- erst die Datei "Unternehmen.mpg" sucht
- sich den Speicherort für spätere Verwendungen merkt und
- dann den Film startet.
Jedoch soll das Makro nicht bei jedem Start die komplette Festplatte nach der Datei durchsuchen (würde wahrscheinlich zu lange dauern), sondern sich den Speicherort merken und bei jedem weiteren Start prüfen, ob die Datei noch an dem gleichen Ort gespeichert ist. (Falls ja, dann den Film starten, falls nein, dann den Film suchen, speichern und starten).
Leider habe ich gar keine Ahnung, wie ich dies VBA-technisch lösen kann. Wer kann mir helfen?
Gruß Jürgen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub file_find() 'Rolf Beißner Dim fso As Object, fs As Object Dim i As Integer Const d$ = "Unternehmen.xls" Set fs = CreateObject("Scripting.FileSystemObject") Set fso = Application.FileSearch With fso .NewSearch .LookIn = "C:\Filme\" .Filename = d$ .SearchSubFolders = True If .Execute() > 0 Then For i = 1 To .FoundFiles.Count If UCase(d$) = UCase(fs.GetFileName(.FoundFiles(i))) Then Workbooks.Open Filename:=.FoundFiles(i) Exit For End If Next Else MsgBox "Datei " & d$ & " nicht gefunden" End If End With End Sub

Sub film_ab() 'Rolf Beißner Dim rng As Range Dim filmfile As String Set rng = ActiveSheet.Range("O1") If rng = "" Then filmfile = file_find If filmfile = "" Then MsgBox "Die Datei 'Unternehmen.mpg' ist nicht vorhanden" End Else rng = filmfile ActiveSheet.Hyperlinks.Add Anchor:=rng, Address:=rng.Formula _ , TextToDisplay:="Film ab" End If End If rng.Hyperlinks(1).Follow End Sub

Function file_find() As String Dim fso As Object, fs As Object Dim i As Integer Const d$ = "Unternehmen.mpg" Set fs = CreateObject("Scripting.FileSystemObject") Set fso = Application.FileSearch With fso .NewSearch .LookIn = "C:\" .Filename = d$ .SearchSubFolders = True If .Execute() > 0 Then For i = 1 To .FoundFiles.Count If UCase(d$) = UCase(fs.GetFileName(.FoundFiles(i))) Then file_find = .FoundFiles(i) Exit For End If Next Else file_find = "" End If End With End Function

Hallo Jürgen,
dann geht das natürlich nicht mehr mit einem Hyperlink. Du musst der Grafik das Makro "Videostart" zuweisen.

Option Explicit
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
     ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetShortPathName Lib "kernel32.dll" Alias "GetShortPathNameA" ( _
     ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private 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

Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" ( _
    ByVal lpFILE_NAME As String, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" ( _
    ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Const MAX_PATH = &H104
Private Const INVALID_HANDLE_VALUE = -&H1
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const SW_SHOWNORMAL = &H1
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFILE_NAME As String * MAX_PATH
    cAlternate As String * 14
End Type
Private Const FILE_NAME As String = "Unternehmen.mpg"
Private strFolder As String
Private bolfound As Boolean
Public Sub Videostart()
    Const FILE_PATH As String = "C:\"
    Dim strShortPath As String
    bolfound = False
    strFolder = GetSetting(Appname:="File", Section:="Path", Key:=FILE_NAME, Default:=Empty)
    If strFolder <> "" Then
        If Dir(strFolder & FILE_NAME) <> "" Then bolfound = True Else FindFiles FILE_PATH
    Else
        FindFiles FILE_PATH
    End If
    If bolfound Then
        SaveSetting Appname:="File", Section:="Path", Key:=FILE_NAME, setting:=strFolder
        strShortPath = Space(MAX_PATH)
        GetShortPathName strFolder & FILE_NAME, strShortPath, MAX_PATH
        ShellExecute FindWindow("XLMAIN", vbNullString), "open", strShortPath, _
            vbNullString, strFolder, SW_SHOWNORMAL
    Else
        MsgBox "Datei ''" & FILE_NAME & "'' nicht gefunden.", 16, "Fehlermeldung"
    End If
End Sub
Private Sub FindFiles(ByVal strFolderPath As String)
    Dim WFD As WIN32_FIND_DATA
    Dim lngSearch As Long
    Dim strDirName As String
    lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        GetFilesInFolder strFolderPath
        Do
            If bolfound Then Exit Do
            If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
                strDirName = Left$(WFD.cFILE_NAME, InStr(WFD.cFILE_NAME, Chr(0)) - 1)
                If (strDirName <> ".") And (strDirName <> "..") Then _
                    FindFiles strFolderPath & strDirName & "\"
            End If
        Loop While FindNextFile(lngSearch, WFD)
        FindClose lngSearch
    End If
End Sub
Private Sub GetFilesInFolder(ByVal strFolderPath As String)
    Dim WFD As WIN32_FIND_DATA
    Dim lngSearch As Long
    lngSearch = FindFirstFile(strFolderPath & FILE_NAME, WFD)
    If lngSearch <> INVALID_HANDLE_VALUE Then
        If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
            bolfound = True
            strFolder = strFolderPath
        End If
    End If
    FindClose lngSearch
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Automatisches Suchen und Speichern von Filmen

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread