|
| |
Visual-Basic Einsteiger| Re: Zugriff von Excel 2016 auf MPEG Datei Header | |  | | Autor: Tscharlie | | Datum: 30.06.20 16:24 |
| Hallo Zusammen,
damit es man es sich besser vorstellen kann, habe ich das (vorläufig) komplette Makro mal reingestellt.
es geht um den Block Z.39 - Z.52
Stelle ich den Pfad-Namen direkt in Set ObjFolder rein, dann funktioniert es, kopiere ich ihn per String Variable rein, springt das Makro ohne Err-Code zum Ende
1 Private Sub GetDet()
2 '********************************
3 Dim objShell As Object 'Shell
4 Dim objFolder As Object 'Folder
5 Dim objFolderItem As Object 'Datei
6 Dim I As Long
7 Dim szItem As String
8 '*******************************
9 Dim FSO As Object
10 Dim InsSte As Integer
11 Dim Zae1 As Long, GesZae As Long, Zae2 As Long, FindZei As Long 'Zähler für Schleife
12 Dim HL1 As String, ZellAdr As String, KeyStr As String, DoppStr As String, TMP As String
13 Dim FilKZ As Integer, ZeiNr As Long, intZeile As Integer, IZ As Integer
14 Dim NAECHSTER As String, Pfad As String, Datei As String, Zeich As String
15 '*******************************
16 Set FSO = CreateObject("scripting.filesystemobject")
17 Set objShell = CreateObject("Shell.Application")
18 '*******************************
19 Application.Calculation = xlManual
20 Application.ScreenUpdating = False
21 '*******************************
22 Zae1 = 2
23 IZ = 2
24
25 WEITER:
26 GesZae = Range("D65535").End(xlUp).Row
27 Do While Zae1 <= GesZae
28 If Cells(Zae1, 4) = "" Or Left(Cells(Zae1, 4), 1) = "'" Then GoTo NAECHSTER
29 HL1 = UCase(Cells(Zae1, 4).Hyperlinks(1).Address)
30 If HL1 <> "" And (Cells(Zae1, 14) = 0 Or Cells(Zae1, 14) = "") Then
31 InsSte = UCase(InStr(HL1, "MOVIE")) + 5
32 HL1 = "Z:" & Trim(Mid(HL1, InsSte, 250))
33
34 If FSO.FileExists(HL1) Then
35 With FSO.GetFile(HL1)
36 Cells(Zae1, 14) = .Size / 1000
37 Cells(Zae1, 15) = .DateLastModified
38 End With
39 '*** Anfang: um diesen Block geht es:
40 Pfad = Left(HL1, InStrRev(HL1, "\"))
41 ' lt. Debug.Print = Pfad: "Z:\MÄRCHEN, SAGEN, LEGENDEN\NIBELUNGEN\"
42
43 '***wenn ich das setze, funktioniert es nicht:
44 'Set objFolder = objShell.Namespace(Pfad)
45
46 'Direkteingabe funktioniert, kann ich aber nicht brauchen
47 Set objFolder = objShell.Namespace("Z:\MÄRCHEN, SAGEN, LEGENDEN\NIBELUNGEN\")
48 Datei = Mid(HL1, InStrRev(HL1, "\") + 1)
49 Set objFolderItem = objFolder.parsename(Datei)
50 'Video-Auflösung:
51 Cells(Zae1, 26) = objFolder.GetDetailsOf(objFolderItem, 316) & "x" & Folder.GetDetailsOf(objFolderItem, 314)
52 '***** Blockende
53 Else
54 Stop
55 Debug.Print Zae1 & " "; Cells(Zae1, 4) & " " & HL1 & " HL Link ist nicht i.O." 'falscher HL
56 GoTo NAECHSTER
57 End If
58 End If
59 NAECHSTER:
60 Zae1 = Zae1 + 1
61 HL1 = ""
62 'If Zae1 = 13553 Then Stop
63 'Debug.Print Zae1 '**********************
64 Loop
65
66 Set objFolder = Nothing
67 Set objShell = Nothing
68 Application.Calculation = xlCalculationAutomatic
69 Application.ScreenUpdating = True
70 MsgBox "Fertig!!!"
71 End Sub | |
 | Sie sind nicht angemeldet!
Um auf diesen Beitrag zu antworten oder neue Beiträge schreiben zu können, müssen Sie sich zunächst anmelden.
 Einloggen | Neu registrieren |
 |
|
vb@rchiv CD Vol.6 vb@rchiv  Vol.6
Geballtes Wissen aus mehr als 8 Jahren vb@rchiv!
Online-Update-Funktion
Entwickler-Vollversionen
u.v.m.Jetzt zugreifen Tipp des Monats Neu! sevPopUp 2.0 
Dynamische Kontextmenüs!
Erstellen Sie mit nur wenigen Zeilen Code Kontextmenüs dynamisch zur Laufzeit. Vordefinierte Styles (XP, Office, OfficeXP, Vista oder Windows 8) erleichtern die Anpassung an die eigenen Anwendung... Weitere Infos
|
| |
|
Copyright ©2000-2024 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein.
Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel
|
|
April 2024
Sie sind aktuell nicht angemeldet.
