|
|
FSO - Список имен файлов из указанной папки в списке (ListBox) (+ Пример)
Основной код из примера:
Private Sub cmdOpenExcelFile_Click()
Dim sVal$
If Me.ListFiles.ListIndex = -1 Then
MsgBox "Не выбран элемент из списка!", vbExclamation, "Внимание!"
Exit Sub
End If
sVal = Me.TextFolder & "\" & Me.ListFiles
WScriptFollowHyperLink sVal
End Sub
Private Sub cmdOpenFolder_Click()
Dim sVal As String
With Application.FileDialog(4)
.Filters.Clear
.Title = "Please Select a Folder"
.InitialFileName = Me.TextFolder & "\"
If .Show Then
sVal = .SelectedItems(1)
If Len(sVal) > 3 Then Me.TextFolder = .SelectedItems(1)
End If
End With
FilesInFolder Me.TextFolder, "*.xl*"
End Sub
Private Sub Form_Load()
Me.TextFolder = CurrentProject.Path
FilesInFolder Me.TextFolder, "*.xl*"
End Sub
Private Sub FilesInFolder(sFolderPath$, Optional sFilesMask = "*.*")
Dim objFSO As Object, objFolder As Object, objFile As Object
Dim sFName$, sVal$
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(sFolderPath)
типа: "ИмяФайла01;ИмяФайла02;ИмяФайла03;ИмяФайла04; ..."
For Each objFile In objFolder.Files
sFName = objFile.Name
If sFName Like sFilesMask Then
sVal = sVal & ";" & sFName
End If
Next objFile
If Len(sVal) > 2 Then sVal = Mid(sVal, 2)
Me.ListFiles.RowSource = sVal
If Me.ListFiles.ListCount > 0 Then
Me.ListFiles = Me.ListFiles.Column(0, 0)
End If
Set objFile = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End Sub
Private Sub ListFiles_DblClick(Cancel As Integer)
Call cmdOpenExcelFile_Click
End Sub
Private Sub WScriptFollowHyperLink(vLinkOrFilePath)
Dim wsShell As Object
Dim sVal As String
On Error GoTo WScriptFollowHyperlink_Err
sVal = vLinkOrFilePath & ""
If Len(sVal) & "" < 5 Then Exit Sub
sVal = Chr(34) & sVal & Chr(34)
Set wsShell = CreateObject("WScript.Shell")
wsShell.Run sVal
DoEvents
WScriptFollowHyperlink_End:
On Error Resume Next
Set wsShell = Nothing
Err.Clear
Exit Sub
WScriptFollowHyperlink_Err:
MsgBox "Cannot open document:" & vbCrLf & sVal & vbCrLf & _
"Contact database administrator. Err: " & Err.Number, vbExclamation, "Error!"
Err.Clear
Resume WScriptFollowHyperlink_End
End Sub
MSA-2007 и выше ( 68 kB) Пример
|
|