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

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

Excel VBA - some snippets

Questo post ha il solo scopo di tenere a portata di mano alcune funzioni VBA che uso abbastanza spesso.

This post is only meant to collect some VBA functions that I often use.

'
' Bottom Right corner of range
' Angolo inferiore destro di un range
'
Function LastCellInRange(rRange As Range) As Range
  Set rRange = rRange.Cells(rRange.Rows.cont, Range.Columns.Count)
End Function
'
' Expand Range to non empty row on first column and last column of range
' Espande il range fino alla prima cella non vuota nella prima colonna, e all'ultima colonna del range 
'
Function ExpandRange(rStartRange As Range) As Range

  If rStartRange.Cells(2, 1).empty Then
  ' Range composto da una solo rig
    Set ExpandRange= LastCellInRange(rStartRange)
  Else
    Dim r As Long, c As Integer
    r = rStartRange.Cells(1, 1).End(xlDown).Row
    c = rStartRange.Columns(rStartRange.Columns.Count).Column
    Set ExpandRange= Range(rStartRange.Cells(1, 1), Cells(r, c))
  End If
End Function

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

Javascript Date

ENG: This are some usefull javascript date functions. I know that there are so many and best off that, but are the ones I often use in my job, so I decided to share and put them in convenient place.
In javascript  date variables are objects, assignment are by reference not by value, so you can't simply duplicate variable assigning it's value to another. The cloneDate function duplicates variables of date type.

ITA: Ho voluto raccogliere alcune utili funzioni javascript per la manipolazione delle date. Lo sò che ne esistono tante e migliori di queste, ma sono quelle che uso spesso per il mio lavoro, perciò ho deciso di condividerle e di metterle in posto comodo.
In javascript le date sono degli oggetti, l'assegnazione è per riferimento e non per valore, quindi non è possibile duplicare una variabile data assegnando il valore ad un'atra variabile.
La funzione cloneDate serve appunto per duplicare una variabile di tipo data.

cloneDate = function(d) {
// Duplicate Date Type Variable
  var dd = new Date();
  dd.setTime(d.getTime());
  return(dd);
}
yesterday = function() {
  var dd = new Date();
  dd.setDate(dd.getDate()-1);
  return(dd);
}
tomorrow = function() {
  var dd = new Date();
  dd.setDate(dd.getDate()+1);
  return(dd);
}
roundDo = function(d) {
// Arrotonda alla Domenica precedente
// Round date to the previous Sunday
  var dd = cloneDate(d);
  dd.setDate(dd.getDate() - dd.getDay());
  return(dd);
};
roundLu = function(d) {
// Arrotondo al Lunedì precedente
// Round to the previous Monday
  var dd = cloneDate(d);
  dd.setDate(dd.getDate() - 1);
  dd.setDate(dd.getDate() - dd.getDay() +1);
  return(dd);
};
roundMe = function(d) {
// Arrotondo al Mercoledì precedente
// Round to the previus Wednesday
  var dd = cloneDate(d);
  dd.setDate(dd.getDate() + 4);
  dd.setDate(dd.getDate() - dd.getDay() -4);
  return(dd);
};
roundGi = function(d) {
// Arrotondo al giovendì precedente
// Round to the previuos Thursday
  var dd = cloneDate(d);
  dd.setDate(dd.getDate() + 3);
  dd.setDate(dd.getDate() - dd.getDay() -3);
  return(dd); 
};
roundFirst = function(d) {
// Arrotonda la primo giorno del mese
// Round to the first day of month
  var dd = cloneDate(d);
  dd.setDate(1);
  return(dd); 
};
roundLast = function(d) {
// Arrotonda all'ultimo giorno del mese
// Round to the last day of month
  var dd = cloneDate(d);
  dd.setDate(1);
  dd.setMonth(d.getMonth()+1);
  dd.setDate(0);
  var fmtdd=formatDT(dd);
  var fmtM2=formatDT(dateM2);
  if (date.compare(dd, dateM2) > 0){
    dd=dateM2;
  }
  return(dd); 
};
roundLastCompleteMonth = function() {
// Primo giorno dell'ultimo mese completo 
// First day of the last completed month 
  var d = new Date();
  return(new Date(d.getFullYear(), d.getMonth() - 1, 1));
}; 

Barcode Encoding (CODE128 e EAN)

Barcode Econdig  in pure PL/SQL 
(without CIABAR32.DLL)

This is a little PL/SQL package contain some function for encode barcode for printing using barcode font. It support only EAN and CODE128, the only I use.
Supported font are ean13.ttf, code128.ttf, CIA128 family and CIA EAN family.
Remeber! CIA font are protected by copyright , uses it only you bought them and you cannot use CIABAR32.dll.

Thanks to grandzebu for some pieces of code.

Your comments, corrections and suggestions are always welcome.

Downlaod Souce code

AS_PDF3_V5 new features

AS_PDF3_V5 new features 

Hello everyone, a few days ago I posted the SQL for create PDF document directly from PL/SQL, based on original package by Anton Scheffer.
Now I've added some new features (version 3.5.2):

• Procedure query2table now accept CLOB query fields, treat this as images and locate it into array of cells, using horizontal and vertical alignment and risizing if specified.
• New procedere query2labels that work like query2table but dispose record into multiple columns and rows. The scope is to create sheets with the same label with different contents like a mailing list.
• Begin of multilanguage errore messages (English or Italian).
• Added offsetY parameter to columns format type, it works like offsetX, but obviously acts on the ordered. Used in combination with cellRow and tRowHeight, allows the positioning of each individual field in an independent manner.
• Added a simplified call to query2table and query2label whit colors parameter as a simpliest list of hex rgb colors comma separated,
  for example '000000,e0ffff,000000,000000,ffffff,000000,000000,d0d0d0,000000' .

 2014-11-13. little bugfix on log procedure
 2016-05-11. bugfix on callingh query2table with p_color parameter set to null
 2016-09-06  bugfix in recursive call of write (for text on multiple lines)

comments and corrections, as always, are welcome

Download Ultima versione (0.3.5.11)   Example  Documentation Github

AS_PDF3_V5 nuove funzionalità

Salve a tutti, qualche giorno fa ho postato il codice SQL per creare documenti PDF direttamente da PL/SQL, basato sul package originale di Anton Scheffer.
Ora ho aggiunto alcune nuove funzionalià:

• Procedure query2table: ora la query acetta campi CLOB, li tratta come immagini e li posiziona all'interno della griglia, con la possibilità di allineamento orizzontale, verticale e ridimensionamento se specificato.
• Nuova procedere query2labels: funziona come query2table, ma dispone i record su colonne e righe miltiple. Lo scopo è di realizare fogli di etichette un po' come farebbe un programma di mailing list per la stampa delle etichette indirizzi.
• Inizio della gestione degli errori personalizzati con messaggi in Italiano e Inglese.
• Aggiunto il parametro offsetY al record dei formati colonne, funziona come offsetX, ma ovviamente agisce sulle ordinate. Usato in combinazione con cellRow e tRowHeight, permette di posizionare ogni singolo campo in modo indipendente.
• Aggiunta una chaimata più semplice per  query2table e query2label dove il parametro dei colori è una semplice lista di colori rgb separata da virgol,
  esempi: '000000,e0ffff,000000,000000,ffffff,000000,000000,d0d0d0,000000' .

2014-11-13. lieve bugfix alla procedura di log
2016-05-11. bugfix con parametro p_color null
2016-09-06  bugfix nelle chiamate ricorsive della procedura write (avvengono per il testo su più righe)
Come sempre commenti e correzioni saranno graditi.

Download Last version (0.3.5.11)    Esempio  Documentazione Github


Change Log
-------------------------------------------------------------------------------
** Date: 18-09-2014             Version:  0.3.5.03
**   bugfix and impovement suggested by Giuseppe Polo
**   +query2table               added Interline parameter
**    setCellFont               bugfix for Header
** Date: 26-09-2014             Version:  0.3.5.04
**   bugfix for recursive call of function Write
** Date: 29-09-2014             Version:  0.3.5.05
**   +query2table               added pFrame parameter ex:  'L=2pt; C=FF0000'
**                                       where L=Linesize and C=rgb hex colour
**   +query2table               p_colors also accept CSV string of rgb colours   
**   +set_Language              Set language for erorr messages.
**                                       (English, Italian)
**   +put_image                 add parameters p_cellWidth, p_cellheight
**   +Columns                   can contain blob IMAGE 
**   +FullJustify Alignment     for write and query2table functions
**
** Date: 25-11-2014             Version:  0.3.5.06
**   bugfix for query with more than 200 records
**   +query2table               Add optional parameter p_bulk_size:=200
**   +cursor2table              if = 0 buffer is autodetected,
**                              but query runs 2 times!
** Date: 24-06-2015             Version:  0.3.5.07
**   BugFix query2table         Reset rowHeith when
**                              RowHeight Min or Exacat as specified
** Date: 30-06-2015             Version:  0.3.5.08
**   BugFix PrepareRecord       Fix problem with rowHeight
** Date: 26-08-2015                    Version:  0.3.5.09
**   BugFix colorTable                 Fix problem with undefined collection
**   WARNING! if you change package name, propertly set g_package variabile
** Date: 14-12-2015                    Version:  0.3.5.10
**   Bugix in PrepareRecord
** Date: 11-05-2016                    Version:  0.3.5.11
**   Bugix error when calling with null colours
**   colorTable changed and moved before query2Table
**   query2table & query2label changed
**   when calling query2table you must use empty string '' instead of null for p_colors parameter
**

as_pdv3_v5 (english)

PL/SQL package for create PDF

(versione italiana)
Some time ago I found this package to create PDF documents directly from PL / SQL. During this time I added some features for the creation of reports and today I wanted to publish my work.

Your comments, bug indication, correction of english,  are appreciated.



Thank to Anton Scheffer who made the original package.


Today I've added new features to the procedure query2table, now it accepts blob fields as image and insert it into cell grid, with resizing and alignment, see the NEW POST HERE.

Download my  Lastest vesion  and documentation Github
.


This example create a PDF with breaking on the first field;
it doesn't need table because it uses random data.

-- Created on 25/06/2014 by VALR 
declare 

        i              INTEGER;
        v_vFileName    VARCHAR2(255);
        v_vOddColor    VARCHAR2(6) := 'd0d0d0';
        v_vHeadColor   VARCHAR2(6) := 'e0ffff';
        v_vOraDir      VARCHAR2(50) := 'PDF';
        v_vPageProc    VARCHAR2(32000);
        r_Fmt  as_pdf3_v5.tp_columns:=as_pdf3_v5.tp_columns();
        v_vSQL varchar2(4000);
begin
  v_vFileName    := 'Test_as_pf3_v5.pdf';
  -- Define Sheet Format 
  as_pdf3_v5.init;
  as_pdf3_v5.set_page_format('A4');
  as_pdf3_v5.set_page_orientation('P');
  as_pdf3_v5.set_margins(30, 10, 15, 10, 'mm');
     
  -- Define Header and Footer
  v_vPageProc := q'[
  begin
    §.set_font('helvetica', 'B', 10 );
    §.put_txt('mm',  5, 5, 'Valerio Rossetti');
    §.put_txt('mm',  90, 5, 'Data: ');
    §.set_font('helvetica', 'N', 10);
    §.put_txt('mm', 115,5, ']'||to_char(sysdate,'dd/mm/yy')||q'[');    
    §.put_txt('mm', 175,5, 'Page #PAGE_NR# of #PAGE_COUNT#');
  end;
  ]';
     
  as_pdf3_v5.set_page_proc(v_vPageProc);
  
  --If you use barcode font, remove comment 
  --as_pdf3_v5.load_ttf_font('PDF', 'ean13.ttf', 'CID', TRUE);

    -- Define column format
    begin
      r_fmt.extend(9);
      i:=1; -- (riga di rottura
      r_fmt(i).colWidth:=25;
      r_fmt(i).colLabel:='cod mkt';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='C';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).tAlignment:='L';
      r_fmt(i).tAlignVert:='B';
      r_fmt(i).tFontSize:=8;
      r_fmt(i).tCHeight := 7;
      r_fmt(i).hCHeight := 7;
      r_fmt(i).cellRow := 1;
      
      i:=i+1;--2
      r_fmt(i).colWidth:=20;
      r_fmt(i).colLabel:='cod_art';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='R';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).tAlignVert:='T';
      --r_fmt(i).offsetX := 0;
      r_fmt(i).tCHeight := 7;
      r_fmt(i).hCHeight := 7;
      
      i:=i+1;--3
      r_fmt(i).colWidth:=22;
      r_fmt(i).colLabel:='pz imb';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='C';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).tAlignment:='R';
      r_fmt(i).tAlignVert:='M';
      
      i:=i+1;--4
      r_fmt(i).colWidth:=12;
      r_fmt(i).colLabel:='udm V';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='C';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).tAlignment:='C';
      r_fmt(i).tAlignVert:='B';
      r_fmt(i).tBorder := as_pdf3_v5.BorderType('TB');
      
      i:=i+1;--5
      r_fmt(i).colWidth:=15;
      r_fmt(i).colLabel:='udm Lt';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='C';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).tAlignment:='C';
      r_fmt(i).tAlignVert:='B';
      
      i:=i+1;--6
      r_fmt(i).colWidth:=20;
      r_fmt(i).colLabel:='prz. vend.';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='C';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).tAlignment:='R';
      r_fmt(i).tAlignVert:='B';
      i:=i+1;--7
      r_fmt(i).colWidth:=20;
      r_fmt(i).colLabel:='prz. cost';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='C';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).tAlignment:='R';
      r_fmt(i).tAlignVert:='B';
      i:=i+1;--8
      r_fmt(i).colWidth:=16;
      r_fmt(i).colLabel:='margin';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='C';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).tAlignment:='R';
      r_fmt(i).tAlignVert:='B';
      r_fmt(i).tBorder := 15;
      i:=i+1;--9
      r_fmt(i).colWidth:=150;
      r_fmt(i).colLabel:='product descrition';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='L';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).hCHeight := 8;
      r_fmt(i).tAlignment:='L';
      r_fmt(i).tAlignVert:='C';
      r_fmt(i).tFontSize:=8;
      r_fmt(i).offsetX := 0;
      r_fmt(i).tCHeight := 8;
      r_fmt(i).cellRow:=2;
      r_fmt(i).tBorder := as_pdf3_v5.BorderType('LRBT');

    end;

     v_vSQL := q'[
SELECT cod_mkt,
       c_art, 
       pcs_imb,
       udm_vend,
       udm_list,
       prz_vend,
       prz_vend*.8 prz_cost,
       prz_vend*.2 margin,
       description
from (       
SELECT case when rownum <5 then '5201001' else '5201003' end cod_mkt,
             rownum*1000+rownum*124 c_art, 
             (trunc(rownum/3)+1)*4  pcs_imb,
             'N'  udm_vend,
             'KG' udm_list,
             round(dbms_random.value(40,2),2) prz_vend,
             round(dbms_random.value(8,2),2)  margin,
             'ART '||to_char(rownum*1000+rownum*124) description
        FROM DUAL d CONNECT BY ROWNUM <= 10
)
order by 1
   ]';
   dbms_output.put_line(v_vSQL);
         
   as_pdf3_v5.query2table(v_vSQL,
     r_fmt,
     as_pdf3_v5.tp_colors('000000',v_vHeadColor,'000000',
                          '000000','ffffff','000000', 
                          '000000',v_vOddColor,'000000'),
     15,15, 'mm',0,1
     );
         
    as_pdf3_v5.save_pdf(v_vOraDir, v_vFileName, TRUE);
  END;

as_pdv3_v5 (italiano)

Un package PL/SQL per creare PDF

(english version)
Tempo fa ho trovato questo package per la creazione di documenti PDF direttamente da PL/SQL, con il tempo ho aggiunto alcune funzionalità per la realizzazione di report ed oggi ho voluto pubblicare il mio lavoro.
Ringrazio Anton Scheffer che ha realizzato il package originale.

La versione descritta di questo post è stata corretta ed aggiornata, consultate il nouvo POST per la descrizione delle nuove funzionalità
Download Codice (ultima versione)  e della documentazione.
o meglio consultate il progetto su Github



questo è un esempio per la creazione di un PDF con rottura sul primo campo;
non ha bisogno di tavole perché usa dati casuali.

-- Created on 25/06/2014 by VALR 
declare 

        i              INTEGER;
        v_vFileName    VARCHAR2(255);
        v_vOddColor    VARCHAR2(6) := 'd0d0d0';
        v_vHeadColor   VARCHAR2(6) := 'e0ffff';
        v_vOraDir      VARCHAR2(50) := 'PDF';
        v_vPageProc    VARCHAR2(32000);
        r_Fmt  as_pdf3_v5.tp_columns:=as_pdf3_v5.tp_columns();
        v_vSQL varchar2(4000);
begin
  v_vFileName    := 'Test_as_pf3_v5.pdf';
  -- FORMATTAZZIONE FOGLIO
  as_pdf3_v5.init;
  as_pdf3_v5.set_page_format('A4');
  as_pdf3_v5.set_page_orientation('P');
  as_pdf3_v5.set_margins(30, 10, 15, 10, 'mm');
     
  -- Definisco Intestazione e piede Pagina
  v_vPageProc := q'[
  begin
    §.set_font('helvetica', 'B', 10 );
    §.put_txt('mm',  5, 5, 'Valerio Rossetti');
    §.put_txt('mm',  90, 5, 'Data: ');
    §.set_font('helvetica', 'N', 10);
    §.put_txt('mm', 115,5, ']'||to_char(sysdate,'dd/mm/yy')||q'[');    
    §.put_txt('mm', 175,5, 'Pagina #PAGE_NR# di #PAGE_COUNT#');
  end;
  ]';
     
  as_pdf3_v5.set_page_proc(v_vPageProc);
  
  --Se vuoi usare dei font per i barcode    
  --as_pdf3_v5.load_ttf_font('PDF', 'ean13.ttf', 'CID', TRUE);

    -- Definizione dei formati
    begin
      r_fmt.extend(9);
      i:=1; -- (riga di rottura
      r_fmt(i).colWidth:=25;
      r_fmt(i).colLabel:='cod mkt';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='C';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).tAlignment:='L';
      r_fmt(i).tAlignVert:='B';
      r_fmt(i).tFontSize:=8;
      r_fmt(i).tCHeight := 7;
      r_fmt(i).hCHeight := 7;
      r_fmt(i).cellRow := 1;
      
      i:=i+1;--2
      r_fmt(i).colWidth:=20;
      r_fmt(i).colLabel:='cod_art';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='R';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).tAlignVert:='T';
      --r_fmt(i).offsetX := 0;
      r_fmt(i).tCHeight := 7;
      r_fmt(i).hCHeight := 7;
      
      i:=i+1;--3
      r_fmt(i).colWidth:=22;
      r_fmt(i).colLabel:='pz imb';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='C';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).tAlignment:='R';
      r_fmt(i).tAlignVert:='M';
      
      i:=i+1;--4
      r_fmt(i).colWidth:=12;
      r_fmt(i).colLabel:='udm V';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='C';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).tAlignment:='C';
      r_fmt(i).tAlignVert:='B';
      r_fmt(i).tBorder := as_pdf3_v5.BorderType('TB');
      
      i:=i+1;--5
      r_fmt(i).colWidth:=15;
      r_fmt(i).colLabel:='udm Lt';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='C';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).tAlignment:='C';
      r_fmt(i).tAlignVert:='B';
      
      i:=i+1;--6
      r_fmt(i).colWidth:=20;
      r_fmt(i).colLabel:='prz. vend.';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='C';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).tAlignment:='R';
      r_fmt(i).tAlignVert:='B';
      i:=i+1;--7
      r_fmt(i).colWidth:=20;
      r_fmt(i).colLabel:='prz. costo.';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='C';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).tAlignment:='R';
      r_fmt(i).tAlignVert:='B';
      i:=i+1;--8
      r_fmt(i).colWidth:=16;
      r_fmt(i).colLabel:='margine';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='C';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).tAlignment:='R';
      r_fmt(i).tAlignVert:='B';
      r_fmt(i).tBorder := 15;
      i:=i+1;--9
      r_fmt(i).colWidth:=150;
      r_fmt(i).colLabel:='des.prodotto';
      r_fmt(i).hFontStyle:='B';
      r_fmt(i).hFontSize:=10;
      r_fmt(i).hAlignment:='L';
      r_fmt(i).hAlignVert:='T';
      r_fmt(i).hCHeight := 8;
      r_fmt(i).tAlignment:='L';
      r_fmt(i).tAlignVert:='C';
      r_fmt(i).tFontSize:=8;
      r_fmt(i).offsetX := 0;
      r_fmt(i).tCHeight := 8;
      r_fmt(i).cellRow:=2;
      r_fmt(i).tBorder := as_pdf3_v5.BorderType('LRBT');

    end;

     v_vSQL := q'[
SELECT cod_mkt,
       c_art, 
       pezzi_imb,
       udm_vendita,
       udm_listino,
       prz_vendita,
       prz_vendita*.8 prz_costo,
       prz_vendita*.2 margine,
       descrizione
from (       
SELECT case when rownum <5 then '5201001' else '5201003' end cod_mkt,
             rownum*1000+rownum*124 c_art, 
             (trunc(rownum/3)+1)*4  pezzi_imb,
             'N'  udm_vendita,
             'KG' udm_listino,
             round(dbms_random.value(40,2),2) prz_vendita,
             round(dbms_random.value(8,2),2) margine,
             'ARTICOLO '||to_char(rownum*1000+rownum*124) descrizione
        FROM DUAL d CONNECT BY ROWNUM <= 10
)
order by 1
   ]';
   dbms_output.put_line(v_vSQL);
         
   as_pdf3_v5.query2table(v_vSQL,
     r_fmt,
     as_pdf3_v5.tp_colors('000000',v_vHeadColor,'000000',
                          '000000','ffffff','000000',
                          '000000',v_vOddColor,'000000'),
     15,15, 'mm',0,1
     );
         
    as_pdf3_v5.save_pdf(v_vOraDir, v_vFileName, TRUE);
  END;