в 16:33, 26 мая 2010

2010-05-26T16:33:00Z

Admin: 1 версия

2010-05-26T12:47:03Z

1 версия

Новая страница

==Check file existance==



<source lang="vb">

Sub ReadPersistedRecordset()
Dim strFileName As String
strFileName = "c:\test.txt"
If Len(Dir(strFileName)) = 0 Then
msgBox "File Not Found"
Exit Sub
End If

End Sub
</source>

==Common File Operations Simplified==



<source lang="vb">

Sub TestGetFile()
Dim nIndex As Integer
Dim sFile As String
sFile = GetExcelFile("Testing GetExcelFile Function")
If sFile = "False" Then
Debug.Print "No file selected."
Exit Sub
End If
Debug.Print sFile
End Sub
Function GetExcelFile(sTitle As String) As String
Dim sFilter As String
Dim bMultiSelect As Boolean
sFilter = "Workbooks (*.xls), *.xls"
bMultiSelect = False
GetExcelFile = Application.GetOpenFilename(FileFilter:=sFilter, _
Title:=sTitle, MultiSelect:=bMultiSelect)
End Function
</source>

==Does the specified file exist?==



<source lang="vb">

Function FileExists(stFile As String) As Boolean
If Dir(stFile) <> "" Then FileExists = True
End Function
Sub TestForFile()
Dim myFileName As String
myFileName = "c:\SalesData1.xls"
If FileExists(myFileName) Then
MsgBox myFileName & " exists"
Else
MsgBox myFileName & " does not exist"
End If
End Sub
</source>

==Gets the file name from the path.==



<source lang="vb">

Sub GetFileName()
Dim stPathSep As String
Dim fileLength As Integer
Dim i As Integer
Dim stFullName As String

stFullName = "C:\asdf.xls"

stPathSep = Application.PathSeparator
fileLength = Len(stFullName)
For i = fileLength To 1 Step -1
If Mid(stFullName, i, 1) = stPathSep Then Exit For
Debug.Print Right(stFullName, fileLength - i + 1)
Next i
End Sub
</source>

==List all files under application path==



<source lang="vb">

Sub FileList()
Dim File As Variant
With Application.FileSearch
.LookIn = "C:\"
.FileType = msoFileTypeAllFiles
.Execute
For Each File In .FoundFiles
MsgBox File
Next File
End With
End Sub
</source>

==processes multiple stored files==



<source lang="vb">

Sub BatchProcess()
Dim Files() As String
Dim FileSpec As String
FileSpec = "c:\text.txt"
NewPath = ExtractPath(FileSpec)
FoundFile = Dir(FileSpec)
If FoundFile = "" Then
MsgBox "Cannot find file:" & FileSpec
Exit Sub
End If
FileCount = 1
ReDim Preserve Files(FileCount)
Files(FileCount) = FoundFile
Do While FoundFile <> ""
FoundFile = Dir()
If FoundFile <> "" Then
FileCount = FileCount + 1
ReDim Preserve Files(FileCount)
Files(FileCount) = FoundFile
End If
Loop
For I = 1 To FileCount
Application.StatusBar = "Processing " & Files(I)
Call ProcessFiles(Files(I))
Next I
Application.StatusBar = False
End Sub
Sub ProcessFiles(FileName As String)
Workbooks.OpenText FileName:=FileName, Origin:=xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(3, 1), Array(12, 1))
End Sub
Function ExtractPath(Spec As String) As String
SpecLen = Len(Spec)
For I = SpecLen To 1 Step -1
If Mid(Spec, I, 1) = "\" Then
ExtractPath = Left(Spec, I - 1)
Exit Function
End If
Next I
ExtractPath = ""
End Function
</source>

==Select a folder==



<source lang="vb">

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Function GetDirectory() As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

bInfo.pidlRoot = 0&
bInfo.lpszTitle = "Select a folder."
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)

path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Sub GetAFolder()
Debug.Print GetDirectory()
End Sub
</source>

==Select a location containing the files you want to list==



<source lang="vb">

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Sub ListFiles()
Msg = "Select a location containing the files you want to list."
Directory = GetDirectory(Msg)
If Directory = "" Then Exit Sub
If Right(Directory, 1) <> "\" Then Directory = Directory & "\"

On Error Resume Next
With Application.FileSearch
.NewSearch
.LookIn = Directory
.Filename = "*.*"
.SearchSubFolders = False
.Execute
For i = 1 To .FoundFiles.Count
Debug.Print .FoundFiles(i)
Debug.Print FileLen(.FoundFiles(i))
Debug.Print FileDateTime(.FoundFiles(i))
Next i
End With
End Sub
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
</source>

==Use array to store a list of files==



<source lang="vb">

Sub XLFiles()
Dim FName As String
Dim arNames() As String
Dim myCount As Integer

FName = Dir("C:\*.xls*")
Do Until FName = ""
myCount = myCount + 1
ReDim Preserve arNames(1 To myCount)
arNames(myCount) = FName
FName = Dir
Loop
End Sub
</source>

← Предыдущая	Версия 16:33, 26 мая 2010
(нет различий)

VBA/Excel/Access/Word/File Path/File - История изменений

в 16:33, 26 мая 2010

Admin: 1 версия