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

VBA - TimeredShape with FadeIn - FadeOut effect

Oggi inizio la pubblicaizone di alcune procedure VBA che uso con Excel.
Quella di oggi serve per visualizzare una shape, più spesso una casella di testo, per un tempo determinato con un effetto dissolvenza in entrata e in uscita, un po' come quello della nova mail in arrivo di outlook.

Per il funzionamento di questa procedura servono alcune funzioni:

1. Dichiarare la funzione sleep del kernel, che permetet di definire delle pause in millisecondi senza sprecare cpu.
2. Procedura FadeInOut, che applica l'efeftto dissolvenza, i parametri sono:
   Oggetto shape al quale applicare l'effetto,
   valore Tree/False per indicare rispettivamente FadeIn o FadeOut,
   durata dell'effetto in msec.
3. Funzione rgbLum che applica una luminosità in % ad un colore, i parametri sono:
   R,G,B (colore di base), L luminosità compresa tra 0 e 100
4. Procedura splitRGB traduce nei 3 componenti rgb un colore, i parametri sono:
   l_RGBcolor: colore da trasformare,
   r,g,b: valori in output che conterrano le 3 componenti del colore.

I parametri della procedura principale TimeredShape sono:
Oggetto shape da mostrare;
Tempo di visualizzazione in msec (default 5)
Tempo dell'effetto dissolvenza

[english]
Today I begin the publication of some VBA procedure that I currently use.
TimeredShape is useful for displaying a shape with fadein effect, after waiting for a time in milliseconds hide that with fadeout effect.

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub FadeInOut(s As Shape, _
              Optional bFadeIN As Boolean = True, _
              Optional lDelayMS As Long = 1000)
Dim i As Integer
Dim iBegin As Integer, iEnd As Integer, iStep As Integer
Dim lDelay As Long
Dim l_Trsp As Long                               ' Final Ttransparency / Trasparenza definitiva
Dim l_ForeColor As Long                          ' Border final color / Colore definitivo bordo
Dim bTrasp As Boolean                            ' Trasparenzy are applicable ? / Trasperenza applicabile ?
Const kScala As Integer = 100
  
  lDelay = CLng(lDelayMS / kScala)               ' Calculate step delay /Calcola il ritardo per ogni step
  Dim r As Integer, g As Integer, b As Integer
  
  l_ForeColor = s.Line.ForeColor                 ' Store line color / Determino il colore dell'oggetto
  splitRGB l_ForeColor, r, g, b                  ' Retrieve r,g,b components / Scompongo i valori RGB
  If s.AutoShapeType <> msoShapeMixed Then       ' Aplly only for fillable shape / Applico solo x shape con proprietà Fill
    l_Trsp = s.Fill.Transparency * kScala        ' Store transparency value / Valore Trasparenza dell'oggetto
    bTrasp = True
  Else
    l_Trsp = 0
    bTrasp = False
  End If
    
  If bFadeIN Then                                ' Define Fade paramters / Definisce i parametri per Fade In e Fade Out
    iBegin = kScala
    iEnd = 0
    iStep = -1
  Else
    iBegin = 0
    iEnd = kScala
    iStep = 1
  End If
  lDelay = lDelay * Abs(iStep)                   ' 
    
  s.Line.ForeColor.RGB = rgbLum(r, g, b, iBegin) ' Initialize colour / Inizializzo il colore
  If bTrasp Then
    s.Fill.Transparency = (l_Trsp + (100 - l_Trsp) * iBegin / kScala) / kScala
  End If
  s.Visible = True                               ' Show shape / Mostra l'oggetto
  For i = iBegin To iEnd Step iStep              ' Fade effect / Effetto dissolvenza
    s.Line.ForeColor.RGB = rgbLum(r, g, b, i)    ' Apply color to border line / Applico il colore alla linea del brodo
    If bTrasp Then                               ' Apply transparency / Applico la trasparenza se esiste fill
      s.Fill.Transparency = (l_Trsp + (100 - l_Trsp) * i / kScala) / kScala
    End If
    DoEvents
    Sleep lDelay
  Next i
  s.Visible = bFadeIN                            ' Show/Hide shape / Mostra/Nasconde oggetto
  If bFadeIN = False Then                        
    s.Line.ForeColor.RGB = l_ForeColor           ' Reapply original colour / Riapplico il colore originale
    If bTrasp Then                               ' 
      s.Fill.Transparency = l_Trsp / kScala      ' Reapply original transparency / Riapplico la trasparenza iniziale
    End If
  End If

    
End Sub
'
' Return color with luminance in % 100=White
' Restituisce il colore corrispondente con una luminosità in %  100%=bianco
'
Function rgbLum(r As Integer, g As Integer, b As Integer, l As Integer) As Long
' Red, Green, Blue, Luminance%
  rgbLum = RGB(r + (255 - r) * l / 100, g + (255 - g) * l / 100, b + (255 - b) * l / 100)
End Function
'
' Retrieve RGC colour component from RGB colour
' Scompone un colore RGB nei 3 componenti
'
Sub splitRGB(lRGBcolor As Long, r As Integer, g As Integer, b As Integer)
Dim s As String
  
  s = Right$("000000" & Hex$(lRGBcolor), 6)
  r = Val("&h" & Mid$(s, 1, 2))
  g = Val("&h" & Mid$(s, 3, 2))
  b = Val("&h" & Mid$(s, 5, 2))
End Sub
' ' Display a shape for a time in msec whith fade effect
' Mostra una shape per i millisecondi indicati + il doppio del tempo di dissolvenza indicato
'
Sub TimeredShape(s As Shape, Optional l_DisplayTimeMS As Long = 5000, Optional l_FadeTime As Long = 2000)
  FadeIn s, True, l_FadeTime
  Sleep l_DisplayTimeMS
  FadeInOut s, False, l_FadeTime
End Sub