vb.net ListView

Questo post è solo una bozza per raccogliere alcuni frammenti di codice relativi alle ListView

' Cancella tutto, comprese colonne e formati

ListView1.Clear 

' Cancello tutte le righe, ma non la formattazione delle colonne

ListView1.Items.Clear()  

 ' Aggiungo una riga, associando l'immagine con indice 0

item1 = New ListViewItem("testo della prima colonna", 0)
' Aggiungo le colonne successivie 

item1.SubItems.Add("Testo della seconda colonna")

' Agggiungo un toltip alla riga 

item1.ToolTipText = "Testo tooltip"

 ' Associo la sorgente di immagini associabili alla listview

ListView1.LargeImegeList=ImageListControl 

' Associa un immagine alla riga



item1.ImageKey = NumeroIndiceImmagine

' Definisco il colore dello sfondo della riga

 item1.BackColor = Color.LightGray
' Definisco il carattere barrato per la riga 

item1.Font = (New System.Drawing.Font(item1.Font, item1.Font.Style Or FontStyle.Strikeout))

' infine aggiungo la riga alla listview

ListView1.Items.Add(item1)

EXCEL VBA - Add Sort Symbol - Aggiungere il simbolo per l'ordinamento

ITA: La funzione restituisce il tipo di ordinamento da usare ed ha 3 metodi di lavoro:
 2=2 Stati: ad ogni chiamata il triangolo cambia verso
 3=3 Stati: il tringolo si alterna in Ascendente, Discendente, nulla
 0=Sola lettura, la funziona restituisce il metodo di ordinamento senza cambiarlo
ENG: This funztion return Sorting Order Method. It has 3 working methods:
 2=2 state mode: on every call triangle change order
 3=2 state mode: trinagle alternate Ascending, Descending, None
 0=Read only mode, function returns sort order without changes

'
' Aggiunge il simbolo ordinamento e restituisce il tipo di ordinamento da usare
' Add sort simbo on right side and return sort order
'
' smode: 2= Two   State (Ascending, Descending)
'        3= Three State (Ascending, Descending, None)
'        0= Read Only
Function SortSimbol(Target As Range, Optional iMode As Integer = 2)
Dim l As Integer
Dim c As String
Dim i As Integer     ' Len of
Const kFontName = "Webdings"

  l = Len(Target.Value)
  c = Right$(Target, 1)
  Select Case iMode
  Case 2, 3
    i = 1
    Select Case c
    Case "6"
      c = "5"
    Case "5"
      If iMode = 3 Then
        c = ""
      Else
        c = "6"
      End If
    Case Else
      i = 0
      c = "6"
    End Select
  ' Change State
    Target = Left$(Target, l - i) & c
  ' Apply Font
    If Len(c) = 1 Then
      l = Len(Target)
      Target.Characters(Start:=l, Length:=1).Font.Name = kFontName
    End If
  End Select
        
' Read actual status
  If Target.Characters(Start:=l, Length:=1).Font.Name = kFontName Then
    Select Case c
    Case "5"
      SortSimbol = xlDescending
    Case "6"
      SortSimbol = xlAscending
    Case Else
      SortSimbol = 0
    End Select
  Else
    SortSimbol = 0
  End If
End Function

VBA EXCEL - Evidenzare Righe al variare del contenuto di una o + colonne

ITA: Evidenzia le righe di un range alternando due colori quando almeno uno dei valori delle colonne di rottura cambia ripetto alla riga precedente. ENG: Highlights the rows of a range by alternating two colors when at least one of the breakcolumn values is different than the previous line.

'
' Cambia il colore di sfondo quando una delle colonne di rottura cambia rispetto alla riga precedente
' Change the background color when one of the columnbreak is different from the previous line
'
Sub EnhanceRowBreaks(rng As Range, _
                     Optional BreakColumn As Integer = 1, _
                     Optional ColorIndex1 As Long = -4142, _
                     Optional ColorIndex2 As Long = 15, _
                     Optional ColorRGB2)
Dim c1 As Integer
Dim c2 As Integer
Dim cBreak As Integer
Dim c As Integer
Dim r As Long
Dim bColor As Boolean     ' Boolean Switch for enhaced color
Dim bUseColor As Boolean  ' True if use ColorRBG2 instead of ColorIndex2
Dim bkgColor(-1 To 0)
   
  c1 = rng.Column
  c2 = rng.Columns(rng.Columns.Count).Column
  cBreak = c1 + BreakColumn - 1
  bkgColor(0) = ColorIndex1
  bkgColor(-1) = ColorIndex2
  bUseColor = Not IsMissing(ColorRGB2)
  r = rng.Row
  Range(Cells(r, c1), Cells(r, c2)).Interior.ColorIndex = bkgColor(0)
  r = r + 1
 
  Do Until Cells(r, c1) = Empty
  ' Test if one of BreakColumns are changed
    For c = c1 To cBreak
      If (Cells(r, c) <> Cells(r - 1, c)) Then
      ' One of the test columns are not equal
        bColor = Not bColor
        Exit For
      End If
    Next
  ' Set background
    If bColor And bUseColor Then
    ' Use RGB color
      Range(Cells(r, c1), Cells(r, c2)).Interior.Color = ColorRGB2
    Else
    ' Use ColorIndex
      Range(Cells(r, c1), Cells(r, c2)).Interior.ColorIndex = bkgColor(bColor)
    End If
    r = r + 1
  Loop
End Sub

VBA-File System Object

ITA: Modulo di interfaccia con FSO, permette di interagire con il filesystem
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

Simulare Check Box in una cella : Simulate CheckBox in cell

ITA:
La procedura CheckSign_Set:
- Trasforma la prima cella di rRange in una check box
- Applica il segno di spunta se bValue è TRUE
- Il parametro Style determina lo stile della chekbox
La funzione CheckSign_Get restituisce True se individua un segno di spunta valido
La funzione CheckSign_Switch inverte lo stato della spunta, restituisce true se individua una spunta nella prima cella di rRange
La funzione getSign determina il caratte da unsare in base a valore e stile.

ENG:
The procedure CheckSign_Set:
- Transform the first cell of rrange in a check box
- Draws the check mark if bValue is TRUE
- The Style parameter determines the style of chekbox
The CheckSign_Get function returns True if detects a valid check mark
The CheckSign_Switch function reverses the state of the check, it returns true if finds a tick in the first cell of rrange
The function determines the getSign char to use based on value and style

'
'
' Determina il carattere da usare per il segno di 
' Determines the font to use for the sign
Private Function GetSign(bValue As Boolean, Optional style As String = "X") As String
  '       Stili validi sono:   - Valid Styles are:
  ' X =ý  'Quadretto Crocetta  - Square box with cross sign
  ' V =þ  'Quadretto Spunta    - Square box with check sign
  ' x =û  'Solo Crocetta       - cross sign without box
  ' v =ü  'Solo Spunta         - check sign without box
  '   =¨  'Quadratto vuoto     - Empty box
  Dim i As Integer
  GetSign = ""
  i = InStr("XVxv", style): If i = 0 Then i = 1
  If bValue Then
    GetSign = Mid$("ýþûü", i, 1)
  Else
    GetSign = Mid$("¨¨  ", i, 1)
  End If
End Function
'
' Imposta il segno di spunta in una cella
' Sets check mark in a cell
'
Sub CheckSign_Set(rRange As Range, bValue As Boolean, Optional Style As String = "X")
Dim c0 As String * 1, c1 As String * 1
  
  With rRange.Cells(1, 1)
    .Value = GetSign(bvalu, style)
    .Font.Name = "Wingdings"
  End With
End Sub
'
' Legge il segno di spunta dalla prima cella di rRange 
' Read Check Mark in the first cell of rRange
'
Function CheckSign_Get(rRange As Range) As Boolean
  With rRange.Cells(1, 1)              ' Legge solo la prima cella;  Read only first cell;
    If .Font.Name = "Wingdings" Then   ' Solo se il font è Wingding; Only for Wingding font; 
      CheckSign_Get = (InStr("ýþûü", .Value) > 0)
    End If
  End With
End Function
'
' Inverte il segno di spunta
' Reverses the checkmark
'
Function CheckSign_Switch(rRange As Range, Optional style As String = "X") As Boolean
  With rRange.Cells(1, 1)
    If .Font.Name = "Wingdings" Then
    ' If .value is empty add a space
      Select Case InStr("ýþûü¨ ", .Value & IIf(Len(.Value) = 0, " ", ""))
      Case 1, 2               ' Boxed
        .Value = "¨"
      Case 3, 4               ' Unboxed
        .Value = " "
      Case 5, 6               ' Not checke, use style
        .Value = GetSign(True, style)
      End Select
      CheckSign_Switch = True ' Checkbox changed
    End If
  End With
End Sub

' ITA:
' Aggiungere questo codice nella dichiarazione del foglio di lavoro, 
' se si desidera modificare lo stato della casella con un doppio clic.
'
' END:
' Add this code in worksheet declaration, if you want to change the status 
' of check box with a double click.
'
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Font.Name = "Wingdings" Then
    Cancel = CheckSign_Switch(Target, "X")
  End If
End Sub

Espande il contenuto di una variabile ambiente

Questa funzione torna utile per leggere il contenuto di variabili di ambiente come %TEMP% o %PATH% Usefull for read and expand Environmen Variabiles like %TEMP% or %PATH%

'
' Legge una variabile ambiente e ne espande il contenuto
' Reda Environment Variable and expand it
'
Function ExpandEnvironment(sVariableName As String) As String
Dim WshShell
  
  Set WshShell = CreateObject("WScript.Shell")
  ExpandEnvironment = WshShell.ExpandEnvironmentStrings(sVariableName)
  Set WshShell = Nothing
End Function

SendKeys con Windows7

'
' Sostisuisce la funzione Sendkeys che non funziona con i SO successivi a XP
' Replaces Sendkeys internal function has problems with operating systems more than XP
'
Sub SendKeys7(sKeyString As String, Optional bWait As Boolean = False)
Dim WshShell As Object
  
  Set WshShell = WScript.CreateObject("WScript.Shell")
  WshShell.SendKeys sKeyString, bWait
  Set WshShell = Nothing
End Sub