ENG: FSO inteface moudle, easy interacts with file system
Option Explicit
'
' Interfaccia con il sistema operativo Kernel32/OpenFileDialog/FileSystemObject
' - Info sul sistema operativo
' - Path di Browser e Applicazioni registrate
' - Finestra dialogo OpenFile (non legata a un OCX)
' - Oggetto FSO (con associazione tardiva che facilita la distribuzione)
' Operating system interface Kernel32/OpenFileDialog/FileSystemObject
' - Operating System Info
' - Path of Browser and others registered Application
' - OpenFile Dialog without OCX
' - File System Object with late binding that simplifies sharing of workbook
' Dichiarazioni API 32bit (Kernel)
'
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Type OSVERSIONINFOEX
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
wServicePackMajor As Integer
wServicePackMinor As Integer
wSuiteMask As Integer
wProductType As Byte
wReserved As Byte
End Type
Public Declare Function GetVersionExA Lib "kernel32" (lpVersionInformation As OSVERSIONINFO) As Integer
'
Private 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
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _
As Long
'
' -- Open File Dialog --
'
Const cdlOFNFileMustExist = &H1000
Const cdlOFNHideReadOnly = &H4
Const cdlOFNHelpButton = &H10
Const cdlOFNPathMustExist = &H800
Const cdlOFNShareAware = &H4000
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) _
As Long
' ----------------------------------
' FILE SYSTEM OBJECT (FSO)
' ----------------------------------
'
' In generale le funzioni che iniziano con:
' FSO usano un oggetto gia associato e lo lasciano inalterato;
' le altre dichiarano un nuovo oggetto, lo usano e poi lo eliminano
' Generally functions name that begin with
' FSO already use a bound object and leave it unchanged;
' others functions declare a new object, use it and then destroy
'
Enum enumSpecialFolder
WindowsFolder = 0
SystemFolder = 1
TemporaryFolder = 2
End Enum
Enum enumIOMODE
ForReading = 1
ForWriting = 2
ForAppending = 8
End Enum
Enum enumFormat
TristateUseDefault = -2
TristateTrue = -1
TristateFalse = 0
End Enum
'
' Esegue l'associazione tardiva all'oggetto di tipo FSO
' Late Binding to FSO
'
Function GetFSO() As Object ' Scripting.FileSystemObject
On Error Resume Next
Set GetFSO = CreateObject("Scripting.FileSystemObject")
On Error GoTo 0
End Function
'
' Se FSO è nothing esegue l'associazione tardina e restituisce TRUE
' If FSO is nothing do late binding a return TRUE
'
Function SetFSO(fso As Object) As Boolean
If fso Is Nothing Then
SetFSO = True
Set fso = GetFSO
End If
End Function
'
' Rilascia fso quando b = TRUE
' Releases fso when b = TRUE
'
Sub unSetFSO(fso As Object, b As Boolean)
If b Then
Set fso = Nothing
End If
End Sub
'
' True se l'oggetto FSO è disponibile
' True if FSO is available
'
Function checkFSO() As Boolean
checkFSO = Not (GetFSO() Is Nothing)
End Function
'
' Estensione di un file senza .
' Return extension of file withou dot
'
Function File_ExtensionName(sFileName As String, _
Optional fso As Object = Nothing) As String
Dim b As Boolean
b = SetFSO(fso)
File_ExtensionName = fso.GetExtensionName(sFileName)
unSetFSO fso, b
End Function
Function File_Estensione(sFileName As String) As String
' ALIAS della precedente - ALIAS of preceding
File_Estensione = File_ExtensionName(sFileName)
End Function
'
' Nome senza Estensione
' File Name withou extension
'
Function File_BaseName(sFileName As String, _
Optional fso As Object = Nothing) As String
Dim b As Boolean
b = SetFSO(fso)
File_BaseName = fso.GetBaseName(sFileName)
unSetFSO fso, b
End Function
Function File_Nome(sFileName As String) As String
' ALIAS della precedente - ALIAS of preceding
File_Nome = File_BaseName(sFileName)
End Function
'
' Nome compresa Estensione
' File Name with extension
'
Function File_Name(sFileName As String, _
Optional fso As Object = Nothing) As String
Dim b As Boolean
b = SetFSO(fso)
File_Name = fso.GetFileName(sFileName)
unSetFSO fso, b
End Function
'
' Nome del drive
' Drive name
'
Function File_DriveName(sFileName As String, _
Optional fso As Object = Nothing) As String
Dim b As Boolean
b = SetFSO(fso)
File_DriveName = fso.GetDriveName(sFileName)
unSetFSO fso, b
End Function
'
' Path di un file con \
' Path of file terminated with \
'
Function File_Path(sFileName As String, _
Optional fso As Object = Nothing) As String
Dim b As Boolean
b = SetFSO(fso)
File_Path = Left$(sFileName, InStr(sFileName, fso.GetBaseName(sFileName)) - 1)
unSetFSO fso, b
End Function
'
' Path assoluto
' Absolute Path
'
Function File_AbsolutePath(sFileName As String, _
Optional fso As Object = Nothing) As String
Dim b As Boolean
b = SetFSO(fso)
File_AbsolutePath = fso.GetAbsolutePathName(sFileName)
unSetFSO fso, b
End Function
'
' Copia di un file
' File Copy
'
Function File_Copy(sFileName As String, _
sNewFileName As String, _
Optional overwrite As Boolean = False, _
Optional bMsg As Boolean = False, _
Optional fso As Object) As Boolean
Dim b As Boolean
Dim bResult As Boolean
b = SetFSO(fso)
Err.Clear
On Error Resume Next
fso.CopyFile sFileName, sNewFileName, overwrite
bResult = (Err.Number <> 0)
On Error GoTo 0
If bMsg And bResult Then
MsgBox Err.Description & vbCrLf & _
sFileName & ";" & vbCrLf & _
sNewFileName, _
vbExclamation, "Copia File Fallita"
End If
File_Copy = bResult
Err.Clear
unSetFSO fso, b
End Function
'
' Copia il fie specificato, anteponendo all'estensione la data e l'ora dell'ultima modifica
' Copy o specified file, prefixing extension with date and time
'
Function File_Backup(sFileName As String, _
Optional overwrite As Boolean = False, _
Optional bMsg As Boolean = False, _
Optional fso As Object) As Boolean
Dim b As Boolean
Dim sNewFileName As String
Dim sEst As String
Dim sTimeStamp As String
b = SetFSO(fso)
sEst = fso.GetExtensionName(sFileName)
sTimeStamp = Format$(fso.GetFile(sFileName).DateLastModified, "yyyymmddhhmmss") & "."
sNewFileName = File_Replace_Ext(sFileName, sTimeStamp & sEst)
File_Backup = File_Copy(sFileName, sNewFileName, overwrite, bMsg, fso)
unSetFSO fso, b
End Function
'
' Elimina un file, TRUE se eliminazione riuscita
' Delete file, return TRUE if successfully
'
Function File_Delete(sFileName As String, _
Optional fso As Object) As Boolean
Dim b As Boolean
b = SetFSO(fso)
If fso.FileExists(sFileName) Then
fso.DeleteFile sFileName
File_Delete = True
End If
unSetFSO fso, b
End Function
'
' Elimina una cartella, TRUE se eliminazione riuscita
' Delete folder, return TRUE if successfully
'
Function File_DeleteFolder(sFolderPath As String, _
Optional fso As Object) As Boolean
Dim b As Boolean
b = SetFSO(fso)
If fso.FolderExists(sFolderPath) Then
fso.DeleteFolder sFolderPath
File_DeleteFolder = True
End If
unSetFSO fso, b
End Function
'
' Altri metodi di FSO - Othes method of FSO
'CopyFile Method
'CopyFolder Method
'CreateFolder Method
'CreateTextFile Method
'MoveFile Method
'MoveFolder Method
'GetDrive Method
'GetFile Method
'GetFolder Method
'GetParentFolderName Method
'GetSpecialFolder Method
'GetTempName Method
'OpenTextFile Method
'
'
' Restituisce TRUE se esiste (File, Cartella, Disco)
' Return TRUE if exists (File, Folder, Drive)
'
Function File_Exist(sFileName As String, _
Optional fso As Object) As Boolean
Dim b As Boolean
b = SetFSO(fso)
File_Exist = fso.FileExists(sFileName)
unSetFSO fso, b
End Function
Function Folder_Exist(sFolderName As String, _
Optional fso As Object) As Boolean
Dim b As Boolean
b = SetFSO(fso)
Folder_Exist = fso.FolderExists(sFolderName)
unSetFSO fso, b
End Function
Function Drive_Exist(sDriveName As String, _
Optional fso As Object) As Boolean
Dim b As Boolean
b = SetFSO(fso)
Drive_Exist = fso.DriveExists(sDriveName)
unSetFSO fso, b
End Function
'
' Costruisce il Path completo, aggiunge i separatori quando servono
' Build complete Path, adding path separator qhen necessary
'
Function File_BuildPath(sPath As String, _
sFileName As String, _
Optional fso As Object) As String
Dim b As Boolean
Dim newpath
b = SetFSO(fso)
newpath = fso.BuildPath(sPath, sFileName)
File_BuildPath = newpath
unSetFSO fso, b
End Function
Function GetDrive(folderSpec As String, _
Optional fso As Object) As Object 'Scriptng.Drive
Dim b As Boolean
b = SetFSO(fso)
Set GetDrive = fso.GetDrive(fso.GetAbsolutePathName(folderSpec))
unSetFSO fso, b
End Function
Function GetFile(fileSpec As String, _
Optional fso As Object) As Object ' Scripting.File
Dim b As Boolean
b = SetFSO(fso)
Set GetFile = fso.GetFile(fileSpec)
unSetFSO fso, b
End Function
'
' Restituisce l'oggetto Folder individuato dal Path
' Return Folder object finding by path
'
Function getFolder(sPath As String, _
Optional fso As Object = Nothing) As Object
Dim b As Boolean
Dim s As String
b = SetFSO(fso)
s = sPath
If fso.FolderExists(s) = False Then
' Non trovo questo path, forse è un file
If fso.FileExisst(s) Then
s = fso.GetParentFolderName(s)
If fso.FolderExists(s) = False Then
Exit Function
End If
Else
Exit Function
End If
End If
Set getFolder = fso.getFolder(s)
unSetFSO fso, b
End Function
'
' Restituisce l'oggetto FSO.Folder
' accetta per il parametro Folder sia FoderName sia FolderObject
' Return folder object
' accept FoderName and FolderObject as parameter
'
Private Function getFolder2(fileSpec As Variant, _
Optional fso As Object) As Object
Dim b As Boolean
b = SetFSO(fso)
Select Case TypeName(fileSpec)
Case "String"
Set getFolder2 = getFolder(CStr(fileSpec), fso)
Case "Folder"
Set getFolder2 = fileSpec
Case "File"
Set getFolder2 = getFolder(fileSpec.path, fso)
Case Else
' set as nothing
Exit Function
End Select
unSetFSO fso, b
End Function
'
' Individua il path di una Cartella Speciale
' System, Windows, Temporary
' Return path of special folder
' (System, Windows o Temporary)
'
Function GetSpecialFolder(folderSpec As enumSpecialFolder, _
Optional fso As Object) As Object ' Scripting.Folder
Dim b As Boolean
b = SetFSO(fso)
Set GetSpecialFolder = fso.GetSpecialFolder(folderSpec)
unSetFSO fso, b
End Function
'
' Elimina i drive da un Path
' accetta Stringa, FolderObject o FileObject
' Remove drive from path string
' accept String, FolderObject or FileObject
'
Function File_TrimDrive(fileSpec As Variant, _
Optional fso As Object) As String
Dim b As Boolean
Dim fld As Object ' scripting.Folder
Dim FolderName As String
Dim Drivename As String
b = SetFSO(fso)
Set fld = getFolder2(fileSpec, fso)
' Se non esiste esco con una stringa vuota
If fld Is Nothing Then Exit Function
FolderName = fld.path
Drivename = File_DriveName(FolderName)
File_TrimDrive = Mid$(FolderName, Len(Drivename) + 1)
unSetFSO fso, b
End Function
'
' Restituisce il nome della primacartella di un path
' accetta Stringa, FolderObject o FileObject
' Return the name of fisrt folder in path
' accept String, FolderObject or FileObject
'
Function File_FirstFolder(fileSpec As Variant, _
Optional fso As Object) As String
Dim b As Boolean
Dim fld As Object ' scripting.Folder
Dim FolderName As String
b = SetFSO(fso)
Set fld = getFolder2(fileSpec, fso)
' Se non esiste esco con una stringa vuota
If fld Is Nothing Then Exit Function
FolderName = fld.path
' Risalgo al primo path
Do While fld.IsRootFolder = False
FolderName = fld.path
Set fld = fld.ParentFolder
Loop
File_FirstFolder = FolderName
End Function
'
' Funzioni di manipolazione del nome senza uso di FSO
' Manipulating Function for name withou FSO
'
Public Function AddPathSeparator(s As String) As String
AddPathSeparator = s & IIf(s > "" And Right(s, 1) <> "\", "\", "")
End Function
Public Function File_Replace_Ext(sFileName As String, sNewExtension As String)
Dim p As String, N As String, e As String
p = File_Path(sFileName)
N = File_Nome(sFileName)
e = sNewExtension
If Left$(e, 1) = "." Then e = Mid$(e, 2)
File_Replace_Ext = File_BuildPath(p, N & "." & e)
End Function
'
' Collezione dei file in una cartella ricorsiva
' Collection of file in folder Recursive
'
Public Function ListaFile(strFolder As String, _
Optional sExtFilter As String = "", _
Optional bRecursive As Boolean = True, _
Optional fso As Object) As Collection
'EXAMPLE:
' Set coll = ListaFile("c:\sviluppo\fogliexcel", ";xls;xlt;xla;", true)
' Dim i As Long
' For i = 1 To coll.Count
' Debug.Print coll(i)
' Next
'
Const FOR_READING = 1
Dim arrListaFile As New Collection
Dim objFolder As Object
Dim objFile As Object
Dim colFiles
Dim b As Boolean
b = SetFSO(fso)
Set objFolder = fso.getFolder(strFolder)
Set colFiles = objFolder.Files
For Each objFile In colFiles
If sExtFilter = Empty Then
arrListaFile.Add objFile.path
ElseIf InStr(sExtFilter, fso.GetExtensionName(objFile.Name)) > 0 Then
arrListaFile.Add objFile.path
End If
Next
If bRecursive Then
ShowSubFolders fso, objFolder, arrListaFile, sExtFilter
End If
Set ListaFile = arrListaFile
unSetFSO fso, b
End Function
'
' Scorre le sottocartelle
' Loop subfolders
'
Private Sub ShowSubFolders(objFSO, objFolder, arrListaFile, sExtFilter As String)
Dim colFolders, objSubFolder, colFiles, objFile
Set colFolders = objFolder.SubFolders
For Each objSubFolder In colFolders
Set colFiles = objSubFolder.Files
For Each objFile In colFiles
If sExtFilter = Empty Then
arrListaFile.Add objFile.path
ElseIf InStr(sExtFilter, objFSO.GetExtensionName(objFile.Name)) > 0 Then
arrListaFile.Add objFile.path
End If
Next
ShowSubFolders objFSO, objSubFolder, arrListaFile, sExtFilter
Next
End Sub
' ----------------------------------
' COMMON DIALOG -- FILEOPEN
' ----------------------------------'
'
Function ScegliFile() As String
Dim Dlg As Object
Set Dlg = CreateObject("MSComDlg.CommonDialog")
With Dlg
.MaxFileSize = 260
.InitDir = ThisWorkbook.path
.CancelError = True
.DialogTitle = "Importa lista articoli"
.Filter = "File Campagne .xls (*.xls)"
.DefaultExt = "xls"
.FileName = "*.xls"
.FilterIndex = 1
.flags = cdlOFNFileMustExist + cdlOFNHideReadOnly + _
cdlOFNPathMustExist + 0
Err.Clear
On Error Resume Next
.ShowOpen
If Err.Number <> 0 Then
MsgBox "Non hai selezionato il file ", vbCritical, "Errore"
End
End If
On Error GoTo 0
End With
ScegliFile = Dlg.FileName
End Function
Function Open_Comdlg32(Optional sStartPath As String = "", _
Optional sFilter As String = "", _
Optional sTitle As String = "", _
Optional lFlag As Long = 0) As String
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim strFilter As String
OpenFile.lStructSize = Len(OpenFile)
'// Define your wildcard string here
'// Note we pad the strings with Chr(0)
'// This indicates an end of a string
If sStartPath = Empty Then
sStartPath = ThisWorkbook.path
End If
If sFilter = Empty Then
sFilter = "Excel (*.xls)" & Chr(0) & "*.xls" & Chr(0)
End If
If sTitle = Empty Then
sTitle = "Apri file"
End If
If lFlag = 0 Then
lFlag = cdlOFNFileMustExist + _
cdlOFNHideReadOnly + _
cdlOFNPathMustExist + 0
End If
With OpenFile
.lpstrFilter = sFilter
.nFilterIndex = 1
.lpstrFile = String(257, 0)
.nMaxFile = Len(.lpstrFile) - 1
.lpstrFileTitle = .lpstrFile
.nMaxFileTitle = .nMaxFile
.lpstrInitialDir = sStartPath
.lpstrTitle = sTitle
.flags = lFlag
End With
lReturn = GetOpenFileName(OpenFile)
If lReturn = 0 Then
' L'utente ha premuto [Annulla]
MsgBox "Operazione Annullata"
Else
Dim FileToOpen As String
FileToOpen = Application.WorksheetFunction.Clean(OpenFile.lpstrFile)
Open_Comdlg32 = FileToOpen
End If
End Function
Function GetDirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, X As Long, pos As Integer
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(msg) Then
bInfo.lpszTitle = "Seleziona una cartella."
Else
bInfo.lpszTitle = msg
End If
' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
X = SHBrowseForFolder(bInfo)
' Parse the result
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
' ----------------------------------
' SISTEMA OPERATIVO
' ----------------------------------
'
Public Function get_OSVersionNum() As Single
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space$(128)
retvalue = GetVersionExA(osinfo)
get_OSVersionNum = osinfo.dwMajorVersion + osinfo.dwMinorVersion / 10
End Function
'
Public Function get_OSVersion() As String
Dim v As String
Select Case get_OSVersionNum
Case 5#
v = "Windows 2000"
Case 5.1
v = "Windows XP (32-bit)"
Case 5.2
v = "Windows XP (64-bit), 2003 Server, Home Server"
Case 6#
v = "Windows Vista, 2008 Server"
Case 6.1
v = "Windows 7, 2008 Server R2"
Case 6.2
v = "Windows 8-8.1, 2012 Server R2"
Case Else
v = "Other version"
End Select
get_OSVersion = v
End Function
' Determina se il sistema operativo è a 64 bit
Public Function Is64bitOS() As Boolean
Is64bitOS = Len(GetEnviron("ProgramW6432")) > 0
End Function
Sub test1()
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space$(128)
retvalue = GetVersionExA(osinfo)
Debug.Print "Buil=" & osinfo.dwBuildNumber
Debug.Print "InfoSize=" & osinfo.dwOSVersionInfoSize
Debug.Print "Platform=" & osinfo.dwPlatformId
Debug.Print osinfo.szCSDVersion
End Sub
Nessun commento:
Posta un commento