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

Excel VBA Context menu

ITA: Per aggiungere un menu contestuale, richiamare PreparamenuContestuale nell'evento evento Workbook_Open.
Per vializzare il menu usare una chiamata nell'evento Worksheet_BeforeRightClick (vedi esempio).
Nell'esempio viene aggiunta solo una voce di menu, ma posiamo aggiungere altre voci di menu o altri menu.
Puoi scegliere il codice FaceID da questa pagina o altre simili in rete.
ENG: You can add contextual menu by adding a call to PreparaMenuContestuale into Workbook_Open event.
You can display context menu by calling it into Worksheet_BeforeRightClick event (see below example).
In this example only one menu item are added, but you can add more items and more menus.
You can view FaceID code in this page or others similar in the net. FaceID

'
' Add Command Bar Items
'
Sub PreparaMenuContestuale(Optional dummy As Boolean = False)
Dim ContextMenu As CommandBarPopup
Dim sName   As String
Dim sAction As String
Dim sTag    As String
Dim i       As Long

  sName = "contextMenuName"
  sAction = "'" & ThisWorkbook.Name & "'!PLG_"  ' Base Name of the code called by menu PLG_ are sample
  sTag = "Tag_PLG"                              ' Tag for alla items in this menu
  DeleteFromCommandBar sName                    ' Removing if already present
  
  With Application.CommandBars.Add( _
      Name:=sName, Position:=msoBarPopup, _
      MenuBar:=False, Temporary:=True)          ' Add new command bar menu
    With .Controls.Add(Type:=msoControlButton)  ' Add first munu item
      .Caption = "Modifica Articolo"            ' What you see in menu
      .TAG = sTag                               ' Used for searching
      .OnAction = sAction & "ModificaArticolo"  ' Name of procedure called
      .FaceId = 2059                            ' ID of image used in menu (optional)
      .DescriptionText = _
         "Modifica le proprietà dell'articolo " ' Hint for this menu item
      .TooltipText = .DescriptionText           ' What you see in tootip text Ballon
    End With
  End With
End Sub
'
' Remove command Bar specified by name
'
Sub DeleteFromCommandBar(sCommandBarName As String)
On Error Resume Next
  
  With Application.CommandBars(sCommandBarName)
    If Error.Number = 0 Then
      .Delete
    End If
  End With
  Error.Clear
On Error GoTo 0
End Sub
'
' Remove alla the item with specidied tag from commandBarMenu specified by name
' if tag is empty rempve all items
'
Sub DeleteFromCommandBarTAG(sCommandBarName As String, Optional sTag As String = "")
Dim ContextMenu As CommandBar
Dim ctrl As CommandBarControl

On Error Resume Next
  ' Define pointer to menu
  Set ContextMenu = Application.CommandBars(sCommandBarName)

  ' Loop for all menu items
  For Each ctrl In ContextMenu.Controls
    If ctrl.Tag = sTag Or sTag = "" Then
    ' Delete when TAG is equal os sTag is empty
      ctrl.Delete
    End If
  Next ctrl
On Error GoTo 0
End Sub

'
' Place this code into worksheet declaration
'
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
  If Target.Row = 3 Then
    If Target.Column < 5 then 
      Cancel = True                                        'Prevent executing of normal Double Click event
      Application.CommandBars("contextMenuName").ShowPopup 'Show Menu
    End If
  End If
End Sub

Excel VBA - Pulizia Range (Clear range)

ITA: Semplifica la cancellazione di un range. Aggiunge alcuni metodi non disponibili:
- Cancellazione delle costanti (lascia intatte le formule)
- Cancellazione selettiva dei bordi
- Cancellazione selettiva degli attributi del font
- Cancellazione Colore del fotn e sfondo

ENG: Simplifies range cleaning. It adds some methods not availables
- Constants cleaning (leaves formulas)
- Selective deleteion of edges
- Selective deletion of font attributes
- Cancellation of the background color

'
' Pulisce il range specificato
' Mode è una stringa che può contenere uno p più dei seguenti caratteri:
'
' T=Tutto              (corrisonde al metodo Clear)
' C=Contenuto          (corrisonde al metodo ClearContents) 
' c=Commenti           (corrisonde al metodo ClearComments)  
' F=Formati            (corrisonde al metodo ClearFormats)  
' N=Note               (corrisonde al metodo ClearNotes)   
' H=Hyperlink          (corrisonde al metodo ClearHyperlinks)   
' O=Outline            (Struttura)
' V=Valori             (non cancella le formule)
' P=Paper color        (Colore sfondo)
' f=Font Attribute     Cancella gli attributi del font, è possibile specificare quali
'                      indicando una combinazione delle lettere [GCBAPSNDI] racchiuse tra []
'                      Grasetto/Corsivo/Barrato/Apice/Pedice/Sottolineato
'                      Nome font/Dimensioni font (ripristina i predefiniti)
'                      Inchiostro (colore del carattere)
' B=Bordi              Cancella i bordi, è possibile specificare quali
'                      indicando una combinazione delle lettere [LTBRVHDU] racchiuse tra []
'                      Left/Top/Bottom/Right; inside Vertical/Horizontal; diagonal Up/Down
'

' Clean specificed range
' Mode is a string than can containing ono or more of this chars:
'
' T=all                (equivalent to Clear          method)
' C=Contents           (equivalent to ClearContents  method)
' c=Comments           (equivalent to ClearComments  method) 
' F=Formats            (equivalent to ClearFormats   method)
' N=Notes              (equivalent to ClearNotes     method)
' H=Hyperlink          (equivalent to ClearHypelinks method)
' O=Outline            (equivalent to ClearOutline   method)
' V=Values             (clear only constants, leave formulas)
' P=Paper color        (clear background color of cells)
' f=Font Attribute     Clear font attributes. You can specify which indicating a combination 
'                      of the letters [GCBAPSNDI] enclosed in square barckets
'                      G=Bold/C=Italic/B=Strikethrough/A=Superscript/P=Subscript/S=Underlines
'                      N=Font Name/D=Font Size/I=Font Color (restore defaults)
' B=Borders            Clear borders. You can specify which indicating a combination 
'                      of the letters [LTBRVHDU] enclosed in square barckets
'                      L=Left/T=Top/B=Bottom/R=Right
'                      V=inside Vertical/H=inside Inside Horizontal
'                      U=diagonal Up/D=diagonal Down
'
Sub PuliziaRange(rRange As Range, Optional ByVal sMode As String = "C")
Dim sKeys As String

  With rRange
    Do Until sMode = Empty
      Select Case Left$(sMode, 1)
      Case "C"
        .ClearContents
      Case "c"
        .ClearComments
      Case "F"
        .ClearFormats
      Case "H"
        .ClearHyperlinks
      Case "N"
        .ClearNotes
      Case "O"
        .ClearOutline
      Case "V"
      ' Solo i valori, lascia le formule 
      ' Only values, leaves formulas
        Dim c As Range
        For Each c In .Cells
          If c.HasFormula = False Then c.ClearContents
        Next c
      Case "P"
        .Interior.ColorIndex = xlColorIndexNone
      Case "f" ' [GCBAPSNDI]
        sKeys = ""
        If Mid$(sMode, 2, 1) = "[" Then
          sKeys = Parse(Mid$(sMode, 3), "]")                ' clean flags for fonts 
          sMode = "f" & Mid$(TrimBefore(sMode, "]"), 2) ' Remove brackets 
        End If
      
        With .Font
          If KeyExist(sKeys, "G") Then .Bold = False
          If KeyExist(sKeys, "C") Then .Italic = False
          If KeyExist(sKeys, "B") Then .Strikethrough = False
          If KeyExist(sKeys, "A") Then .Superscript = False
          If KeyExist(sKeys, "P") Then .Subscript = False
          If KeyExist(sKeys, "S") Then .Underline = xlUnderlineStyleNone
          If KeyExist(sKeys, "F") Then .Name = Application.StandardFont
          If KeyExist(sKeys, "D") Then .Name = Application.StandardFontSize
          If KeyExist(sKeys, "I") Then .Name = .ColorIndex = xlAutomatic
        End With
        
      Case "B"      ' [LTBRVHDU]
        sKeys = ""
        If Mid$(sMode, 2, 1) = "[" Then
          sKeys = Parse(Mid$(sMode, 3), "]")                ' clean flags for bordes
          sMode = "B" & Mid$(TrimBefore(sMode, "]"), 2) ' Remove brackets 
        End If
        If KeyExist(sKeys, "D") Then .Borders(xlDiagonalDown).LineStyle = xlNone
        If KeyExist(sKeys, "U") Then .Borders(xlDiagonalUp).LineStyle = xlNone
        If KeyExist(sKeys, "L") Then .Borders(xlEdgeLeft).LineStyle = xlNone
        If KeyExist(sKeys, "T") Then .Borders(xlEdgeTop).LineStyle = xlNone
        If KeyExist(sKeys, "B") Then .Borders(xlEdgeBottom).LineStyle = xlNone
        If KeyExist(sKeys, "R") Then .Borders(xlEdgeRight).LineStyle = xlNone
        If KeyExist(sKeys, "V") Then .Borders(xlInsideVertical).LineStyle = xlNone
        If KeyExist(sKeys, "H") Then .Borders(xlInsideHorizontal).LineStyle = xlNone
      Case "T"
        .Clear
      Case Else
        Err.Raise 2001, "PuliziaRange", "Invalid Parameter " & sMode 
      End Select
      sMode = Mid$(sMode, 2)
    Loop
  End With
End Sub

'
' Cerca il carattere sKey nella stringa sKeys
' Se la string sKeys è vuota retituisce bDefault
' il confronto è case sensitive
'
' Find sKey into sKeys. If sKeys is empty return sDefault
' Search are case sensitive
'
Function KeyExist(sKeys As String, sKey As String, _
                  Optional bDefault As Boolean = True) As Boolean
  If Len(sKeys) = 0 Then
    KeyExist = bDefault
  Else
    KeyExist = (InStr(sKeys, sKey) > 0)
  End If
End Function
'
' Scompone una stringa di parametri
' Separati da virgole oppure da un altro carattere a scelta
'
'
' Parse parametre string, separated by commas or other char specified
'
Function Parse(s As String, Optional Sep) As String
Dim c As Integer
  If IsMissing(Sep) Then Sep = ","
  c = InStr(s, Sep)
  Select Case c
  Case 0
    Parse = s
    s = Empty
  Case 1
    Parse = Empty
    s = Mid$(s, 2)
  Case Else
    Parse = Mid$(s, 1, c - 1)
    s = Mid$(s, c + 1)
  End Select
End Function

'
' Cerca nella stringa S la stringa F
' Per default la ricerca è CaseSensitive (specificare vbTextCompare per NoCaseSensitive)
' Se la trova restituisce la parte di stringa S che inizia con F (F compresa)
' Se non la trova restituisce una stringa vuota
'
' Find string S into F, search are CaseSensitive (specify vbTextCompare for NoCaseSensitive)
' If found then return part of S that begins at F position (included)
' If not found then return empty string
'
Function TrimBefore(s As String, f As String, Optional vbCompare As VbCompareMethod = vbBinaryCompare) As String
Dim i As Integer
  
  i = InStr(1, s, f, vbCompare)
  If i > 0 Then
    TrimBefore = Mid$(s, i)
  Else
    TrimBefore = Empty
  End If
End Function