File2XL v1.0.7.*Table des procédures 1 - GlobalSuppressions.vb 2 - _modConst.vb 3 - AssemblyInfo.vb 4 - clsFile2XL.vb 4.1 - Private Shared Sub AddField 4.2 - Private Sub AlerteRow 4.3 - Private Sub FindColumnsType 4.4 - Private Sub FindProbDelimiter 4.5 - Private Sub NewLine 4.6 - Private Sub NewSplitLine 4.7 - Private Sub SetCellColor 4.8 - Private Sub SetCellValue 4.9 - Private Sub SetNumericStyle 4.10 - Private Sub SetRowColor 4.11 - Private Sub SetWorkbookStyle 4.12 - Private Sub UpdateMsg 4.13 - Private Sub WriteRow 4.14 - Public Function bRead 4.15 - Public Function bWrite 4.16 - Public Sub FreeMemory 4.17 - Public Sub New 4.18 - Public Sub New 5 - frmFile2XL.vb 5.1 - Private Function bStart 5.2 - Private Shared Sub AddContextMenus 5.3 - Private Shared Sub AddContextMenus 5.4 - Private Shared Sub CreateTestFile 5.5 - Private Shared Sub RemoveContextMenus 5.6 - Private Shared Sub RemoveContextMenus 5.7 - Private Shared Sub WaitCursor 5.8 - Private Sub Activation 5.9 - Private Sub CheckContextMenu 5.10 - Private Sub cmdAddContextMenu_Click 5.11 - Private Sub cmdCancel_Click 5.12 - Private Sub cmdCreateTestFiles_Click 5.13 - Private Sub cmdRemoveContextMenu_Click 5.14 - Private Sub cmdShow_Click 5.15 - Private Sub cmdStart_Click 5.16 - Private Sub frmFile2XL_FormClosing 5.17 - Private Sub frmFile2XL_Shown 5.18 - Private Sub HideContextMenus 5.19 - Private Sub Initialization 5.20 - Private Sub Quit 5.21 - Private Sub SetWaitCursor 5.22 - Private Sub ShowButtons 5.23 - Private Sub ShowLongMessage 5.24 - Private Sub ShowLongMessageDeleg 5.25 - Private Sub ShowMessage 5.26 - Private Sub ShowMessageDeleg 6 - modFile2XLUtil.vb 6.1 - Public Function iNbOccurrences% 7 - clsShowMsg.vb 7.1 - Private Delegate Sub ShowMessageDelegate 7.2 - Public ReadOnly Property bDisable 7.3 - Public ReadOnly Property sMessage$ 7.4 - Public Sub New 7.5 - Public Sub New 7.6 - Public Sub ShowLongMsg 7.7 - Public Sub ShowMsg 7.8 - Public Sub WaitCursor 8 - clsSortDic.vb 8.1 - Protected Sub New 8.2 - Public Function Sort 8.3 - Sub New 9 - modEncoding.vb 9.1 - Private Function CheckUtf16Ascii 9.2 - Private Function CheckUtf8 9.3 - Private Shared Function CheckUtf16NewlineChars 9.4 - Private Shared Function DoesContainNulls 9.5 - Public Function CheckBom 9.6 - Public Function DetectEncoding 9.7 - Public Shared Function GetBomLengthFromEncodingMode 9.8 - Public WriteOnly Property NullSuggestsBinary 9.9 - Public WriteOnly Property Utf16ExpectedNullPercent 9.10 - Public WriteOnly Property Utf16UnexpectedNullPercent 10 - modGenRead.vb 10.1 - Private Sub WaitPause 10.2 - Public Delegate Sub EvHandlerLine 10.3 - Public Function bReadFileGeneric 10.4 - Public Function bReadFileGenericDetectEncoding 10.5 - Public ReadOnly Property sLine$ 10.6 - Public Sub New 10.7 - Public Sub New 10.8 - Public Sub NewSplitLine 11 - modUtil.vb 11.1 - Public Function is64BitProcess 11.2 - Public Function rFastConv# 11.3 - Public Function sRAMInfo$ 11.4 - Public Sub CopyToClipboard 11.5 - Public Sub FreeDotNetRAM 11.6 - Public Sub SetMsgTitle 11.7 - Public Sub ShowErrorMsg 11.8 - Public Sub TruncateChildTextAccordingToControlWidth 12 - modUtilFile.vb 12.1 - Private Function abReadFile 12.2 - Public Function asCmdLineArg 12.3 - Public Function asLines 12.4 - Public Function asReadFile 12.5 - Public Function bDeleteFile 12.6 - Public Function bFileExists 12.7 - Public Function bFileIsAvailable 12.8 - Public Function bFileIsWritable 12.9 - Public Function bFileLocked 12.10 - Public Function bLetOpenFile 12.11 - Public Function bWriteFile 12.12 - Public Function GetEncoding 12.13 - Public Function GetEncodingPreviousVersion 12.14 - Public Function GetEncodingTEC 12.15 - Public Function sDisplayNumeric$ 12.16 - Public Function sDisplaySizeInBytes$ 12.17 - Public Function sDisplayTime$ 12.18 - Public Function StringReadLine$ 12.19 - Public Sub LetOpenFile 12.20 - Public Sub New 12.21 - Public Sub StartAssociateApp 13 - modUtilReg.vb 13.1 - Public Function asCurrentUserRegistrySubKeys 13.2 - Public Function bAddContextMenu 13.3 - Public Function bAddContextMenuFileType 13.4 - Public Function bClassesRootRegistryKeyExists 13.5 - Public Function bClassesRootRegistryKeyExists 13.6 - Public Function bCurrentUserRegistryKeyExists 13.7 - Public Function bLocalMachineRegistryKeyExists 14 - UniversalComparer.vb 14.1 - Public Function Compare 14.2 - Public Function Compare 14.3 - Public Sub New GlobalSuppressions.vb <Assembly: CodeAnalysis.SuppressMessage("Microsoft.Design", "CA2210:AssembliesShouldHaveValidStrongNames")> <Assembly: CodeAnalysis.SuppressMessage("Microsoft.Design", "CA1002:DoNotExposeGenericLists", Scope:="member", Target:="File2XL.clsFile2XL.#m_lstFields")> <Assembly: CodeAnalysis.SuppressMessage("Microsoft.Design", "CA1026:DefaultParametersShouldNotBeUsed", Scope:="member", Target:="File2XL.SortDic`2.#Sort(System.String)")> <Assembly: CodeAnalysis.SuppressMessage("Microsoft.Design", "CA1026:DefaultParametersShouldNotBeUsed", Scope:="member", Target:="File2XL.clsDelegMsg.#WaitCursor(System.Boolean)")> <Assembly: CodeAnalysis.SuppressMessage("Microsoft.Performance", "CA1812:AvoidUninstantiatedInternalClasses", Scope:="type", Target:="File2XL.clsFile2XL+clsFieldType")> <Assembly: CodeAnalysis.SuppressMessage("Microsoft.Performance", "CA1812:AvoidUninstantiatedInternalClasses", Scope:="type", Target:="File2XL.frmFile2XL+clsTest")> ' ' ' Ce fichier est utilisé par l'analyse du code pour tenir à jour les attributs ' SuppressMessage appliqués à ce projet. ' Les suppressions au niveau du projet n'ont pas de cible ou ont ' une cible spécifique et comme portée un espace de noms, un type, un membre etc. ' ' Pour ajouter une suppression à ce fichier, cliquez avec le bouton droit sur le message dans les résultats de l'analyse du code ', pointez sur "Supprimer les messages", puis cliquez sur ' "Dans le fichier de suppression". ' Vous n'avez pas besoin d'ajouter des suppressions à ce fichier manuellement. _modConst.vb ' File modConst.vb ' ---------------- Module _modConst Public Const sAppDate$ = "01/05/2023" '1.06:22/10/2021 1.05:25/01/2019 1.04:05/01/2018 1.03:20/05/2017 1.02:08/05/2017 1.01:16/10/2016 #If DEBUG Then Public Const bDebug As Boolean = True Public Const bRelease As Boolean = False #Else Public Const bDebug As Boolean = False Public Const bRelease As Boolean = True #End If Public ReadOnly sAppVersion$ = My.Application.Info.Version.Major & "." & My.Application.Info.Version.Minor & My.Application.Info.Version.Build Public ReadOnly sAppName$ = My.Application.Info.Title Public ReadOnly sMsgTitle$ = sAppName Public Const iDisplayRate% = 1000 Public Const sMsgDone$ = "Done." Public Const sQuotes$ = """" ' Chr$(34) = " Public Const sQuotesCommaQuotesDelimiter$ = sQuotes & sComma & sQuotes Public Const sQuotesSemiColonQuotesDelimiter$ = sQuotes & ";" & sQuotes Public Const sDot$ = "." Public Const sPeriod$ = sDot Public Const sComma$ = "," Public Const sEmpty$ = "" Public Const sNULL$ = "NULL" ' PhpMyAdmin null value in csv export Public Const sTxtSheet$ = "Text sheet" Public Const sStdrSheet$ = "Standard sheet" Public Const sPostFixWithQuotes$ = "WithQuotes" End Module AssemblyInfo.vb ' File AssemblyInfo.vb ' -------------------- Imports System.Reflection <Assembly: AssemblyTitle("File2XL")> <Assembly: AssemblyDescription("File2XL : Open a csv file into MS-Excel with pre-formatted cells")> <Assembly: AssemblyCompany("ORS Production")> <Assembly: AssemblyProduct("File2XL")> <Assembly: AssemblyCopyright("Copyright © ORS Production 2023")> <Assembly: AssemblyVersion("1.0.7.*")> <Assembly: Runtime.InteropServices.ComVisible(False)> ' CA1017 <Assembly: CLSCompliant(True)> ' CA1014 <Assembly: Resources.NeutralResourcesLanguage("")> ' CA1824 clsFile2XL.vb ' File clsFile2XL.vb : Open a csv file into MS-Excel with pre-formatted cells ' ------------------ Imports System.Text ' For StringBuilder Imports NPOI.XSSF.UserModel ' For XSSFWorkbook, XSSFSheet : Excel 2007 Imports NPOI.HSSF.UserModel ' For HSSFWorkbook, HSSFSheet : Excel 2003 Imports NPOI.HSSF.Model Imports NPOI.SS.Util ' For CellRangeAddress Imports NPOI.SS.UserModel ' For FillPattern Imports NPOI.HSSF.Util ' For HSSFColor Imports System.Runtime.CompilerServices ' For MethodImpl(MethodImplOptions.AggressiveInlining) Imports System.Drawing.Imaging Public Class clsPrm Public sFieldDelimiters$, sDefaultDelimiter$ Public bUseXls As Boolean Public bUseXlsx As Boolean Public bAlertForNoDelimiterFound As Boolean = True Public bUseQuotesCommaQuotesDelimiter As Boolean = True Public bMsgBoxAlert As Boolean = True Public iNbFrozenColumns% Public iNbLinesAnalyzed% Public bCreateStandardSheet As Boolean Public bPreferMultipleDelimiter As Boolean ' For example, prefer "," to , Public bAutosizeColumns As Boolean Public iMinColumnWidth% ' After autozise 20/05/2017 Public iMaxColumnWidth% ' After autozise 20/05/2017 Public bRemoveNULL As Boolean ' Replace PhpMyAdmin NULL by empty 28/04/2017 Public bLogFile As Boolean ' 30/04/2023 End Class Public Class clsFile2XL Public m_bXlsx As Boolean = False Public m_sDestPathXls$, m_sDestPathXlsx$ Public m_bOnlyTextFields As Boolean = True ' Check if there are only text fields or not, and store them here Public m_sb As New StringBuilder Public Const iNbCarMaxCell% = 32767 Public Const iNbLinesMaxExcel2003% = 65536 Public Const iNbLinesMaxExcel2007% = 1048576 Const iNbColMaxExcel2003% = 256 Const iNbColMaxExcel2007% = 16384 'Dim m_iNbColMaxExcel% = iNbColMaxExcel2003 Const iNbColMaxAutoFilterExcel2003NPOI% = 255 ' Bug NPOI : il should be 256 Const sMsgNextColumnsIgnored$ = "(File2XL: Next columns have been ignored)" Const sMsgNextLinesIgnored$ = "(File2XL: Next lines have been ignored)" Dim sMsgNextCarIgnored$ = "(File2XL: " & iNbCarMaxCell & " characters reached, next characters have been ignored) " Dim sMsgMaxCarCell$ = "The number of characters in a cell exceeds" & vbLf & " the maximum allowed (" & iNbCarMaxCell & ")." & vbLf & "Next characters will be ignored." Dim m_sMsgMaxColumns$ = "" Dim m_sMsgMaxLines$ = "" Private WithEvents m_lineDeleg As New clsDelegLine Private m_lines As List(Of String) Private m_wb As HSSFWorkbook, m_sh As HSSFSheet, m_shStdr As HSSFSheet ' Excel 2003 Private m_wbXlsx As XSSFWorkbook, m_shXlsx As XSSFSheet, m_shStdrXlsx As XSSFSheet ' Excel >= 2007 Private m_numericCellStyleXls, m_numericCellStyleXlsx As ICellStyle Private m_iNumLine% Private m_iNbColMaxFound% ' Not used Private m_iNbFilledColMaxFound% Private m_bAlertLineMax, m_bAlertColumnMax, m_bAlertCellTextLengthMax As Boolean Private m_delegMsg As clsDelegMsg Private m_prm As clsPrm Private m_bDetectColumnType As Boolean Private m_splitLines As List(Of List(Of String)) Private m_lstFields As List(Of clsField) #Region "Classes" Private Class clsFieldType Public Const sNumericC2P$ = "NumericC2P" Public Const sNumericP2C$ = "NumericP2C" ' Period to Comma Public Const sNumeric$ = "Numeric" Public Const sNumericWithQuotes$ = "NumericWithQuotes" Public Const sNumericC2PWithQuotes$ = "NumericC2PWithQuotes" Public Const sNumericP2CWithQuotes$ = "NumericP2CWithQuotes" Public Const sText$ = "Text" Public Const sTextWithQuotes$ = "TextWithQuotes" End Class Private Class clsField ' sField and iNumField are used only in debug mode <CodeAnalysis.SuppressMessage("Microsoft.Performance", "CA1823:AvoidUnusedPrivateFields")> Public sField$, iNumField% Public sType$, iNbOcc% Public bCanEndWithMinus As Boolean = False ' Numeric followed by - Public Sub New(iNumField0%, sField0$, sType0$) iNumField = iNumField0 sField = sField0 sType = sType0 iNbOcc = 1 End Sub End Class Private Class clsOcc Public s$ Public iNbOcc%, iOccLength% ' This field is used in sorting using a string, e.g.: "iWeight DESC, iNbOcc DESC, iOccLength DESC" <CodeAnalysis.SuppressMessage("Microsoft.Performance", "CA1823:AvoidUnusedPrivateFields")> Public iWeight% Public Sub New(s0$, iNbOcc0%, bPreferMultipleDelimiter As Boolean) s = s0 iNbOcc = iNbOcc0 iOccLength = s.Length If bPreferMultipleDelimiter Then iWeight = iNbOcc * iOccLength ' Increase the weight as the delimiter length Else iWeight = iNbOcc End If End Sub End Class #End Region Public Function bRead(prm As clsPrm, sPath$, delegMsg As clsDelegMsg) As Boolean If prm Is Nothing Then Return False If delegMsg Is Nothing Then Return False m_prm = prm If Not m_prm.bUseXls AndAlso Not m_prm.bUseXlsx Then If bDebug Then Stop m_prm.bUseXlsx = True End If m_delegMsg = delegMsg m_delegMsg.m_bIgnoreNextLines = False m_delegMsg.m_bCancel = False If Not bFileIsWritable(m_sDestPathXls, bNonExistentOk:=True, bPromptRetry:=True) Then Return False If Not bFileIsWritable(m_sDestPathXlsx, bNonExistentOk:=True, bPromptRetry:=True) Then Return False 'Dim encod = GetEncoding(sPath) ' If encoding is ASCII, set the Latin alphabet to preserve for example accents ' Default = System.Text.SBCSCodePageEncoding = Encoding.GetEncoding(1252) 'If encod Is Encoding.ASCII Then encod = Encoding.Default 'Dim encod = GetEncodingTEC(sPath) ' 15/07/2022 Dim encod As Encoding = Nothing ' 29/04/2023 Force detectEncodingFromByteOrderMarks version 'm_sb = New StringBuilder delegMsg.ShowMsg("Reading first lines...") m_lines = New List(Of String) Dim bHeader As Boolean Dim iNbLines% = 0 Dim iNbColumns% = 0 Dim sFieldDelimiter$ = String.Empty If Not bReadFileGeneric(sFieldDelimiter, bHeader, sPath, m_lineDeleg, delegMsg, iNbLines, iNbColumns, bOnlyFirstLines:=True, encod:=encod, iNbLinesAnalyzed:=prm.iNbLinesAnalyzed) Then Return False delegMsg.ShowLongMsg("") delegMsg.ShowMsg("Searching probable delimiter...") FindProbDelimiter(prm.sFieldDelimiters, prm.sDefaultDelimiter, sFieldDelimiter) ' Detecting column type m_splitLines = New List(Of List(Of String)) m_bDetectColumnType = True If Not bReadFileGeneric(sFieldDelimiter, bHeader, sPath, m_lineDeleg, delegMsg, iNbLines, iNbColumns, bOnlyFirstSplitLines:=True, encod:=encod, iNbLinesAnalyzed:=prm.iNbLinesAnalyzed) Then Return False m_bDetectColumnType = False delegMsg.ShowMsg("Searching columns type...") FindColumnsType(m_lstFields, m_bOnlyTextFields, delegMsg) If m_bOnlyTextFields Then m_prm.bCreateStandardSheet = False delegMsg.ShowMsg("Initializing Excel library...") ' Read the file using the probable delimiter now m_bXlsx = False : If Not m_prm.bUseXls Then m_bXlsx = True UpdateMsg() If m_prm.bUseXls Then m_wb = HSSFWorkbook.Create(InternalWorkbook.CreateWorkbook()) ' Excel 2003 m_sh = DirectCast(m_wb.CreateSheet(sTxtSheet), HSSFSheet) m_sh.CreateFreezePane(prm.iNbFrozenColumns, 1) If m_prm.bCreateStandardSheet Then m_shStdr = DirectCast(m_wb.CreateSheet(sStdrSheet), HSSFSheet) m_shStdr.CreateFreezePane(prm.iNbFrozenColumns, 1) SetNumericStyle(m_numericCellStyleXls, bExcel2007:=False) End If End If If m_prm.bUseXlsx Then m_wbXlsx = New XSSFWorkbook ' Excel 2007 m_shXlsx = DirectCast(m_wbXlsx.CreateSheet(sTxtSheet), XSSFSheet) m_shXlsx.CreateFreezePane(prm.iNbFrozenColumns, 1) If m_prm.bCreateStandardSheet Then m_shStdrXlsx = DirectCast(m_wbXlsx.CreateSheet(sStdrSheet), XSSFSheet) m_shStdrXlsx.CreateFreezePane(prm.iNbFrozenColumns, 1) SetNumericStyle(m_numericCellStyleXlsx, bExcel2007:=True) End If End If delegMsg.ShowMsg("Filling workbook...") m_bAlertLineMax = False : m_bAlertColumnMax = False : m_bAlertCellTextLengthMax = False ' From 10 Mb read line by line Dim lFileSize& = New IO.FileInfo(sPath).Length Dim bLineByLine As Boolean = False If lFileSize > iBigFileSizeMb Then bLineByLine = True If Not bReadFileGeneric(sFieldDelimiter, bHeader, sPath, m_lineDeleg, delegMsg, iNbLines, iNbColumns, encod:=encod, bLineByLine:=bLineByLine) Then Return False Dim bRes = bWrite() Return bRes End Function Public Sub FreeMemory() m_wb = Nothing : m_sh = Nothing m_wbXlsx = Nothing : m_shXlsx = Nothing End Sub Private Sub SetNumericStyle(ByRef style As ICellStyle, bExcel2007 As Boolean) Dim format As IDataFormat If bExcel2007 Then style = m_wbXlsx.CreateCellStyle format = m_wbXlsx.CreateDataFormat() Else style = m_wb.CreateCellStyle format = m_wb.CreateDataFormat() End If style.DataFormat = format.GetFormat("0") End Sub Public Function bWrite() As Boolean Dim sPath$ = Nothing m_delegMsg.ShowLongMsg("") m_delegMsg.ShowMsg("Checking Excel file...") Dim iNumColMax% = m_iNbFilledColMaxFound - 1 If m_bXlsx Then sPath = m_sDestPathXlsx ElseIf m_prm.bUseXls Then sPath = m_sDestPathXls End If If Not bFileIsWritable(sPath, bNonExistentOk:=True, bPromptRetry:=True) Then Return False m_delegMsg.ShowMsg("Checking columns type...") If m_bXlsx Then If iNumColMax > iNbColMaxExcel2007 - 1 Then iNumColMax = iNbColMaxExcel2007 - 1 SetWorkbookStyle(iNumColMax, bExcel2007:=True) ElseIf m_prm.bUseXls Then If iNumColMax > iNbColMaxAutoFilterExcel2003NPOI - 1 Then _ iNumColMax = iNbColMaxAutoFilterExcel2003NPOI - 1 SetWorkbookStyle(iNumColMax, bExcel2007:=False) End If m_delegMsg.ShowMsg("Writing workbook " & IO.Path.GetFileName(sPath) & "...") Try Using fs = New IO.FileStream(sPath, IO.FileMode.Create, IO.FileAccess.Write) If m_bXlsx Then m_wbXlsx.Write(fs) Else ' Name conflicts with _FilterDatabase ' (_FilterDatabase: The name must not be identical to a predefined name) 'm_wb.Names.Item("_FilterDatabase").Delete() 'm_wb.RemoveName("_FilterDatabase") ' ToDo : check if a new version of NPOI is available (retry NuGet package ?) m_wb.Write(fs) End If End Using Catch ex As Exception m_delegMsg.ShowMsg("Error : Can't write the workbok !") ShowErrorMsg(ex, "File2XL : writing workbook", "Can't write the file : " & IO.Path.GetFileName(sPath) & vbCrLf & sPath, sPossibleErrCause) Return False End Try m_delegMsg.ShowMsg(sMsgDone) Return True End Function Private Sub SetWorkbookStyle(iNumColMax%, bExcel2007 As Boolean) If iNumColMax < 0 Then Exit Sub ' Set header to gray Dim range As New CellRangeAddress(0, 0, 0, iNumColMax) Dim row0 As IRow Dim iNbColMax% If bExcel2007 Then m_shXlsx.SetAutoFilter(range) row0 = m_shXlsx.GetRow(0) iNbColMax = iNbColMaxExcel2007 Else m_sh.SetAutoFilter(range) row0 = m_sh.GetRow(0) iNbColMax = iNbColMaxExcel2003 End If Dim dTimeStart = Now() For iNumField1 As Integer = 0 To m_lstFields.Count - 1 If iNumField1 > row0.Cells.Count - 1 AndAlso iNumField1 < iNbColMax - 1 Then _ row0.CreateCell(iNumField1) Next Dim dTimeEnd = Now() Dim ts = dTimeEnd - dTimeStart Dim sMsg$ = "Time (sec) for CreateCell: " & ts.TotalSeconds.ToString("0.000") If bDebug Then Debug.WriteLine(sMsg) m_sb.AppendLine(sMsg) dTimeStart = Now() SetRowColor(row0, HSSFColor.Grey25Percent.Index, bExcel2007) dTimeEnd = Now() ts = dTimeEnd - dTimeStart sMsg = "Time (sec) for SetRowColor: " & ts.TotalSeconds.ToString("0.000") If bDebug Then Debug.WriteLine(sMsg) m_sb.AppendLine(sMsg) Dim rTime# = 0 Dim iMinColumnWidth% = m_prm.iMinColumnWidth Dim iMaxColumnWidth% = m_prm.iMaxColumnWidth Const iDisplayRate = 10 Dim iNumField0% = 0 Dim iNbFields0% = row0.Cells.Count For Each field In m_lstFields iNumField0 += 1 If field.sType.StartsWith(clsFieldType.sNumeric, StringComparison.Ordinal) Then ' Color header If iNumField0 <= iNbFields0 Then SetCellColor(row0.Cells(iNumField0 - 1), HSSFColor.BrightGreen.Index, bExcel2007) If m_prm.bAutosizeColumns Then If iNumField0 Mod iDisplayRate = 0 OrElse iNumField0 = iNbFields0 Then m_delegMsg.ShowMsg("Text sheet : Autosizing column n°" & iNumField0 & "/" & iNbFields0 & "...") If m_delegMsg.m_bCancel Then m_delegMsg.m_bCancel = False : Exit For End If If m_delegMsg.m_bCancel Then m_delegMsg.m_bCancel = False : Exit For ' Set same column width on text sheet If bExcel2007 Then m_shXlsx.AutoSizeColumn(iNumField0 - 1) ' AutoFit ' 20/05/2017 Dim iColWTxt% = m_shXlsx.GetColumnWidth(iNumField0 - 1) If iColWTxt < iMinColumnWidth Then iColWTxt = iMinColumnWidth m_shXlsx.SetColumnWidth(iNumField0 - 1, iColWTxt) End If If iColWTxt > iMaxColumnWidth Then iColWTxt = iMaxColumnWidth m_shXlsx.SetColumnWidth(iNumField0 - 1, iColWTxt) End If If m_prm.bCreateStandardSheet Then _ m_shStdrXlsx.SetColumnWidth(iNumField0 - 1, iColWTxt) Else dTimeStart = Now() m_sh.AutoSizeColumn(iNumField0 - 1) ' AutoFit dTimeEnd = Now() ts = dTimeEnd - dTimeStart rTime += ts.TotalSeconds ' 20/05/2017 Dim iColWTxt% = m_sh.GetColumnWidth(iNumField0 - 1) 'Debug.WriteLine("iColWTxt(" & iNumField0 & ")=" & iColWTxt) If iColWTxt < iMinColumnWidth Then iColWTxt = iMinColumnWidth m_sh.SetColumnWidth(iNumField0 - 1, iColWTxt) End If If iColWTxt > iMaxColumnWidth Then iColWTxt = iMaxColumnWidth m_sh.SetColumnWidth(iNumField0 - 1, iColWTxt) End If If m_prm.bCreateStandardSheet Then _ m_shStdr.SetColumnWidth(iNumField0 - 1, iColWTxt) End If End If End If End If Next ' Time (sec) for AutoSizeColumn: ' -- for NPOI 1.2.5 Nuget 29/07/2012 (no Excel 2007 support) ' 39.174 for NPOI 2.0.6 Nuget 12/04/2014 ' 42.800 for NPOI 2.1.3 Nuget 31/12/2014 ' 45.601 for NPOI 2.1.3.1 Dll net40 23/02/2015 https://www.nuget.org/packages/NPOI/2.1.3.1 ' 38.790 for NPOI 2.1.3.1 Nuget 23/02/2015 https://www.nuget.org/packages/NPOI/2.1.3.1 ' 3.934 for NPOI 2.2.1 Nuget 31/05/2016 ' 5.121 for NPOI 2.2.1.0 Dll net20 01/06/2016 https://www.nuget.org/packages/NPOI/2.2.1 ' 4.888 for NPOI 2.2.1.0 Dll net40 01/06/2016 https://www.nuget.org/packages/NPOI/2.2.1 ' 0.034 for NPOI 2.2.1.1 Dll act 05/06/2016 Optimized version: maxRows for GetColumnWidth ' 3.760 for NPOI 2.5.5 Nuget 24/10/2021 https://www.nuget.org/packages/NPOI/2.5.5 ' 3.517 for NPOI 1.2.3 Nuget 24/11/2020 https://www.nuget.org/packages/DotNetCore.NPOI/1.2.3 sMsg = "Time (sec) for AutoSizeColumn: " & rTime.ToString("0.000") If bDebug Then Debug.WriteLine(sMsg) m_sb.AppendLine(sMsg) If m_prm.bCreateStandardSheet Then If bExcel2007 Then m_shStdrXlsx.SetAutoFilter(range) row0 = m_shStdrXlsx.GetRow(0) Else m_shStdr.SetAutoFilter(range) row0 = m_shStdr.GetRow(0) End If For iNumField1 As Integer = 0 To m_lstFields.Count - 1 If iNumField1 > row0.Cells.Count - 1 AndAlso iNumField1 < iNbColMax - 1 Then _ row0.CreateCell(iNumField1) Next SetRowColor(row0, HSSFColor.Grey25Percent.Index, bExcel2007) Dim iNumField% = 0 Dim iNbFields% = row0.Cells.Count For Each field In m_lstFields Dim iMemNumField% = iNumField iNumField += 1 If field.sType.StartsWith(clsFieldType.sNumeric, StringComparison.Ordinal) Then ' Color header If iNumField <= iNbFields Then SetCellColor(row0.Cells(iMemNumField), HSSFColor.BrightGreen.Index, bExcel2007) If m_prm.bAutosizeColumns Then If iNumField Mod iDisplayRate = 0 OrElse iNumField = iNbFields Then m_delegMsg.ShowMsg("Standard sheet : Autosizing column n°" & iNumField & "...") If m_delegMsg.m_bCancel Then m_delegMsg.m_bCancel = False : Exit For End If ' Set same column width on text sheet If bExcel2007 Then m_shStdrXlsx.AutoSizeColumn(iMemNumField) ' AutoFit Dim iColWStdr% = m_shStdrXlsx.GetColumnWidth(iMemNumField) Dim iColWTxt% = m_shXlsx.GetColumnWidth(iMemNumField) Dim bResizeStdr As Boolean = False Dim bResizeTxt As Boolean = False If iColWStdr > iMaxColumnWidth Then iColWStdr = iMaxColumnWidth : bResizeStdr = True If iColWTxt > iMaxColumnWidth Then iColWTxt = iMaxColumnWidth : bResizeTxt = True If iColWStdr < iMinColumnWidth Then iColWStdr = iMinColumnWidth : bResizeStdr = True If iColWTxt < iMinColumnWidth Then iColWTxt = iMinColumnWidth : bResizeTxt = True If iColWTxt < iColWStdr Then 'm_shXlsx.SetColumnWidth(iMemNumField, iColWStdr) iColWTxt = iColWStdr bResizeTxt = True ElseIf iColWTxt > iColWStdr Then 'm_shStdrXlsx.SetColumnWidth(iMemNumField, iColWTxt) iColWStdr = iColWTxt bResizeStdr = True End If If bResizeTxt Then m_shXlsx.SetColumnWidth(iMemNumField, iColWTxt) If bResizeStdr Then m_shStdrXlsx.SetColumnWidth(iMemNumField, iColWStdr) Else m_shStdr.AutoSizeColumn(iMemNumField) ' AutoFit Dim iColWStdr% = m_shStdr.GetColumnWidth(iMemNumField) Dim iColWTxt% = m_sh.GetColumnWidth(iMemNumField) 'Debug.WriteLine("iColWStdr(" & iNumField0 & ")=" & iColWStdr) 'Debug.WriteLine("iColWTxt(" & iNumField0 & ")=" & iColWTxt) Dim bResizeStdr As Boolean = False Dim bResizeTxt As Boolean = False If iColWStdr > iMaxColumnWidth Then iColWStdr = iMaxColumnWidth : bResizeStdr = True If iColWTxt > iMaxColumnWidth Then iColWTxt = iMaxColumnWidth : bResizeTxt = True If iColWStdr < iMinColumnWidth Then iColWStdr = iMinColumnWidth : bResizeStdr = True If iColWTxt < iMinColumnWidth Then iColWTxt = iMinColumnWidth : bResizeTxt = True If iColWTxt < iColWStdr Then 'm_sh.SetColumnWidth(iMemNumField, iColWStdr) iColWTxt = iColWStdr bResizeTxt = True ElseIf iColWTxt > iColWStdr Then 'm_shStdr.SetColumnWidth(iMemNumField, iColWTxt) iColWStdr = iColWTxt bResizeStdr = True End If If bResizeTxt Then m_sh.SetColumnWidth(iMemNumField, iColWTxt) If bResizeStdr Then m_shStdr.SetColumnWidth(iMemNumField, iColWStdr) End If End If End If End If Next If bExcel2007 Then m_wbXlsx.SetSelectedTab(1) m_wbXlsx.SetActiveSheet(1) Else m_wb.SetSelectedTab(1) m_wb.SetActiveSheet(1) End If End If End Sub Private Sub UpdateMsg() Dim iNbColMaxExcel% = iNbColMaxExcel2003 Dim iNbLinesMaxExcel% = iNbLinesMaxExcel2003 If m_bXlsx Then iNbColMaxExcel = iNbColMaxExcel2007 iNbLinesMaxExcel = iNbLinesMaxExcel2007 End If m_sMsgMaxColumns = "The number of columns exceeds the maximum allowed (" & iNbColMaxExcel & ")." & vbLf & "Next columns will be ignored." m_sMsgMaxLines = "The number of lines exceeds the maximum allowed (" & iNbLinesMaxExcel & ")." & vbLf & "Next lines will be ignored." End Sub Private Sub NewSplitLine(sender As Object, e As clsSplitLineEventArgs) _ Handles m_lineDeleg.EvNewSplitLine If m_bDetectColumnType Then Dim lstFields = New List(Of String) For Each sField In e.m_asFields lstFields.Add(sField) Next m_splitLines.Add(lstFields) Exit Sub End If ' Fill Excel workbook If m_iNumLine >= iNbLinesMaxExcel2003 Then If Not m_bAlertLineMax Then If Not m_prm.bUseXlsx AndAlso m_prm.bUseXls Then Dim row0 = m_sh.GetRow(iNbLinesMaxExcel2003 - 1) AlerteRow(row0, bExcel2007:=False) Dim row1 = m_shStdr.GetRow(iNbLinesMaxExcel2003 - 1) AlerteRow(row1, bExcel2007:=False) Else m_bXlsx = True : UpdateMsg() End If End If If Not m_prm.bUseXlsx Then Exit Sub End If If m_iNumLine >= iNbLinesMaxExcel2007 Then If Not m_bAlertLineMax Then Dim row0 = m_shXlsx.GetRow(iNbLinesMaxExcel2007 - 1) AlerteRow(row0, bExcel2007:=True) Dim row1 = m_shStdrXlsx.GetRow(iNbLinesMaxExcel2007 - 1) AlerteRow(row1, bExcel2007:=True) End If Exit Sub End If Dim iNbCol% = e.m_asFields.Count If iNbCol > m_iNbColMaxFound Then m_iNbColMaxFound = iNbCol Dim row As IRow If m_prm.bUseXlsx Then row = m_shXlsx.CreateRow(m_iNumLine) WriteRow(row, e.m_asFields, iNbColMaxExcel2007, bExcel2007:=True) If m_prm.bCreateStandardSheet Then row = m_shStdrXlsx.CreateRow(m_iNumLine) WriteRow(row, e.m_asFields, iNbColMaxExcel2007, bExcel2007:=True, bConv:=True) End If End If If m_prm.bUseXls AndAlso Not m_bXlsx Then row = m_sh.CreateRow(m_iNumLine) WriteRow(row, e.m_asFields, iNbColMaxExcel2003, bExcel2007:=False) If m_prm.bCreateStandardSheet Then row = m_shStdr.CreateRow(m_iNumLine) WriteRow(row, e.m_asFields, iNbColMaxExcel2003, bExcel2007:=False, bConv:=True) End If End If m_iNumLine += 1 End Sub Private Sub AlerteRow(row0 As IRow, bExcel2007 As Boolean) 'Dim val = row0.Cells(0) 'Dim sCellVal$ = " " & val.StringCellValue ' 05/06/2016 Exception with NPOI 2.2.1.0 ! 'Dim sCellVal$ = " " & val.RichStringCellValue.String ' Idem Dim sCellVal$ = "" ' 05/06/2016 SetCellValue(row0.Cells(0), sMsgNextLinesIgnored & sCellVal, bExcel2007) SetCellColor(row0.Cells(0), HSSFColor.Orange.Index, bExcel2007) If Not m_bAlertLineMax Then m_bAlertLineMax = True If m_prm.bMsgBoxAlert Then MsgBox(m_sMsgMaxLines, vbExclamation, m_sMsgTitle) End If m_delegMsg.m_bIgnoreNextLines = True End Sub Private Sub WriteRow(row As IRow, asFields$(), iNbColMaxExcel%, bExcel2007 As Boolean, Optional bConv As Boolean = False) Dim iNumField% = 0 For Each sField In asFields If m_prm.bUseXlsx AndAlso iNumField > iNbColMaxExcel2003 - 1 Then If Not m_bXlsx Then m_bXlsx = True : UpdateMsg() If Not bExcel2007 Then Exit Sub End If If iNumField > iNbColMaxExcel - 1 Then 'Dim val = row.Cells(iNumField - 1) 'Dim sCellVal$ = " " & val.StringCellValue ' 05/06/2016 Exception with NPOI 2.2.1.0 ! 'Dim sCellVal$ = " " & val.RichStringCellValue.String ' 05/06/2016 Idem Dim sCellVal$ = "" ' 05/06/2016 SetCellValue(row.Cells(iNumField - 1), sMsgNextColumnsIgnored & sCellVal, bExcel2007) SetCellColor(row.Cells(iNumField - 1), HSSFColor.Orange.Index, bExcel2007) If m_prm.bMsgBoxAlert AndAlso Not m_bAlertColumnMax Then MsgBox(m_sMsgMaxColumns, vbExclamation, m_sMsgTitle) m_bAlertColumnMax = True End If Exit For End If row.CreateCell(iNumField) ' Remove NULL value only for the Standard sheet (bConv = True), not for the Text sheet (bConv = False) If m_prm.bRemoveNULL AndAlso bConv AndAlso sField = sNULL Then sField = "" ' 28/04/2017 Dim bValue As Boolean = False If sField.Length > 0 Then bValue = True If bValue Then If bConv AndAlso iNumField < m_lstFields.Count Then Dim field = m_lstFields(iNumField) If field.sType = clsFieldType.sText Then If row.RowNum = 0 Then SetCellValue(row.Cells(iNumField), sField.Replace(sQuotes, sEmpty), bExcel2007) Else SetCellValue(row.Cells(iNumField), sField, bExcel2007) End If ElseIf field.sType = clsFieldType.sTextWithQuotes Then SetCellValue(row.Cells(iNumField), sField.Replace(sQuotes, sEmpty), bExcel2007) Else Dim sFieldConv$ Select Case field.sType Case clsFieldType.sNumeric : sFieldConv = sField Case clsFieldType.sNumericC2P : sFieldConv = sField.Replace(sComma, sPeriod) Case clsFieldType.sNumericP2C : sFieldConv = sField.Replace(sPeriod, sComma) Case clsFieldType.sNumericWithQuotes : sFieldConv = sField.Replace(sQuotes, sEmpty) Case clsFieldType.sNumericC2PWithQuotes : sFieldConv = sField.Replace(sComma, sPeriod).Replace(sQuotes, sEmpty) Case clsFieldType.sNumericP2CWithQuotes : sFieldConv = sField.Replace(sPeriod, sComma).Replace(sQuotes, sEmpty) Case Else : sFieldConv = sField End Select Dim iMult% = 1 If field.bCanEndWithMinus Then Dim sFieldTrim$ = sField.Trim If sFieldTrim.EndsWith("-", StringComparison.Ordinal) Then sFieldConv = sFieldTrim.Substring(0, sFieldTrim.Length - 1) iMult = -1 End If End If Dim bOk As Boolean Dim rVal# = iMult * rFastConv(sFieldConv, , bOk) If bOk Then row.Cells(iNumField).SetCellValue(rVal) If bExcel2007 Then row.Cells(iNumField).CellStyle = m_numericCellStyleXlsx Else row.Cells(iNumField).CellStyle = m_numericCellStyleXls End If Else ' Header fields If field.sType.EndsWith(sPostFixWithQuotes, StringComparison.Ordinal) Then SetCellValue(row.Cells(iNumField), sField.Replace(sQuotes, sEmpty), bExcel2007) Else SetCellValue(row.Cells(iNumField), sField, bExcel2007) End If End If End If Else SetCellValue(row.Cells(iNumField), sField, bExcel2007) End If End If iNumField += 1 If bValue AndAlso iNumField > m_iNbFilledColMaxFound Then m_iNbFilledColMaxFound = iNumField Next End Sub Private Sub NewLine(sender As Object, e As clsLineEventArgs) Handles m_lineDeleg.EvNewLine m_lines.Add(e.sLine) End Sub ' Attribute for inline to avoid function overhead <MethodImpl(MethodImplOptions.AggressiveInlining)> Private Sub SetCellValue(cell As ICell, sValue$, bExcel2007 As Boolean) Const bReplaceTab As Boolean = False ' This constant may be a setting in a next release If bReplaceTab AndAlso sValue.IndexOf(vbTab) > -1 Then sValue = sValue.Replace(vbTab, " ") End If If sValue.Length <= iNbCarMaxCell Then cell.SetCellValue(sValue) Else Dim iNbCar% = iNbCarMaxCell - sMsgNextCarIgnored.Length Dim sTruncVal$ = sMsgNextCarIgnored & sValue.Substring(0, iNbCar) cell.SetCellValue(sTruncVal) SetCellColor(cell, HSSFColor.Orange.Index, bExcel2007) If m_prm.bMsgBoxAlert AndAlso Not m_bAlertCellTextLengthMax Then MsgBox(sMsgMaxCarCell, vbExclamation, m_sMsgTitle) m_bAlertCellTextLengthMax = True End If End If End Sub Private Sub SetRowColor(row As IRow, indexColor As Short, bExcel2007 As Boolean) If IsNothing(row) Then If bDebug Then Stop Exit Sub End If Const iColMin% = 0 Dim iColMax% = row.LastCellNum Dim style As ICellStyle If bExcel2007 Then style = m_wbXlsx.CreateCellStyle Else style = m_wb.CreateCellStyle End If style.FillForegroundColor = indexColor style.FillPattern = FillPattern.SolidForeground For i = iColMin To iColMax - 1 Dim cell = row.GetCell(i) cell.CellStyle = style Next End Sub Private Sub SetCellColor(cell As ICell, indexColor As Short, bExcel2007 As Boolean) If IsNothing(cell) Then If bDebug Then Stop Exit Sub End If Dim style As ICellStyle If bExcel2007 Then style = m_wbXlsx.CreateCellStyle Else style = m_wb.CreateCellStyle End If style.FillForegroundColor = indexColor style.FillPattern = FillPattern.SolidForeground cell.CellStyle = style End Sub Private Sub FindProbDelimiter(sDelimiterList$, sDefaultDelimiter$, ByRef sFieldDelimiter$) Const bDebugSort As Boolean = False 'If m_prm.bLogFile Then bDebugSort = True Dim sb As New StringBuilder If m_prm.bLogFile Then Dim sMsg$ = "PreferMultipleDelimiter = " & m_prm.bPreferMultipleDelimiter Debug.WriteLine(sMsg) sb.AppendLine(sMsg) End If sFieldDelimiter = String.Empty Dim acDelimiters = sDelimiterList.ToCharArray Dim dicStat As New SortDic(Of String, clsOcc) For Each c In acDelimiters Dim s$ = c dicStat.Add(s, New clsOcc(s, 0, m_prm.bPreferMultipleDelimiter)) ' Count succes Next ' Count also "," and ";" if required ' 16/04/2017 AndAlso m_prm.bPreferMultipleDelimiter If m_prm.bUseQuotesCommaQuotesDelimiter AndAlso m_prm.bPreferMultipleDelimiter Then dicStat.Add(sQuotesCommaQuotesDelimiter, New clsOcc(sQuotesCommaQuotesDelimiter, 0, m_prm.bPreferMultipleDelimiter)) dicStat.Add(sQuotesSemiColonQuotesDelimiter, New clsOcc(sQuotesSemiColonQuotesDelimiter, 0, m_prm.bPreferMultipleDelimiter)) End If Const sSorting = "iWeight DESC, iNbOcc DESC, iOccLength DESC" ' Fields of clsOcc Dim iNumLine% = 0 For Each sLine In m_lines iNumLine += 1 Dim dic As New SortDic(Of String, clsOcc) For Each c In acDelimiters Dim s$ = c Dim iNbOcc% = iNbOccurrences(sLine, s) If dic.ContainsKey(s) Then Continue For dic.Add(s, New clsOcc(s, iNbOcc, m_prm.bPreferMultipleDelimiter)) Next ' 16/04/2017 AndAlso m_prm.bPreferMultipleDelimiter If m_prm.bUseQuotesCommaQuotesDelimiter AndAlso m_prm.bPreferMultipleDelimiter Then Dim iNbOcc% = iNbOccurrences(sLine, sQuotesCommaQuotesDelimiter) If Not dic.ContainsKey(sQuotesCommaQuotesDelimiter) Then dic.Add(sQuotesCommaQuotesDelimiter, New clsOcc(sQuotesCommaQuotesDelimiter, iNbOcc, m_prm.bPreferMultipleDelimiter)) End If Dim iNbOcc2% = iNbOccurrences(sLine, sQuotesSemiColonQuotesDelimiter) If Not dic.ContainsKey(sQuotesSemiColonQuotesDelimiter) Then dic.Add(sQuotesSemiColonQuotesDelimiter, New clsOcc(sQuotesSemiColonQuotesDelimiter, iNbOcc2, m_prm.bPreferMultipleDelimiter)) End If End If If bDebugSort Then Dim sMsg$ = "Result line n°" & iNumLine & " :" Debug.WriteLine(sMsg) sb.AppendLine(sMsg) End If Dim iNumSep% = 0 ' First sort by number of occurrences, then by occurrence length, so that "," can win against , For Each occ In dic.Sort(sSorting) If bDebugSort Then Dim sMsg$ = occ.s & "=" & occ.iNbOcc & " (" & occ.iOccLength & " car.)" Debug.WriteLine(sMsg) sb.AppendLine(sMsg) End If If iNumSep = 0 AndAlso occ.iNbOcc > 0 Then dicStat(occ.s).iNbOcc += 1 iNumSep += 1 Next Next If m_prm.bLogFile Then Dim sMsg$ = "Probable delimiter detection results:" If bDebugSort Then Debug.WriteLine("") : Debug.WriteLine("") Debug.WriteLine(sMsg) If bDebugSort Then sb.AppendLine() : sb.AppendLine() sb.AppendLine(sMsg) End If Dim sProb$ = String.Empty Dim iNumSep2% = 0 For Each occ In dicStat.Sort(sSorting) If m_prm.bLogFile Then Dim sMsg$ = occ.s & "=" & occ.iNbOcc & " wins / " & m_lines.Count Debug.WriteLine(sMsg) sb.AppendLine(sMsg) End If If iNumSep2 = 0 AndAlso occ.iNbOcc > 0 Then sProb = occ.s ' Keep the winner iNumSep2 += 1 Next If sProb = sQuotesCommaQuotesDelimiter OrElse sProb = sQuotesSemiColonQuotesDelimiter Then sFieldDelimiter = sProb Else If sProb = String.Empty Then If m_prm.bLogFile Then Dim sMsg$ = "No delimiter found" Debug.WriteLine(sMsg) sb.AppendLine(sMsg) End If If m_prm.bAlertForNoDelimiterFound Then Dim sMsg$ = "No delimiter found !" If Not String.IsNullOrEmpty(sDefaultDelimiter) Then sMsg &= vbLf & "Default delimiter will be use : [" & sDefaultDelimiter & "]" End If MsgBox(sMsg, MsgBoxStyle.Exclamation, m_sMsgTitle) End If sProb = sDefaultDelimiter End If sFieldDelimiter = sProb End If If m_prm.bLogFile Then Me.m_sb.Append(sb) End Sub Private Sub FindColumnsType(ByRef lstFields As List(Of clsField), ByRef bOnlyTextFields As Boolean, delegMsg As clsDelegMsg) Const bDebugColType As Boolean = False bOnlyTextFields = True Dim lstFields0 As New List(Of SortDic(Of String, clsField)) Dim lstNameOfFields As New List(Of String) Dim lstMinusExistsForFields As New List(Of Boolean) Dim rTime# = 0 Dim iNumLine% = 0 For Each sLine In m_splitLines delegMsg.ShowMsg("Searching columns type... " & iNumLine + 1 & "/" & m_splitLines.Count) If delegMsg.m_bCancel Then delegMsg.m_bCancel = False : Exit For If bDebugColType Then Debug.WriteLine("iNumLine=" & iNumLine + 1) Dim iNumField% = 0 For Each sField In sLine ' 28/04/2017 If m_prm.bRemoveNULL AndAlso sField = sNULL Then Continue For ' Do not count null value End If 'Dim sFieldMinus = "" Dim sFieldTrim$ = sField.Trim Dim bEndWithMinus As Boolean = False If sFieldTrim.EndsWith("-", StringComparison.Ordinal) Then bEndWithMinus = True 'sFieldMinus = sFieldTrim.Substring(0, sFieldTrim.Length - 1) End If Dim dic As SortDic(Of String, clsField) Dim sFieldName$ = "" If iNumLine = 0 OrElse iNumField >= lstFields0.Count Then dic = New SortDic(Of String, clsField) lstFields0.Add(dic) If iNumLine = 0 Then sFieldName = sField If sFieldName.Trim.Length = 0 Then sFieldName = "Field n°" & iNumField + 1 lstNameOfFields.Add(sFieldName) lstMinusExistsForFields.Add(bEndWithMinus) Else dic = lstFields0(iNumField) sFieldName = lstNameOfFields(iNumField) Dim bEndWithMinus0 = lstMinusExistsForFields(iNumField) If bEndWithMinus AndAlso Not bEndWithMinus0 Then lstMinusExistsForFields(iNumField) = bEndWithMinus End If End If Dim dTimeStart = Now() If IsNumeric(sField) Then AddField(dic, iNumField, sFieldName, clsFieldType.sNumeric) ElseIf IsNumeric(sField.Replace(sPeriod, sComma)) Then AddField(dic, iNumField, sFieldName, clsFieldType.sNumericP2C) ElseIf IsNumeric(sField.Replace(sComma, sPeriod)) Then AddField(dic, iNumField, sFieldName, clsFieldType.sNumericC2P) ElseIf IsNumeric(sField.Replace(sQuotes, sEmpty)) Then AddField(dic, iNumField, sFieldName, clsFieldType.sNumericWithQuotes) ElseIf IsNumeric(sField.Replace(sPeriod, sComma).Replace(sQuotes, sEmpty)) Then AddField(dic, iNumField, sFieldName, clsFieldType.sNumericP2CWithQuotes) ElseIf IsNumeric(sField.Replace(sComma, sPeriod).Replace(sQuotes, sEmpty)) Then AddField(dic, iNumField, sFieldName, clsFieldType.sNumericC2PWithQuotes) ElseIf sField.Contains(sQuotes) Then AddField(dic, iNumField, sFieldName, clsFieldType.sTextWithQuotes) Else AddField(dic, iNumField, sFieldName, clsFieldType.sText) End If Dim dTimeEnd = Now() Dim ts = dTimeEnd - dTimeStart rTime += ts.TotalSeconds If bDebugColType Then Debug.WriteLine(sFieldName & "=" & sField) iNumField += 1 Next iNumLine += 1 Next ' IsNumeric is slow in Debug mode for old version of Visual Studio (2013) Dim sMsg$ = "Time (sec) for IsNumeric: " & rTime.ToString("0.000") If bDebugColType Then Debug.WriteLine(sMsg) m_sb.AppendLine(sMsg) lstFields = New List(Of clsField) Dim iNumField2% = 0 For Each dic In lstFields0 Dim iNumSep2% = 0 For Each field In dic.Sort("iNbOcc DESC") If bDebugColType Then Debug.WriteLine(field.iNumField & " : " & field.sField & ", " & field.sType & ", iNbOcc=" & field.iNbOcc) ' Keep the max. If iNumSep2 = 0 Then lstFields.Add(field) If field.sType <> clsFieldType.sText Then bOnlyTextFields = False End If iNumSep2 += 1 Next iNumField2 += 1 Next Dim iNumField3% = 0 For Each field In lstFields field.bCanEndWithMinus = lstMinusExistsForFields(iNumField3) iNumField3 += 1 Next End Sub Private Shared Sub AddField(dic As SortDic(Of String, clsField), iNumField%, sFieldName$, sFieldType$) If Not dic.ContainsKey(sFieldType) Then Dim field = New clsField(iNumField, sFieldName, sFieldType) dic.Add(sFieldType, field) Else Dim field = dic(sFieldType) field.iNbOcc += 1 End If End Sub End Class frmFile2XL.vb ' File2XL : Open a csv file into MS-Excel with pre-formatted cells ' ---------------------------------------------------------------- ' Documentation : File2XL.html ' http://patrice.dargenton.free.fr/CodesSources/File2XL.html ' http://patrice.dargenton.free.fr/CodesSources/File2XL.vbproj.html ' Version 1.07 - 22/04/2023 ' By Patrice Dargenton : mailto:patrice.dargenton@free.fr ' http://patrice.dargenton.free.fr/index.html ' http://patrice.dargenton.free.fr/CodesSources/index.html ' ---------------------------------------------------------------- ' Naming convention : ' ----------------- ' b for Boolean (True or False) ' i for Integer : % ' l for Long : & ' r for Real number (Single!, Double# or Decimal : D) ' s for String : $ ' c for Char or Byte ' d for Date ' u for Unsigned (positif integer) ' a for Array : () ' o for Object ' m_ for member variable of a class or of a form (but not for constants) ' frm for Form ' cls for Class ' mod for Module ' ... ' ----------------- ' File frmFile2XL.vb : Main form ' ------------------ Imports System.Runtime.Hosting Imports System.Text ' for StringBuilder Public Class frmFile2XL Private Const bDelWorkBookOnCloseDef As Boolean = True Private m_bDelWorkBookOnClose As Boolean = bDelWorkBookOnCloseDef Private Const sContextMenu_FileTypeAll$ = "*" ' Every file (every text or csv file to open in Excel) Private Const sContextMenu_CmdKeyOpen$ = "File2XL.Open" Private Const sContextMenu_CmdKeyOpenDescr$ = "Open in MS-Excel using File2XL" Private Const sContextMenu_CmdKeyOpen2$ = "File2XL.Open2" Private Const sContextMenu_CmdKeyOpen2Descr$ = "Open in MS-Excel using File2XL (single delimiter)" Private Const sSingleDelimiterArg$ = "SingleDelimiter" ' For example , rather than "," Private WithEvents m_delegMsg As New clsDelegMsg Private m_bInit As Boolean = False Private m_bXlsExists, m_bXlsxExists As Boolean Private m_bClosing As Boolean = False Private m_f2xl As New clsFile2XL Private Sub frmFile2XL_Shown(sender As Object, e As EventArgs) Handles Me.Shown If Not m_bInit Then m_bInit = True Initialization() End If End Sub Private Sub frmFile2XL_FormClosing(sender As Object, e As FormClosingEventArgs) Handles Me.FormClosing m_delegMsg.m_bCancel = True Quit() End Sub Private Sub Initialization() SetMsgTitle(sMsgTitle) Dim sTxt$ = sMsgTitle & " " & sAppVersion & " (" & sAppDate & ")" If bDebug Then sTxt &= " - Debug" 'If Not is64BitProcess() Then sTxt &= " - 32 bits" Me.Text = sTxt Me.cmdCancel.Visible = False Me.cmdStart.Visible = False Me.cmdShow.Visible = False If bRelease Then Me.cmdCreateTestFiles.Visible = False Me.ToolTip1.SetToolTip(Me.cmdAddContextMenu, "Add context menu to open files in Excel using File2XL " & "(this requires administrator privileges, run as admin. File2XL for this operation)") Me.ToolTip1.SetToolTip(Me.cmdRemoveContextMenu, "Remove context menu for opening files in Excel using File2XL " & "(this requires administrator privileges, run as admin. File2XL for this operation)") CheckContextMenu() ShowLongMessage("") ShowMessage("Checking dll files...") If Not bFileExists(Application.StartupPath & "\ICSharpCode.SharpZipLib.dll", bPrompt:=True) Then GoTo EndSub If Not bFileExists(Application.StartupPath & "\NPOI.dll", bPrompt:=True) Then GoTo EndSub If Not bFileExists(Application.StartupPath & "\NPOI.OOXML.dll", bPrompt:=True) Then GoTo EndSub If Not bFileExists(Application.StartupPath & "\NPOI.OpenXml4Net.dll", bPrompt:=True) Then GoTo EndSub If Not bFileExists(Application.StartupPath & "\NPOI.OpenXmlFormats.dll", bPrompt:=True) Then GoTo EndSub Dim sArg0$ = Microsoft.VisualBasic.Interaction.Command 'MsgBox("File2XL : " & sArg0) If bDebug Then sArg0 = Application.StartupPath & "\Tmp\Test256Col.dat" Else Me.cmdCreateTestFiles.Visible = False End If If sArg0.Length > 0 Then Dim asArgs$() = asCmdLineArg(sArg0) If asArgs.Length > 0 Then Dim sArgument$ = asArgs(0) Dim sArgument2$ = "" Dim bSingleDelimiter As Boolean = False If asArgs.Length > 1 Then sArgument2 = asArgs(1) If sArgument2 = sSingleDelimiterArg Then bSingleDelimiter = True End If ShowButtons() HideContextMenus() Activation(bActivate:=False) ShowMessage("Starting...") If bStart(sArgument, bSingleDelimiter, sArgument2) Then Activation(bActivate:=True) Quit() Else ShowMessage("Error !") Activation(bActivate:=True) Me.cmdShow.Enabled = False End If Exit Sub End If End If EndSub: ShowMessage("Ready.") End Sub Private Function bStart(sPath$, bSingleDelimiter As Boolean, sArgument$) As Boolean If Not bFileExists(sPath, bPrompt:=True) Then Return False Dim sFileName$ = IO.Path.GetDirectoryName(sPath) & "\" & IO.Path.GetFileNameWithoutExtension(sPath) Dim sPostFix$ = "" If bSingleDelimiter Then sPostFix = "_" & sSingleDelimiterArg m_f2xl.m_sDestPathXls = sFileName & sPostFix & ".xls" m_f2xl.m_sDestPathXlsx = sFileName & sPostFix & ".xlsx" m_bXlsExists = bFileExists(m_f2xl.m_sDestPathXls) m_bXlsxExists = bFileExists(m_f2xl.m_sDestPathXlsx) m_bDelWorkBookOnClose = My.Settings.DeleteFileOnClose ' 20/05/2017 MinColumnWidth and MaxColumnWidth ' 28/04/2017 .bRemoveNULL = My.Settings.RemoveNULL Dim prm As New clsPrm With { .sFieldDelimiters = My.Settings.FieldDelimiters, .sDefaultDelimiter = My.Settings.DefaultDelimiter, .bUseXls = My.Settings.UseXls, .bUseXlsx = My.Settings.UseXlsx, .iNbFrozenColumns = My.Settings.NbFrozenColumns, .iNbLinesAnalyzed = My.Settings.NbLinesAnalyzed, .bPreferMultipleDelimiter = Not bSingleDelimiter, .bAutosizeColumns = My.Settings.AutosizeColumns, .iMinColumnWidth = My.Settings.MinColumnWidth, .iMaxColumnWidth = My.Settings.MaxColumnWidth, .bRemoveNULL = My.Settings.RemoveNULL, .bLogFile = My.Settings.LogFile } 'If prm.bLogFile Then ' m_f2xl.m_sb.AppendLine("Arguments: " & Microsoft.VisualBasic.Interaction.Command) ' m_f2xl.m_sb.AppendLine("Path: " & sPath) ' If sArgument.Length > 0 Then m_f2xl.m_sb.AppendLine("Argument: " & sArgument) 'End If If Not prm.bUseXls AndAlso Not prm.bUseXlsx Then If bDebug Then Stop prm.bUseXlsx = True End If prm.bCreateStandardSheet = My.Settings.CreateStandardSheet ShowMessage("Converting...") Dim dTimeStart = Now() If m_f2xl.bRead(prm, sPath, m_delegMsg) Then Dim sDestPath$ = m_f2xl.m_sDestPathXls If m_f2xl.m_bXlsx Then sDestPath = m_f2xl.m_sDestPathXlsx If My.Settings.LogFile Then ' 20/05/2017 Dim ci = Globalization.CultureInfo.CurrentCulture() Dim dTimeEnd = Now() Dim ts = dTimeEnd - dTimeStart Const sDateTimeFormat = "dd\/MM\/yyyy HH:mm:ss" Dim sTime$ = dTimeStart.ToString(sDateTimeFormat, ci) & " -> " & dTimeEnd.ToString(sDateTimeFormat, ci) & " : " & sDisplayTime(ts.TotalSeconds) Dim sb As New StringBuilder() sb.AppendLine() sb.AppendLine(sTime) sb.AppendLine(" -> " & sPath) sb.Append(m_f2xl.m_sb) Dim sLogPath$ = Application.StartupPath & "\File2XL.log" bWriteFile(sLogPath, sb, bAppend:=True) End If If Not bLetOpenFile(sDestPath) Then m_bDelWorkBookOnClose = False End If Return True End Function Private Sub Quit() If m_bClosing Then Exit Sub m_bClosing = True If m_delegMsg.m_bCancel Then GoTo QuitNow If m_delegMsg.m_bPause Then m_delegMsg.m_bCancel = True : GoTo QuitNow Dim sPath2$ = m_f2xl.m_sDestPathXlsx Dim sPath$ = m_f2xl.m_sDestPathXls Dim bWorkBookExists = m_bXlsExists If m_f2xl.m_bXlsx Then sPath = m_f2xl.m_sDestPathXlsx : bWorkBookExists = m_bXlsxExists sPath2 = m_f2xl.m_sDestPathXls ' Delete second path too, if necessary End If If String.IsNullOrEmpty(sPath) Then GoTo QuitNow If Not bWorkBookExists AndAlso m_bDelWorkBookOnClose Then ' Wait, quit Excel and delete workbook If bRelease Then Me.WindowState = FormWindowState.Minimized Me.cmdShow.Enabled = False Me.cmdStart.Enabled = False Me.cmdCancel.Enabled = True m_delegMsg.m_bCancel = False m_f2xl.FreeMemory() ShowMessage("Freeing memory...") FreeDotNetRAM() ShowMessage("Done.") While bFileIsAvailable(sPath, bNonExistentOk:=True, bCheckForSlowRead:=True) ShowMessage("Waiting for the workbook to be open...") If m_delegMsg.m_bCancel Then Exit While Threading.Thread.Sleep(500) End While While Not bFileIsAvailable(sPath, bNonExistentOk:=True, bCheckForSlowRead:=True) ShowMessage("Waiting for the workbook to be closed, and for deleting it...") If m_delegMsg.m_bCancel Then Exit While Threading.Thread.Sleep(500) End While If Not m_delegMsg.m_bCancel Then If My.Settings.DeleteFileConfirm Then ShowMessage("Confirm the deletion of the workbook...") Me.WindowState = FormWindowState.Normal If MsgBoxResult.Cancel = MsgBox( "Delete temporary workbook ? " & IO.Path.GetFileName(sPath) & vbLf & sPath, MsgBoxStyle.Question Or MsgBoxStyle.OkCancel, m_sMsgTitle) Then GoTo QuitNow End If If Not bDeleteFile(sPath) Then If bDebug Then Stop End If ' If necessary delete the other file If Not m_bXlsxExists AndAlso Not m_bXlsExists Then If Not bDeleteFile(sPath2) Then If bDebug Then Stop End If End If End If Else ' Wait and quit Excel While Not bFileIsAvailable(sPath, bNonExistentOk:=True, bCheckForSlowRead:=True) ShowMessage("Waiting for the workbook to be closed...") If m_delegMsg.m_bCancel Then Exit While Threading.Thread.Sleep(500) End While End If QuitNow: Me.Close() End Sub Private Sub cmdStart_Click(sender As Object, e As EventArgs) Handles cmdStart.Click m_delegMsg.m_bPause = Not m_delegMsg.m_bPause Me.cmdCancel.Enabled = True If m_delegMsg.m_bPause Then Me.cmdStart.Text = "Continue" Me.cmdShow.Enabled = True WaitCursor(bDisable:=True) Else Me.cmdStart.Text = "Pause" Me.cmdShow.Enabled = False WaitCursor() End If Application.DoEvents() End Sub Private Sub cmdShow_Click(sender As Object, e As EventArgs) Handles cmdShow.Click Dim sPath$ = m_f2xl.m_sDestPathXls If m_f2xl.m_bXlsx Then sPath = m_f2xl.m_sDestPathXlsx If m_f2xl.bWrite() Then bLetOpenFile(sPath) m_delegMsg.m_bCancel = False End Sub Private Sub cmdCancel_Click(sender As Object, e As EventArgs) Handles cmdCancel.Click m_delegMsg.m_bCancel = True End Sub Private Sub ShowButtons() Me.cmdCancel.Visible = True Me.cmdStart.Visible = True Me.cmdShow.Visible = True End Sub Private Sub Activation(bActivate As Boolean) Me.cmdCancel.Enabled = Not bActivate Me.cmdStart.Enabled = Not bActivate Me.cmdShow.Enabled = bActivate If Not bActivate Then WaitCursor() Me.cmdStart.Text = "Pause" Else WaitCursor(bDisable:=True) Me.cmdStart.Text = "Start" End If Application.DoEvents() End Sub Private Sub HideContextMenus() Me.lblContextMenu.Visible = False Me.cmdAddContextMenu.Visible = False Me.cmdRemoveContextMenu.Visible = False Me.cmdCreateTestFiles.Visible = False End Sub Private Sub ShowLongMessage(sMsg$) Me.lblInfo.Text = sMsg Application.DoEvents() ' Required End Sub Private Sub ShowMessage(sMsg$) Me.ToolStripLabel1.Text = sMsg If Me.WindowState <> FormWindowState.Minimized Then TruncateChildTextAccordingToControlWidth(Me.ToolStripLabel1, Me, appendEllipsis:=True) Dim iLong% = Me.ToolStripLabel1.Text.Length If iLong < 30 AndAlso iLong < sMsg.Length And bDebug Then Debug.WriteLine(sMsg & " -> ") Debug.WriteLine(Me.ToolStripLabel1.Text) Stop End If End If Application.DoEvents() ' Required End Sub Private Sub ShowMessageDeleg(sender As Object, e As clsMsgEventArgs) Handles m_delegMsg.EvShowMessage Me.ShowMessage(e.sMessage) End Sub Private Sub ShowLongMessageDeleg(sender As Object, e As clsMsgEventArgs) _ Handles m_delegMsg.EvShowLongMessage Me.ShowLongMessage(e.sMessage) End Sub Private Sub SetWaitCursor(sender As Object, e As clsWaitCursorEventArgs) _ Handles m_delegMsg.EvWaitCursor WaitCursor(e.bDisable) End Sub Private Shared Sub WaitCursor(Optional bDisable As Boolean = False) If bDisable Then Application.UseWaitCursor = False Else Application.UseWaitCursor = True End If End Sub Private Class clsTest Public Const sTestHeader$ = "TestHeader" Public Const sTest255Col$ = "Test255Col" Public Const sTest256Col$ = "Test256Col" Public Const sTest257Col$ = "Test257Col" Public Const sTest16384Col$ = "Test16384Col" Public Const sTest16385Col$ = "Test16385Col" Public Const sTest65536Lines$ = "Test65536Lines" Public Const sTest65536LinesBig$ = "Test65536LinesBig" Public Const sTest65537Lines$ = "Test65537Lines" Public Const sTest1048576Lines$ = "Test1048576Lines" Public Const sTest1048577Lines$ = "Test1048577Lines" Public Const sTestMaxCarCell32767$ = "TestMaxCarCell32767" Public Const sTestMaxCarCell32768$ = "TestMaxCarCell32768" Public Const sTestBigExcel2003$ = "TestBigExcel2003" Public Const sTestVeryBigExcel2003$ = "TestVeryBigExcel2003" Public Const sTestBigExcel2007$ = "TestBigExcel2007" End Class Private Sub cmdCreateTestFiles_Click(sender As Object, e As EventArgs) Handles cmdCreateTestFiles.Click Me.cmdCreateTestFiles.Enabled = False CreateTestFile(clsTest.sTestHeader) CreateTestFile(clsTest.sTest255Col) CreateTestFile(clsTest.sTest256Col) CreateTestFile(clsTest.sTest257Col) CreateTestFile(clsTest.sTest16384Col) CreateTestFile(clsTest.sTest16385Col) CreateTestFile(clsTest.sTest65536Lines) CreateTestFile(clsTest.sTest65536LinesBig) CreateTestFile(clsTest.sTest65537Lines) CreateTestFile(clsTest.sTest1048576Lines) CreateTestFile(clsTest.sTest1048577Lines) CreateTestFile(clsTest.sTestMaxCarCell32767) CreateTestFile(clsTest.sTestMaxCarCell32768) CreateTestFile(clsTest.sTestBigExcel2003) CreateTestFile(clsTest.sTestVeryBigExcel2003) CreateTestFile(clsTest.sTestBigExcel2007) 'EndTest: Me.cmdCreateTestFiles.Enabled = True MsgBox("OK !") End Sub Private Shared Sub CreateTestFile(sTestFile$) Dim bTestHeader As Boolean = False Dim bTestMaxTxtCell As Boolean = False Dim iNbCol%, iNbLines%, iNbCarMax% iNbCol = 10 iNbLines = 10 iNbCarMax = clsFile2XL.iNbCarMaxCell Select Case sTestFile Case clsTest.sTestHeader : bTestHeader = True Case clsTest.sTest255Col : iNbCol = 255 Case clsTest.sTest256Col : iNbCol = 256 Case clsTest.sTest257Col : iNbCol = 257 Case clsTest.sTest16384Col : iNbCol = 16384 : iNbLines = 2 Case clsTest.sTest16385Col : iNbCol = 16385 : iNbLines = 2 Case clsTest.sTest65536Lines : iNbLines = 65536 : iNbCol = 2 Case clsTest.sTest65536LinesBig : iNbLines = 65536 : iNbCol = 10 Case clsTest.sTest65537Lines : iNbLines = 65537 : iNbCol = 2 Case clsTest.sTest1048576Lines : iNbLines = 1048576 : iNbCol = 2 Case clsTest.sTest1048577Lines : iNbLines = 1048577 : iNbCol = 2 Case clsTest.sTestMaxCarCell32767 : bTestMaxTxtCell = True Case clsTest.sTestMaxCarCell32768 : bTestMaxTxtCell = True : iNbCarMax = clsFile2XL.iNbCarMaxCell + 1 Case clsTest.sTestBigExcel2003 : iNbLines = 10000 : iNbCol = 100 Case clsTest.sTestVeryBigExcel2003 : iNbLines = 65536 : iNbCol = 256 Case clsTest.sTestBigExcel2007 : iNbLines = 10000 : iNbCol = 500 End Select Const sDelimiter = ";" 'vbTab Dim sb As New StringBuilder For i As Integer = 0 To iNbLines - 1 If bTestHeader Then iNbCol = i For j As Integer = 0 To iNbCol - 1 If bTestMaxTxtCell AndAlso i = 5 AndAlso (j = 5 OrElse j = 7) Then For k As Integer = 0 To iNbCarMax - 1 sb.Append("x") Next sb.Append(sDelimiter) Continue For End If 'sb.Append((j + 1 + i * iNbCol)) sb.Append((j + 1 + i)) If j < iNbCol - 1 Then sb.Append(sDelimiter) Next sb.AppendLine() Next Dim sPath$ = Application.StartupPath & "\" & sTestFile & ".dat" If Not bWriteFile(sPath, sb) Then Exit Sub End Sub #Region "Context menus" Private Sub CheckContextMenu() Dim sKey$ = sContextMenu_FileTypeAll & "\" & sShellKey & "\" & sContextMenu_CmdKeyOpen If bClassesRootRegistryKeyExists(sKey) Then Me.cmdAddContextMenu.Enabled = False Me.cmdRemoveContextMenu.Enabled = True Else Me.cmdAddContextMenu.Enabled = True Me.cmdRemoveContextMenu.Enabled = False End If End Sub Private Sub cmdAddContextMenu_Click(sender As Object, e As EventArgs) _ Handles cmdAddContextMenu.Click AddContextMenus() CheckContextMenu() End Sub Private Sub cmdRemoveContextMenu_Click(sender As Object, e As EventArgs) _ Handles cmdRemoveContextMenu.Click RemoveContextMenus() CheckContextMenu() End Sub Private Shared Sub AddContextMenus() If MsgBoxResult.Cancel = MsgBox("Add context menu ?", MsgBoxStyle.OkCancel Or MsgBoxStyle.Question, m_sMsgTitle) Then Exit Sub AddContextMenus(sContextMenu_FileTypeAll) End Sub Private Shared Sub RemoveContextMenus() If MsgBoxResult.Cancel = MsgBox("Remove context menu ?", MsgBoxStyle.OkCancel Or MsgBoxStyle.Question, m_sMsgTitle) Then Exit Sub RemoveContextMenus(sContextMenu_FileTypeAll) End Sub Private Shared Sub AddContextMenus(sKey$) Dim sExePath$ = Application.ExecutablePath Const bPrompt As Boolean = False Const sPath = """%1""" bAddContextMenu(sKey, sContextMenu_CmdKeyOpen, bPrompt, , sContextMenu_CmdKeyOpenDescr, sExePath, sPath) bAddContextMenu(sKey, sContextMenu_CmdKeyOpen2, bPrompt, , sContextMenu_CmdKeyOpen2Descr, sExePath, sPath & " " & sSingleDelimiterArg) End Sub Private Shared Sub RemoveContextMenus(sKey$) bAddContextMenu(sKey, sContextMenu_CmdKeyOpen, bRemove:=True, bPrompt:=False) bAddContextMenu(sKey, sContextMenu_CmdKeyOpen2, bRemove:=True, bPrompt:=False) End Sub #End Region End Class modFile2XLUtil.vb ' File modFile2XLUtil.vb : Utility module for File2XL ' ---------------------- Module modFile2XLUtil Public Function iNbOccurrences%(sTxt$, sOcc$) ' Return the number of items searched Dim iTxtLen% = sTxt.Length Dim iOccLen% = sOcc.Length Dim iPosMax% = iTxtLen - iOccLen Dim iNbOcc%, iPosNew%, iPos% While iPos <= iPosMax iPosNew = sTxt.IndexOf(sOcc, iPos, StringComparison.Ordinal) ' Ordinal : Exact (binary) If iPosNew = -1 Then Exit While iNbOcc += 1 iPos = iPosNew + iOccLen End While 'Debug.WriteLine("Nb " & sOcc & " = " & iNbOcc & " in " & sTxt) Return iNbOcc End Function End Module clsShowMsg.vb ' File clsShowMsg.vb : Managing class for messages displayed by the delegate ' ------------------ Public Class clsMsgEventArgs : Inherits EventArgs Private m_sMsg$ = "" Public Sub New(sMsg$) If sMsg Is Nothing Then sMsg = "" Me.m_sMsg = sMsg End Sub Public ReadOnly Property sMessage$() Get Return Me.m_sMsg End Get End Property End Class Public Class clsWaitCursorEventArgs : Inherits EventArgs Private m_bDisable As Boolean = False Public Sub New(bDisable As Boolean) Me.m_bDisable = bDisable End Sub Public ReadOnly Property bDisable() As Boolean Get Return Me.m_bDisable End Get End Property End Class Public Class clsDelegMsg ' Managing class for messages displayed by the delegate Private Delegate Sub ShowMessageDelegate(sender As Object, e As clsMsgEventArgs) 'Public Event EvShowMessage As ShowMessageDelegate Public Event EvShowMessage As EventHandler(Of clsMsgEventArgs) 'Public Event EvShowLongMessage As ShowMessageDelegate Public Event EvShowLongMessage As EventHandler(Of clsMsgEventArgs) Private Delegate Sub WaitCursorEvHandler(sender As Object, e As clsWaitCursorEventArgs) 'Public Event EvWaitCursor As WaitCursorEvHandler Public Event EvWaitCursor As EventHandler(Of clsWaitCursorEventArgs) Public m_bPause As Boolean Public m_bCancel As Boolean Public m_bIgnoreNextLines As Boolean Public Sub New() End Sub Public Sub ShowMsg(sMsg$) Dim e As New clsMsgEventArgs(sMsg) RaiseEvent EvShowMessage(Me, e) End Sub Public Sub ShowLongMsg(sMsg$) Dim e As New clsMsgEventArgs(sMsg) RaiseEvent EvShowLongMessage(Me, e) End Sub Public Sub WaitCursor(Optional bDisable As Boolean = False) Dim e As New clsWaitCursorEventArgs(bDisable) RaiseEvent EvWaitCursor(Me, e) End Sub End Class clsSortDic.vb ' File clsSortDic.vb : Sortable dictionary class ' ------------------ Imports System.Runtime.Serialization <Serializable> _ Public Class SortDic(Of TKey, TValue) : Inherits Dictionary(Of TKey, TValue) Sub New() End Sub Protected Sub New(info As SerializationInfo, context As StreamingContext) MyBase.New(info, context) End Sub Public Function Sort(Optional sSorting$ = "") As TValue() ' Sort the dictionary and return sorted elements Dim iNbLines% = Me.Count Dim arrayTvalue(iNbLines - 1) As TValue Dim iNumLine% = 0 For Each kvp As KeyValuePair(Of TKey, TValue) In Me arrayTvalue(iNumLine) = kvp.Value iNumLine += 1 Next ' If no sorting is specified, simply return the array If String.IsNullOrEmpty(sSorting) Then Return arrayTvalue ' Sort the dictionary Dim comp As New UniversalComparer(Of TValue)(sSorting) Array.Sort(Of TValue)(arrayTvalue, comp) Return arrayTvalue End Function End Class modEncoding.vb ' https://github.com/AutoItConsulting/text-encoding-detect ' Copyright 2015-2016 Jonathan Bennett <jon@autoitscript.com> ' ' https://www.autoitscript.com ' ' Licensed under the Apache License, Version 2.0 (the "License"); ' you may not use this file except in compliance with the License. ' You may obtain a copy of the License at ' ' http://www.apache.org/licenses/LICENSE-2.0 ' ' Unless required by applicable law or agreed to in writing, software ' distributed under the License is distributed on an "AS IS" BASIS, ' WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ' See the License for the specific language governing permissions and ' limitations under the License. Option Infer On 'Namespace AutoIt.Common Public Class TextEncodingDetect Private ReadOnly _utf16BeBom As Byte() = {&HFE, &HFF} Private ReadOnly _utf16LeBom As Byte() = {&HFF, &HFE} Private ReadOnly _utf8Bom As Byte() = {&HEF, &HBB, &HBF} Private _nullSuggestsBinary As Boolean = True Private _utf16ExpectedNullPercent As Double = 70 Private _utf16UnexpectedNullPercent As Double = 10 Public Enum Encoding ''' <summary> ''' Unknown or binary ''' </summary> None ''' <summary> ''' 0-255 ''' </summary> Ansi ''' <summary> ''' 0-127 ''' </summary> Ascii ''' <summary> ''' UTF8 with BOM ''' </summary> Utf8Bom ''' <summary> ''' UTF8 without BOM ''' </summary> Utf8Nobom ''' <summary> ''' UTF16 LE (Little Endian) with BOM: Unicode ''' </summary> Utf16LeBom ''' <summary> ''' UTF16 LE (Little Endian) without BOM: Unicode ''' </summary> Utf16LeNoBom ''' <summary> ''' UTF16-BE (Big Endian) with BOM ''' </summary> Utf16BeBom ''' <summary> ''' UTF16-BE (Big Endian) without BOM ''' </summary> Utf16BeNoBom End Enum ''' <summary> ''' Sets if the presence of nulls in a buffer indicate the buffer is binary data rather than text. ''' </summary> Public WriteOnly Property NullSuggestsBinary As Boolean Set(ByVal value As Boolean) _nullSuggestsBinary = value End Set End Property Public WriteOnly Property Utf16ExpectedNullPercent As Double Set(ByVal value As Double) If value > 0 AndAlso value < 100 Then _utf16ExpectedNullPercent = value End If End Set End Property Public WriteOnly Property Utf16UnexpectedNullPercent As Double Set(ByVal value As Double) If value > 0 AndAlso value < 100 Then _utf16UnexpectedNullPercent = value End If End Set End Property ''' <summary> ''' Gets the BOM length for a given Encoding mode. ''' </summary> ''' <param name="encoding"></param> ''' <returns>The BOM length.</returns> Public Shared Function GetBomLengthFromEncodingMode(ByVal encoding As Encoding) As Integer Dim length As Integer Select Case encoding Case Encoding.Utf16BeBom, Encoding.Utf16LeBom length = 2 Case Encoding.Utf8Bom length = 3 Case Else length = 0 End Select Return length End Function ''' <summary> ''' Checks for a BOM sequence in a byte buffer. ''' </summary> ''' <param name="buffer"></param> ''' <param name="size"></param> ''' <returns>Encoding type or Encoding.None if no BOM.</returns> Public Function CheckBom(ByVal buffer As Byte(), ByVal size As Integer) As Encoding ' Check for BOM If size >= 2 AndAlso buffer(0) = _utf16LeBom(0) AndAlso buffer(1) = _utf16LeBom(1) Then Return Encoding.Utf16LeBom End If If size >= 2 AndAlso buffer(0) = _utf16BeBom(0) AndAlso buffer(1) = _utf16BeBom(1) Then Return Encoding.Utf16BeBom End If If size >= 3 AndAlso buffer(0) = _utf8Bom(0) AndAlso buffer(1) = _utf8Bom(1) AndAlso buffer(2) = _utf8Bom(2) Then Return Encoding.Utf8Bom End If Return Encoding.None End Function ''' <summary> ''' Automatically detects the Encoding type of a given byte buffer. ''' </summary> ''' <param name="buffer">The byte buffer.</param> ''' <param name="size">The size of the byte buffer.</param> ''' <returns>The Encoding type or Encoding.None if unknown.</returns> Public Function DetectEncoding(ByVal buffer As Byte(), ByVal size As Integer) As Encoding ' First check if we have a BOM and return that if so Dim encoding = CheckBom(buffer, size) If encoding <> Encoding.None Then Return encoding End If ' Now check for valid UTF8 encoding = CheckUtf8(buffer, size) If encoding <> Encoding.None Then Return encoding End If ' Now try UTF16 encoding = CheckUtf16NewlineChars(buffer, size) If encoding <> Encoding.None Then Return encoding End If encoding = CheckUtf16Ascii(buffer, size) If encoding <> Encoding.None Then Return encoding End If ' ANSI or None (binary) then If Not DoesContainNulls(buffer, size) Then Return Encoding.Ansi End If ' Found a null, return based on the preference in null_suggests_binary_ Return If(_nullSuggestsBinary, Encoding.None, Encoding.Ansi) End Function ''' <summary> ''' Checks if a buffer contains text that looks like utf16 by scanning for ''' newline chars that would be present even in non-english text. ''' </summary> ''' <param name="buffer">The byte buffer.</param> ''' <param name="size">The size of the byte buffer.</param> ''' <returns>Encoding.none, Encoding.Utf16LeNoBom or Encoding.Utf16BeNoBom.</returns> Private Shared Function CheckUtf16NewlineChars(ByVal buffer As Byte(), ByVal size As Integer) As Encoding If size < 2 Then Return Encoding.None End If ' Reduce size by 1 so we don't need to worry about bounds checking for pairs of bytes size -= 1 Dim leControlChars = 0 Dim beControlChars = 0 'Dim pos As UInteger = 0 Dim pos As Integer = 0 While pos < size Dim ch1 = buffer(Math.Min(Threading.Interlocked.Increment(pos), pos - 1)) Dim ch2 = buffer(Math.Min(Threading.Interlocked.Increment(pos), pos - 1)) If ch1 = 0 Then If ch2 = &HA OrElse ch2 = &HD Then Threading.Interlocked.Increment(beControlChars) End If ElseIf ch2 = 0 Then If ch1 = &HA OrElse ch1 = &HD Then Threading.Interlocked.Increment(leControlChars) End If End If ' If we are getting both LE and BE control chars then this file is not utf16 If leControlChars > 0 AndAlso beControlChars > 0 Then Return Encoding.None End If End While If leControlChars > 0 Then Return Encoding.Utf16LeNoBom End If Return If(beControlChars > 0, Encoding.Utf16BeNoBom, Encoding.None) End Function ''' <summary> ''' Checks if a buffer contains any nulls. Used to check for binary vs text data. ''' </summary> ''' <param name="buffer">The byte buffer.</param> ''' <param name="size">The size of the byte buffer.</param> Private Shared Function DoesContainNulls(ByVal buffer As Byte(), ByVal size As Integer) As Boolean 'Dim pos As UInteger = 0 Dim pos As Integer = 0 While pos < size If buffer(Math.Min(Threading.Interlocked.Increment(pos), pos - 1)) = 0 Then Return True End If End While Return False End Function ''' <summary> ''' Checks if a buffer contains text that looks like utf16. This is done based ''' on the use of nulls which in ASCII/script like text can be useful to identify. ''' </summary> ''' <param name="buffer">The byte buffer.</param> ''' <param name="size">The size of the byte buffer.</param> ''' <returns>Encoding.none, Encoding.Utf16LeNoBom or Encoding.Utf16BeNoBom.</returns> Private Function CheckUtf16Ascii(ByVal buffer As Byte(), ByVal size As Integer) As Encoding Dim numOddNulls = 0 Dim numEvenNulls = 0 ' Get even nulls 'Dim pos As UInteger = 0 Dim pos As Integer = 0 While pos < size If buffer(pos) = 0 Then numEvenNulls += 1 End If pos += 2 End While ' Get odd nulls pos = 1 While pos < size If buffer(pos) = 0 Then numOddNulls += 1 End If pos += 2 End While Dim evenNullThreshold = numEvenNulls * 2.0 / size Dim oddNullThreshold = numOddNulls * 2.0 / size Dim expectedNullThreshold = _utf16ExpectedNullPercent / 100.0 Dim unexpectedNullThreshold = _utf16UnexpectedNullPercent / 100.0 ' Lots of odd nulls, low number of even nulls If evenNullThreshold < unexpectedNullThreshold AndAlso oddNullThreshold > expectedNullThreshold Then Return Encoding.Utf16LeNoBom End If ' Lots of even nulls, low number of odd nulls If oddNullThreshold < unexpectedNullThreshold AndAlso evenNullThreshold > expectedNullThreshold Then Return Encoding.Utf16BeNoBom End If ' Don't know Return Encoding.None End Function ''' <summary> ''' Checks if a buffer contains valid utf8. ''' </summary> ''' <param name="buffer">The byte buffer.</param> ''' <param name="size">The size of the byte buffer.</param> ''' <returns> ''' Encoding type of Encoding.None (invalid UTF8), Encoding.Utf8NoBom (valid utf8 multibyte strings) or ''' Encoding.ASCII (data in 0.127 range). ''' </returns> Private Function CheckUtf8(ByVal buffer As Byte(), ByVal size As Integer) As Encoding ' UTF8 Valid sequences ' 0xxxxxxx ASCII ' 110xxxxx 10xxxxxx 2-byte ' 1110xxxx 10xxxxxx 10xxxxxx 3-byte ' 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx 4-byte ' ' Width in UTF8 ' Decimal Width ' 0-127 1 byte ' 194-223 2 bytes ' 224-239 3 bytes ' 240-244 4 bytes ' ' Subsequent chars are in the range 128-191 Dim onlySawAsciiRange = True 'Dim pos As UInteger = 0 Dim pos As Integer = 0 While pos < size Dim ch = buffer(Math.Min(Threading.Interlocked.Increment(pos), pos - 1)) If ch = 0 AndAlso _nullSuggestsBinary Then Return Encoding.None End If Dim moreChars As Integer If ch <= 127 Then ' 1 byte moreChars = 0 ElseIf ch >= 194 AndAlso ch <= 223 Then ' 2 Byte moreChars = 1 ElseIf ch >= 224 AndAlso ch <= 239 Then ' 3 Byte moreChars = 2 ElseIf ch >= 240 AndAlso ch <= 244 Then ' 4 Byte moreChars = 3 Else Return Encoding.None ' Not utf8 End If ' Check secondary chars are in range if we are expecting any While moreChars > 0 AndAlso pos < size onlySawAsciiRange = False ' Seen non-ascii chars now ch = buffer(Math.Min(Threading.Interlocked.Increment(pos), pos - 1)) If ch < 128 OrElse ch > 191 Then Return Encoding.None ' Not utf8 End If Threading.Interlocked.Decrement(moreChars) End While End While ' If we get to here then only valid UTF-8 sequences have been processed ' If we only saw chars in the range 0-127 then we can't assume UTF8 (the caller will need to decide) Return If(onlySawAsciiRange, Encoding.Ascii, Encoding.Utf8Nobom) End Function End Class 'End Namespace modGenRead.vb ' File modGenRead.vb : Generic text reading module ' ------------------ Imports System.Text ' StringBuilder Imports System.IO Module modGenericReading ' Read big files (> 10 Mb) line by line Public Const iBigFileSizeMb% = 10 * 1024 * 1024 ' 10 Mb #Region "Delegate (call-back)" Public Class clsLineEventArgs : Inherits EventArgs Private m_sLine$ = "" Public Sub New(sLine$) If String.IsNullOrEmpty(sLine) Then sLine = "" Me.m_sLine = sLine End Sub Public ReadOnly Property sLine$() Get Return Me.m_sLine End Get End Property End Class Public Class clsSplitLineEventArgs : Inherits EventArgs Public m_asFields$() Public m_iNbColumns% = 0 Public Sub New(sLine$, sFieldDelimiter$, bQuotesDelimiter As Boolean) ' This constructor works only using "," or ";" If String.IsNullOrEmpty(sLine) Then sLine = "" ' Split using " : remove first and last ones If bQuotesDelimiter AndAlso Not String.IsNullOrEmpty(sLine) AndAlso sLine.Length > 2 Then sLine = sLine.Substring(1, sLine.Length - 2) End If If String.IsNullOrEmpty(sFieldDelimiter) Then ReDim Me.m_asFields(0) Me.m_asFields(0) = sLine m_iNbColumns = 1 Else Me.m_asFields = Split(sLine, sFieldDelimiter) m_iNbColumns = Me.m_asFields.GetUpperBound(0) End If End Sub End Class Public Class clsDelegLine Public Delegate Sub EvHandlerLine(sender As Object, e As clsLineEventArgs) Public Event EvNewLine As EvHandlerLine Public Delegate Sub EvHandlerSplitLine(sender As Object, e As clsSplitLineEventArgs) Public Event EvNewSplitLine As EvHandlerSplitLine Public Sub NewLine(sLine$) Dim e As New clsLineEventArgs(sLine) RaiseEvent EvNewLine(Me, e) End Sub Public Sub NewSplitLine(sLine$, sFieldDelimiter$, bQuotesDelimiter As Boolean, ByRef iNbColumns%) Dim e As New clsSplitLineEventArgs(sLine, sFieldDelimiter, bQuotesDelimiter) RaiseEvent EvNewSplitLine(Me, e) iNbColumns = e.m_iNbColumns End Sub End Class #End Region 'Public Function bReadFileGenericSmart(sFieldDelimiter$, bHeader As Boolean, ' sPath$, delegLine As clsDelegLine, msgDeleg As clsDelegMsg, ' ByRef iNbLines%, ByRef iNbColumns%) As Boolean ' Dim encod = GetEncoding(sPath) ' ' If encoding is ASCII, set the Latin alphabet to preserve for example accents ' ' Default = System.Text.SBCSCodePageEncoding = Encoding.GetEncoding(1252) ' If encod Is Encoding.ASCII Then encod = Encoding.Default ' ' From 10 Mb read line by line ' Dim lTailleFic& = New IO.FileInfo(sPath).Length ' Dim bLineByLineMode As Boolean = False ' If lTailleFic > iBigFileSizeMb Then bLineByLineMode = True ' Return bReadFileGeneric(sFieldDelimiter, bHeader, sPath, delegLine, msgDeleg, ' iNbLines, iNbColumns, bLineByLineMode, encod:=encod) 'End Function Public Function bReadFileGeneric(sFieldDelimiter$, bHeader As Boolean, sPath$, lineDeleg As clsDelegLine, msgDeleg As clsDelegMsg, ByRef iNbLines%, ByRef iNbColumns%, Optional bLineByLine As Boolean = False, Optional bOnlyFirstLines As Boolean = False, Optional bOnlyFirstSplitLines As Boolean = False, Optional encod As Encoding = Nothing, Optional iNbLinesAnalyzed% = 10) As Boolean ' 29/04/2023 If encod Is Nothing Then Return bReadFileGenericDetectEncoding( sFieldDelimiter, bHeader, sPath, lineDeleg, msgDeleg, iNbLines, iNbColumns, bOnlyFirstLines, bOnlyFirstSplitLines, iNbLinesAnalyzed) iNbLines = -1 ' -1 = Not started Dim sFile$ = IO.Path.GetFileName(sPath) Dim sMsg0$ = "Loading " & sFile & "..." msgDeleg.ShowMsg(sMsg0) Dim sMsg1$ = "Loading..." & vbLf & sPath msgDeleg.ShowLongMsg(sMsg1) If Not bFileExists(sPath, bPrompt:=True) Then Return False Dim bQuotesDelimiter As Boolean = False If sFieldDelimiter = sQuotesCommaQuotesDelimiter OrElse sFieldDelimiter = sQuotesSemiColonQuotesDelimiter Then bQuotesDelimiter = True If IsNothing(encod) Then encod = Encoding.Default Dim iNumLine% = 0 Dim iDisplayRate0% = iDisplayRate If iNbColumns > 0 Then Select Case iNbColumns Case 1 To 5 : iDisplayRate0 = 10000 Case 6 To 10 : iDisplayRate0 = iDisplayRate Case 11 To 50 : iDisplayRate0 = 500 Case 51 To 100 : iDisplayRate0 = 100 Case 101 To 1000 : iDisplayRate0 = 10 Case Else iDisplayRate0 = 1 End Select End If If bLineByLine OrElse bOnlyFirstLines OrElse bOnlyFirstSplitLines Then ' Read line by line Dim fs As FileStream = Nothing Try Dim ci = Globalization.CultureInfo.CurrentCulture() Dim lFileSize& = New IO.FileInfo(sPath).Length Dim share As IO.FileShare = IO.FileShare.ReadWrite fs = New IO.FileStream(sPath, IO.FileMode.Open, IO.FileAccess.Read, share) Dim lPosition& = 0 Using sr As New IO.StreamReader(fs, encod) fs = Nothing ' 19/05/2017 Do not use fs.Position inside this loop Do Dim sLine$ = sr.ReadLine() ' 20/08/2017 If Not String.IsNullOrEmpty(sLine) Then If Not String.IsNullOrEmpty(sLine) Then lPosition += sLine.Length iNumLine += 1 If bOnlyFirstLines Then If iNumLine > iNbLinesAnalyzed Then Return True If IsNothing(sLine) Then Continue Do lineDeleg.NewLine(sLine) Continue Do End If If bHeader AndAlso Not bOnlyFirstLines AndAlso iNumLine = 1 Then Continue Do ' Header If msgDeleg.m_bIgnoreNextLines Then Exit Do If IsNothing(sLine) Then Continue Do Dim iNbColumns0% = 0 lineDeleg.NewSplitLine(sLine, sFieldDelimiter, bQuotesDelimiter, iNbColumns0) If iNbColumns0 > iNbColumns Then iNbColumns = iNbColumns0 If bOnlyFirstSplitLines Then If iNumLine > iNbLinesAnalyzed Then Return True Continue Do End If If iNumLine Mod iDisplayRate0 = 0 Then 'Dim lFilePos& = fs.Position Dim lFilePos& = lPosition ' 19/05/2017 Dim rPC! = 100 * CSng(lFilePos / lFileSize) Dim sPC$ = iNumLine & " (" & rPC.ToString("0.00", ci) & " %)..." Dim sMsg$ = sFile & " lines : " & sPC Dim sLongMsg$ = sPC & vbLf & sPath & vbLf & sRAMInfo() msgDeleg.ShowMsg("Loading : " & sMsg) msgDeleg.ShowLongMsg("Loading : " & sLongMsg) WaitPause(msgDeleg, "Paused : " & sMsg, "Paused : " & sLongMsg) If msgDeleg.m_bCancel Then Return False End If Loop While Not sr.EndOfStream End Using If Not msgDeleg.m_bIgnoreNextLines Then iNbLines = iNumLine Dim sPC1$ = iNumLine & " (" & (100).ToString("0.00", ci) & " %)" Dim sMsg$ = "Loading " & sFile & " lines : " & sPC1 Dim sLongMsg$ = "Loading : " & sPC1 & vbLf & sPath & vbLf & sRAMInfo() msgDeleg.ShowMsg(sMsg) msgDeleg.ShowLongMsg(sLongMsg) End If Catch ex As Exception Throw Return False Finally ' 19/05/2017 Right code to suppress CA2202 warning, but fs.Position ' cannot be read inside the loop If fs IsNot Nothing Then fs.Dispose() ' CA2000 End Try Else ' Read whole file Dim asLines$() = asReadFile(sPath, bReadOnly:=True, encod:=encod) If IsNothing(asLines) Then Return False iNbLines = asLines.Count For Each sLine As String In asLines iNumLine += 1 If bHeader AndAlso iNumLine = 1 Then Continue For ' Header If msgDeleg.m_bIgnoreNextLines Then Exit For Dim iNbColumns0% = 0 lineDeleg.NewSplitLine(sLine, sFieldDelimiter, bQuotesDelimiter, iNbColumns0) If iNbColumns0 > iNbColumns Then iNbColumns = iNbColumns0 If iNumLine Mod iDisplayRate0 = 0 OrElse iNumLine = iNbLines Then Dim sProgress$ = iNumLine & "/" & iNbLines Dim sMsg$ = sFile & " lines... " & sProgress Dim sLongMsg$ = sProgress & vbLf & sPath & vbLf & sRAMInfo() msgDeleg.ShowMsg("Loading : " & sMsg) msgDeleg.ShowLongMsg("Loading : " & sLongMsg) WaitPause(msgDeleg, "Paused : " & sMsg, "Paused : " & sLongMsg) If msgDeleg.m_bCancel Then Return False End If Next End If If bHeader AndAlso iNbLines > 0 Then iNbLines -= 1 msgDeleg.ShowMsg(sMsgDone) msgDeleg.ShowLongMsg(sMsgDone) Return True End Function Public Function bReadFileGenericDetectEncoding(sFieldDelimiter$, bHeader As Boolean, sPath$, lineDeleg As clsDelegLine, msgDeleg As clsDelegMsg, ByRef iNbLines%, ByRef iNbColumns%, Optional bOnlyFirstLines As Boolean = False, Optional bOnlyFirstSplitLines As Boolean = False, Optional iNbLinesAnalyzed% = 10) As Boolean iNbLines = -1 ' -1 = Not started Dim sFile$ = IO.Path.GetFileName(sPath) Dim sMsg0$ = "Loading " & sFile & "..." msgDeleg.ShowMsg(sMsg0) Dim sMsg1$ = "Loading..." & vbLf & sPath msgDeleg.ShowLongMsg(sMsg1) If Not bFileExists(sPath, bPrompt:=True) Then Return False Dim bQuotesDelimiter As Boolean = False If sFieldDelimiter = sQuotesCommaQuotesDelimiter OrElse sFieldDelimiter = sQuotesSemiColonQuotesDelimiter Then bQuotesDelimiter = True Dim iNumLine% = 0 Dim iDisplayRate0% = iDisplayRate If iNbColumns > 0 Then Select Case iNbColumns Case 1 To 5 : iDisplayRate0 = 10000 Case 6 To 10 : iDisplayRate0 = iDisplayRate Case 11 To 50 : iDisplayRate0 = 500 Case 51 To 100 : iDisplayRate0 = 100 Case 101 To 1000 : iDisplayRate0 = 10 Case Else iDisplayRate0 = 1 End Select End If ' Read line by line, and detect encoding Dim fs As FileStream = Nothing Try Dim ci = Globalization.CultureInfo.CurrentCulture() Dim lFileSize& = New IO.FileInfo(sPath).Length Dim share As IO.FileShare = IO.FileShare.ReadWrite fs = New IO.FileStream(sPath, IO.FileMode.Open, IO.FileAccess.Read, share) Dim lPosition& = 0 Using sr As New IO.StreamReader(fs, detectEncodingFromByteOrderMarks:=True) fs = Nothing ' Do not use fs.Position inside this loop Do Dim sLine$ = sr.ReadLine() If Not String.IsNullOrEmpty(sLine) Then lPosition += sLine.Length iNumLine += 1 If bOnlyFirstLines Then If iNumLine > iNbLinesAnalyzed Then Return True If IsNothing(sLine) Then Continue Do lineDeleg.NewLine(sLine) Continue Do End If If bHeader AndAlso Not bOnlyFirstLines AndAlso iNumLine = 1 Then Continue Do ' Header If msgDeleg.m_bIgnoreNextLines Then Exit Do If IsNothing(sLine) Then Continue Do Dim iNbColumns0% = 0 lineDeleg.NewSplitLine(sLine, sFieldDelimiter, bQuotesDelimiter, iNbColumns0) If iNbColumns0 > iNbColumns Then iNbColumns = iNbColumns0 If bOnlyFirstSplitLines Then If iNumLine > iNbLinesAnalyzed Then Return True Continue Do End If If iNumLine Mod iDisplayRate0 = 0 Then Dim lFilePos& = lPosition Dim rPC! = 100 * CSng(lFilePos / lFileSize) Dim sPC$ = iNumLine & " (" & rPC.ToString("0.00", ci) & " %)..." Dim sMsg$ = sFile & " lines : " & sPC Dim sLongMsg$ = sPC & vbLf & sPath & vbLf & sRAMInfo() msgDeleg.ShowMsg("Loading : " & sMsg) msgDeleg.ShowLongMsg("Loading : " & sLongMsg) WaitPause(msgDeleg, "Paused : " & sMsg, "Paused : " & sLongMsg) If msgDeleg.m_bCancel Then Return False End If Loop While Not sr.EndOfStream End Using If Not msgDeleg.m_bIgnoreNextLines Then iNbLines = iNumLine Dim sPC1$ = iNumLine & " (" & (100).ToString("0.00", ci) & " %)" Dim sMsg$ = "Loading " & sFile & " lines : " & sPC1 Dim sLongMsg$ = "Loading : " & sPC1 & vbLf & sPath & vbLf & sRAMInfo() msgDeleg.ShowMsg(sMsg) msgDeleg.ShowLongMsg(sLongMsg) End If Catch ex As Exception Throw Return False Finally If fs IsNot Nothing Then fs.Dispose() End Try If bHeader AndAlso iNbLines > 0 Then iNbLines -= 1 msgDeleg.ShowMsg(sMsgDone) msgDeleg.ShowLongMsg(sMsgDone) Return True End Function Private Sub WaitPause(msgDeleg As clsDelegMsg, sMsgPause$, sLongMsgPause$) While msgDeleg.m_bPause msgDeleg.ShowMsg(sMsgPause) msgDeleg.ShowLongMsg(sLongMsgPause) If msgDeleg.m_bCancel Then Exit Sub Threading.Thread.Sleep(500) End While End Sub End Module modUtil.vb ' File modUtil.vb : Utility module ' --------------- Imports System.Runtime.CompilerServices ' For MethodImpl(MethodImplOptions.AggressiveInlining) Module modUtil ' This field is rather a static variable than a member variable, it should be named s_sMsgTitle <CodeAnalysis.SuppressMessage("Microsoft.Maintainability", "CA1504:ReviewMisleadingFieldNames")> Public m_sMsgTitle$ = sMsgTitle Public Sub SetMsgTitle(sMsgTitle$) m_sMsgTitle = sMsgTitle End Sub Public Sub ShowErrorMsg(ex As Exception, Optional sFunctionTitle$ = "", Optional sInfo$ = "", Optional sDetailedErrMsg$ = "", Optional bCopyErrMsgClipboard As Boolean = True, Optional ByRef sFinalErrMsg$ = "") If Not Cursor.Current.Equals(Cursors.Default) Then Cursor.Current = Cursors.Default Dim sMsg$ = "" If sFunctionTitle <> "" Then sMsg = "Function : " & sFunctionTitle If sInfo <> "" Then sMsg &= vbCrLf & sInfo If sDetailedErrMsg <> "" Then sMsg &= vbCrLf & sDetailedErrMsg If ex.Message <> "" Then sMsg &= vbCrLf & ex.Message.Trim If Not IsNothing(ex.InnerException) Then _ sMsg &= vbCrLf & ex.InnerException.Message End If If bCopyErrMsgClipboard Then CopyToClipboard(sMsg) sMsg &= vbCrLf & "(this error message has been copied into the clipboard)" End If sFinalErrMsg = sMsg MsgBox(sMsg, MsgBoxStyle.Critical, m_sMsgTitle) End Sub Public Sub CopyToClipboard(sInfo$) ' Copy text into Windows clipboard (until the application is closed) Try Dim dataObj As New DataObject dataObj.SetData(DataFormats.Text, sInfo) Clipboard.SetDataObject(dataObj) Catch ex As Exception ' The clipboard can be unavailable ShowErrorMsg(ex, "CopyToClipboard", bCopyErrMsgClipboard:=False) End Try End Sub Public Function is64BitProcess() As Boolean Return (IntPtr.Size = 8) End Function #Region "Documentation" ''' <summary> ''' If a child ToolStripStatusLabel is wider than it's parent then this method will attempt to ''' make the child's text fit inside of the parent's boundaries. An ellipsis can be appended ''' at the end of the text to indicate that it has been truncated to fit. ''' </summary> ''' <param name="child">Child ToolStripStatusLabel</param> ''' <param name="parent">Parent control where the ToolStripStatusLabel resides</param> ''' <param name="appendEllipsis">Append an "..." to the end of the truncated text</param> #End Region Public Sub TruncateChildTextAccordingToControlWidth(child As ToolStripLabel, parent As Control, appendEllipsis As Boolean) ' http://stackoverflow.com/questions/5708375/how-can-i-determine-how-much-of-a-string-will-fit-in-a-certain-width ' If the child's width is greater than that of the parent's Const rPadding = 0.1 'If child.Size.Width >= parent.Size.Width * 0.9 Then If child.Size.Width >= parent.Size.Width * (1 - rPadding) Then ' Get the number of times that the child is oversized [child/parent] Dim decOverSized As Decimal = CDec(child.Size.Width) / CDec(parent.Size.Width) ' Get the new Text length based on the number of times that the child's width is oversized. 'Dim iNewLength% = CInt(child.Text.Length / (2D * decOverSized)) Dim iNewLength% = CInt(child.Text.Length / ((1 + rPadding) * decOverSized)) ' Doubling as a buffer (Magic Number). ' If the ellipsis is to be appended If appendEllipsis Then ' then 3 more characters need to be removed to make room for it. iNewLength = iNewLength - 3 End If ' If the new length is negative for whatever reason If iNewLength < 0 Then iNewLength = 0 ' Then default it to zero ' Truncate the child's Text accordingly If child.Text.Length >= iNewLength Then _ child.Text = child.Text.Substring(0, iNewLength) ' If the ellipsis is to be appended If appendEllipsis Then child.Text += "..." ' Then do this last End If End Sub ' GC.Collect is rarely usefull <CodeAnalysis.SuppressMessage("Microsoft.Reliability", "CA2001:AvoidCallingProblematicMethods", MessageId:="System.GC.Collect")> Public Sub FreeDotNetRAM(Optional bComResources As Boolean = False) ' Clean up managed, and unmanaged COM resources if bComResources is True ' Clean up the unmanaged COM resources by forcing a garbage ' collection as soon as the calling function is off the stack ' (at which point these objects are no longer rooted). GC.Collect() If bComResources Then GC.WaitForPendingFinalizers() ' GC needs to be called twice in order to get the Finalizers called ' - the first time in, it simply makes a list of what is to be ' finalized, the second time in, it actually is finalizing. Only ' then will the object do its automatic ReleaseComObject. GC.Collect() GC.WaitForPendingFinalizers() End If End Sub Public Function sRAMInfo$(Optional sMsg$ = "RAM : ") Dim ci = Globalization.CultureInfo.CurrentCulture() Dim x As Process = System.Diagnostics.Process.GetCurrentProcess Dim lAllocatedRamByApp& = x.WorkingSet64 Dim sAllocatedRamByApp$ = sDisplaySizeInBytes(lAllocatedRamByApp) ' In 32 bits, only 1.6 Gb can be allocated (inside Visual Studio or not) If Not is64BitProcess() Then Dim lRamAvailable32 As ULong = CULng(1.6 * 1024 * 1024 * 1024) ' 1.6 Go If lRamAvailable32 < My.Computer.Info.AvailablePhysicalMemory Then lRamAvailable32 = My.Computer.Info.AvailablePhysicalMemory End If Dim sRamAvailable32$ = sDisplaySizeInBytes(CLng(lRamAvailable32)) Dim rPCRAMUsed32! = CSng(lAllocatedRamByApp / lRamAvailable32) Dim sRam32$ = sMsg & sAllocatedRamByApp & " / " & sRamAvailable32 & " (" & rPCRAMUsed32.ToString("0.0 %", ci) & ")" Return sRam32 End If Dim lRamAvailable As ULong = My.Computer.Info.AvailablePhysicalMemory 'Dim sRamAvailable$ = sDisplaySizeInBytes(CLng(lRamAvailable)) Dim lRamTot As ULong = My.Computer.Info.TotalPhysicalMemory Dim sRamTot$ = sDisplaySizeInBytes(CLng(lRamTot)) Dim lTotAllocated As ULong = lRamTot - lRamAvailable Dim sTotAllocatedRAM$ = sDisplaySizeInBytes(CLng(lTotAllocated)) Dim lAllocatedByOtherProc As ULong = CULng(lTotAllocated - lAllocatedRamByApp) Dim sAllocatedByOtherProc$ = sDisplaySizeInBytes(CLng(lAllocatedByOtherProc)) Dim rPCRAMUsed! = CSng(lTotAllocated / lRamTot) Dim sRam$ = sMsg & sAllocatedRamByApp & " + " & sAllocatedByOtherProc & " = " & sTotAllocatedRAM & " / " & sRamTot & " (" & rPCRAMUsed.ToString("0.0 %", ci) & ")" Return sRam End Function <MethodImpl(MethodImplOptions.AggressiveInlining)> Public Function rFastConv#(sValue$, Optional rDef! = 0.0!, Optional ByRef bOK As Boolean = True) bOK = False If String.IsNullOrEmpty(sValue) Then Return rDef Dim rVal# If Double.TryParse(sValue, rVal) Then bOK = True : Return rVal Else Dim sVal2$ = sValue.Replace(sDot, sComma) If Double.TryParse(sVal2, rVal) Then bOK = True : Return rVal Dim sVal3$ = sValue.Replace(sComma, sDot) If Double.TryParse(sVal3, rVal) Then bOK = True : Return rVal Return rDef End If End Function End Module modUtilFile.vb ' File modUtilFile.vb : Utility module for files and folders ' ------------------- Imports System.Text ' For Encoding Imports System.Runtime.CompilerServices ' For MethodImpl(MethodImplOptions.AggressiveInlining) Module modUtilFile Public Const sPossibleErrCause$ = "The file may be write-protected or locked by another software" #Region "Reading files" Public Function bFileExists(sFilePath$, Optional bPrompt As Boolean = False) As Boolean ' Return True if the specified file is found ' Note : It doesn't work with filter, for ex. C:\*.txt Dim bExists As Boolean = IO.File.Exists(sFilePath) If Not bExists AndAlso bPrompt Then _ MsgBox("Can't find file : " & IO.Path.GetFileName(sFilePath) & vbLf & sFilePath, MsgBoxStyle.Critical, m_sMsgTitle & " - File not found") Return bExists End Function Public Function bFileIsWritable(sFilePath$, Optional bPrompt As Boolean = False, Optional bPromptClose As Boolean = False, Optional bNonExistentOk As Boolean = False, Optional bPromptRetry As Boolean = False) As Boolean ' Check first if the file is locked by a software, in order to prompt user to close it If Not bFileIsAvailable(sFilePath, bPrompt, bPromptClose, bNonExistentOk, bPromptRetry, bCheckForSlowRead:=True) Then Return False ' And then check if the file is not write-protected If Not bFileIsAvailable(sFilePath, bPrompt, bPromptClose, bNonExistentOk, bPromptRetry) Then _ Return False Return True End Function ' Attribute to prevent the IDE to stop in this function if an exception is thrown <System.Diagnostics.DebuggerStepThrough()> Public Function bFileIsAvailable(sFilePath$, Optional bPrompt As Boolean = False, Optional bPromptClose As Boolean = False, Optional bNonExistentOk As Boolean = False, Optional bPromptRetry As Boolean = False, Optional bCheckForReadOnly As Boolean = False, Optional bCheckForSlowRead As Boolean = False) As Boolean ' Check if a file is available for read/write (for example if a file is not locked by Excel) ' bNonExistentOk : If the file does not exist, it is writable ' bCheckForReadOnly : Check if the file can be opened at least for read only ' bCheckForSlowRead : Throw an exception if the file is locked for example in Excel : ' reading the file may be very slow in this case Retry: If bNonExistentOk Then ' If the file does not exist, it is writable : return True without any alert If Not bFileExists(sFilePath) Then Return True Else If Not bFileExists(sFilePath, bPrompt) Then Return False End If 'Retry: Dim answer As MsgBoxResult = MsgBoxResult.Cancel Dim fs As IO.FileStream = Nothing Try ' If Excel locked the file, the file can still be open for reading ' if the sharing mode is also set to IO.FileShare.ReadWrite Dim mode As IO.FileMode = IO.FileMode.Open Dim access As IO.FileAccess = IO.FileAccess.ReadWrite If bCheckForReadOnly Then access = IO.FileAccess.Read Dim share = IO.FileShare.ReadWrite ' bCheckForSlowRead : Throw an exception to check for slowness risk If bCheckForSlowRead Then share = IO.FileShare.Read : access = IO.FileAccess.Read fs = New IO.FileStream(sFilePath, mode, access, share) fs.Close() fs = Nothing Return True Catch ex As Exception Dim msgbs As MsgBoxStyle = MsgBoxStyle.Exclamation Dim sQuestion$ = "" If bPromptRetry Then msgbs = msgbs Or MsgBoxStyle.RetryCancel sQuestion = vbLf & "Retry ?" End If If bCheckForSlowRead AndAlso (bPrompt OrElse bPromptClose OrElse bPromptRetry) Then answer = MsgBox( "Please close the file : " & IO.Path.GetFileName(sFilePath) & vbLf & sFilePath & sQuestion, msgbs, m_sMsgTitle) ElseIf bPromptClose OrElse bPromptRetry Then If bCheckForReadOnly Then ' The file cannot be read for various causes (insufficient read privileges, ' file locked by another application, ...) answer = MsgBox("The file cannot be read : " & IO.Path.GetFileName(sFilePath) & vbLf & sFilePath & vbLf & "Please close the file, if it is opened, or change" & vbLf & "his read attributes, if it is appropriate." & sQuestion, msgbs, m_sMsgTitle) Else answer = MsgBox("The file is write-protected : " & IO.Path.GetFileName(sFilePath) & vbLf & sFilePath & vbLf & "Please close the file, if it is opened, or change" & vbLf & "his write attributes, if it is appropriate." & sQuestion, msgbs, m_sMsgTitle) End If ElseIf bPrompt Then ShowErrorMsg(ex, "bFileIsAvailable", "The file cannot be accessed : " & IO.Path.GetFileName(sFilePath) & vbCrLf & sFilePath, sPossibleErrCause) End If Finally If fs IsNot Nothing Then fs.Dispose() ' CA2000 End Try If answer = MsgBoxResult.Retry Then GoTo Retry Return False End Function ''' <summary> ''' Determines a text file's encoding by analyzing its Byte Order Mark (BOM). ''' Defaults to ASCII when detection of the text file's endianness fails. ''' </summary> ''' <param name="filename">The text file to analyze.</param> ''' <returns>The detected encoding.</returns> Public Function GetEncoding(filename As String) As Encoding ' https://en.wikipedia.org/wiki/Byte_order_mark ' UTF-16 Big Endian: FE FF ' UTF-16 Little Endian: FF FE ' UTF-8 : EF BB BF ' SCSU : 0E FE FF ' BOCU-1: FB EE 28 ' UTF-1 : F7 64 4C ' UTF-32 Big Endian: 00 00 FE FF ' UTF-32 Little Endian: FF FE 00 00 ' UTF-EBCDIC : DD 73 66 73 ' UTF-7 : 2B 2F 76 and one of the following bytes: ' [ 38 | 39 | 2B | 2F ] ' Read the BOM Dim bom = New Byte(3) {} Using file = New IO.FileStream(filename, IO.FileMode.Open, IO.FileAccess.Read, IO.FileShare.ReadWrite) ' 05/01/2018 Need only read-only access, not write access file.Read(bom, 0, 4) End Using ' Analyze the BOM ' UTF-16 Big Endian : FE FF ' UTF-16 Little Endian : FF FE If bom(0) = &HFE AndAlso bom(1) = &HFF Then Return Encoding.BigEndianUnicode ' UTF-16 If bom(0) = &HFF AndAlso bom(1) = &HFE Then Return Encoding.Unicode ' UTF-8 : EF BB BF ' SCSU : 0E FE FF ' BOCU-1 : FB EE 28 ' UTF-1 : F7 64 4C If bom(0) = &HEF AndAlso bom(1) = &HBB AndAlso bom(2) = &HBF Then Return Encoding.UTF8 'If bom(0) = &H0E AndAlso bom(1) = &HFE AndAlso bom(2) = &HFF Then Return Encoding.SCSU 'If bom(0) = &HFB AndAlso bom(1) = &HEE AndAlso bom(2) = &H28 Then Return Encoding.BOCU-1 'If bom(0) = &HF7 AndAlso bom(1) = &H64 AndAlso bom(2) = &H4C Then Return Encoding.UTF-1 ' UTF-32 Big Endian: 00 00 FE FF ' UTF-32 Little Endian: FF FE 00 00 ' UTF-EBCDIC : DD 73 66 73 ' UTF-7 : 2B 2F 76 and one of the following bytes: ' [ 38 | 39 | 2B | 2F ] If bom(0) = &H0 AndAlso bom(1) = &H0 AndAlso bom(2) = &HFE AndAlso bom(3) = &HFF Then 'Return Encoding.BigEndianUnicode : UTF16<>UTF32 End If If bom(0) = &HFF AndAlso bom(1) = &HFE AndAlso bom(2) = &H0 AndAlso bom(3) = &H0 Then Return Encoding.UTF32 End If If bom(0) = &HDD AndAlso bom(1) = &H73 AndAlso bom(2) = &H66 AndAlso bom(3) = &H73 Then 'Return Encoding.UTF-EBCDIC End If If bom(0) = &H2B AndAlso bom(1) = &H2F AndAlso bom(2) = &H76 AndAlso (bom(3) = &H38 OrElse bom(3) = &H39 OrElse bom(3) = &H2B OrElse bom(3) = &H2F) Then Return Encoding.UTF7 End If Return Encoding.ASCII End Function Public Function GetEncodingPreviousVersion(filename As String) As Encoding ' https://en.wikipedia.org/wiki/Byte_order_mark ' Read the BOM Dim bom = New Byte(3) {} Using file = New IO.FileStream(filename, IO.FileMode.Open, IO.FileAccess.Read, IO.FileShare.ReadWrite) ' 05/01/2018 Need only read-only access, not write access file.Read(bom, 0, 4) End Using ' Analyze the BOM If bom(0) = &H2B AndAlso bom(1) = &H2F AndAlso bom(2) = &H76 Then Return Encoding.UTF7 End If If bom(0) = &HEF AndAlso bom(1) = &HBB AndAlso bom(2) = &HBF Then Return Encoding.UTF8 End If ' 25/01/2019 If bom(0) = &H4E AndAlso bom(1) = &HC2 AndAlso bom(2) = &HB0 Then Return Encoding.UTF8 End If ' 28/02/2016 If bom(0) = &H22 AndAlso bom(1) = &H43 AndAlso bom(2) = &H6F AndAlso bom(3) = &H75 Then Return Encoding.UTF8 End If ' 08/05/2017 If bom(0) = 50 AndAlso bom(1) = 48 AndAlso bom(2) = 49 AndAlso bom(3) = 54 Then Return Encoding.UTF8 End If ' 19/05/2017 If bom(0) = 34 AndAlso bom(1) = 105 AndAlso bom(2) = 100 AndAlso bom(3) = 34 Then Return Encoding.UTF8 End If If bom(0) = &HFF AndAlso bom(1) = &HFE Then Return Encoding.Unicode End If 'UTF-16LE If bom(0) = &HFE AndAlso bom(1) = &HFF Then Return Encoding.BigEndianUnicode End If 'UTF-16BE If bom(0) = 0 AndAlso bom(1) = 0 AndAlso bom(2) = &HFE AndAlso bom(3) = &HFF Then Return Encoding.UTF32 End If ' 22/10/2021 If bom(0) = 44 AndAlso bom(1) = 34 AndAlso bom(2) = 78 AndAlso bom(3) = 111 Then Return Encoding.UTF8 End If Return Encoding.ASCII End Function ''' <summary> ''' Determines a text file's encoding by analyzing its Byte Order Mark (BOM). ''' Defaults to ASCII when detection of the text file's endianness fails. ''' </summary> ''' <param name="filename">The text file to analyze.</param> ''' <returns>The detected encoding.</returns> Public Function GetEncodingTEC(filename As String) As Encoding ' Version using text-encoding-detect: ' https://github.com/AutoItConsulting/text-encoding-detect Dim buffer As Byte() Try ' No, avoid reading all bytes, there may be large files 'buffer = IO.File.ReadAllBytes(sChemin) buffer = abReadFile(filename, iMaxSizeBytes:=1000) Dim textDetect As New TextEncodingDetect() Dim encodingAutoIt As TextEncodingDetect.Encoding = textDetect.DetectEncoding(buffer, buffer.Length) Select Case encodingAutoIt Case TextEncodingDetect.Encoding.None Case TextEncodingDetect.Encoding.Ansi Case TextEncodingDetect.Encoding.Ascii Return Encoding.ASCII Case TextEncodingDetect.Encoding.Utf8Bom Return Encoding.UTF8 Case TextEncodingDetect.Encoding.Utf8Nobom Return Encoding.UTF8 Case TextEncodingDetect.Encoding.Utf16BeBom Return Encoding.BigEndianUnicode Case TextEncodingDetect.Encoding.Utf16BeNoBom Return Encoding.BigEndianUnicode Case TextEncodingDetect.Encoding.Utf16LeBom Return Encoding.Unicode Case TextEncodingDetect.Encoding.Utf16LeNoBom Return Encoding.Unicode End Select Catch End Try Return Encoding.ASCII End Function Public Function asReadFile(sFilePath$, Optional bReadOnly As Boolean = False, Optional bCheckCrCrLf As Boolean = False, Optional bUnicodeUTF8 As Boolean = False, Optional bWindows1252 As Boolean = False, Optional encod As Encoding = Nothing) As String() ' Read and return the file content as an array of String If Not bFileExists(sFilePath, bPrompt:=True) Then Return Nothing Dim fs As IO.FileStream = Nothing Try Dim encod0 As Encoding If bUnicodeUTF8 Then encod0 = Encoding.UTF8 ElseIf bWindows1252 Then ' Latin alphabet for English and for some other Western languages encod0 = Encoding.GetEncoding(1252) ElseIf Not IsNothing(encod) Then encod0 = encod Else encod0 = Encoding.Default End If If bReadOnly Then ' If Excel locked the file, the file can still be open for reading ' if the sharing mode is also set to IO.FileShare.ReadWrite fs = New IO.FileStream(sFilePath, IO.FileMode.Open, IO.FileAccess.Read, IO.FileShare.ReadWrite) Using sr As New IO.StreamReader(fs, encod0) fs = Nothing ' Do exactly as sr.ReadLine() Dim sStream As New clsStringStream(sr.ReadToEnd) Return sStream.asLines(bCheckCrCrLf) End Using Else Return IO.File.ReadAllLines(sFilePath, encod0) End If Catch ex As Exception ShowErrorMsg(ex, "asReadFile") Return Nothing Finally If fs IsNot Nothing Then fs.Dispose() ' CA2000 End Try End Function Private Function abReadFile(sChemin$, Optional iMaxSizeBytes% = -1) As Byte() ' Read a file in binary mode, like ReadAllBytes, but only ' the beginning of the file (the first 1000 bytes) Dim abBuffer As Byte() Try ' If we do not specify a size limit, then we read everything If iMaxSizeBytes <= 0 Then abBuffer = IO.File.ReadAllBytes(sChemin) Return abBuffer End If ' If we only need to read the header in binary mode, then limit the reading Using flux As IO.FileStream = IO.File.Open(sChemin, IO.FileMode.Open) abBuffer = New Byte(iMaxSizeBytes - 1) {} Dim iNbOctetsLus% = flux.Read(abBuffer, 0, iMaxSizeBytes) If iNbOctetsLus <= 0 Then Return abBuffer Dim bufferDest As Byte() bufferDest = New Byte(iNbOctetsLus - 1) {} Array.Copy(abBuffer, bufferDest, iNbOctetsLus) Return bufferDest End Using Return abBuffer Catch ex As Exception ShowErrorMsg(ex, "abReadFile") Return Nothing End Try End Function Public Function bLetOpenFile(sFilePath$, Optional bCheckFile As Boolean = True, Optional sInfo$ = "") As Boolean ' Don't check file if it is a URL, for example If bCheckFile AndAlso Not bFileExists(sFilePath, bPrompt:=True) Then Return False Dim lFileSize& = (New IO.FileInfo(sFilePath)).Length Dim sFileSize$ = sDisplaySizeInBytes(lFileSize) Dim sMsg$ = "File created successfully : " & IO.Path.GetFileName(sFilePath) & vbLf & sFilePath If sInfo.Length > 0 Then sMsg &= vbLf & sInfo sMsg &= vbLf & "Would you like to open it ? (" & sFileSize & ")" If MsgBoxResult.Cancel = MsgBox(sMsg, MsgBoxStyle.Exclamation Or MsgBoxStyle.OkCancel, m_sMsgTitle) Then Return False StartAssociateApp(sFilePath) Return True End Function Public Sub LetOpenFile(sFilePath$, Optional sInfo$ = "") If Not bFileExists(sFilePath, bPrompt:=True) Then Exit Sub Dim lFileSize& = (New IO.FileInfo(sFilePath)).Length Dim sFileSize$ = sDisplaySizeInBytes(lFileSize) Dim sMsg$ = "File created successfully : " & IO.Path.GetFileName(sFilePath) & vbLf & sFilePath If sInfo.Length > 0 Then sMsg &= vbLf & sInfo sMsg &= vbLf & "Would you like to open it ? (" & sFileSize & ")" If MsgBoxResult.Cancel = MsgBox(sMsg, MsgBoxStyle.Exclamation Or MsgBoxStyle.OkCancel, m_sMsgTitle) Then Exit Sub StartAssociateApp(sFilePath) End Sub Public Sub StartAssociateApp(sFilePath$, Optional bMaximized As Boolean = False, Optional bCheckFile As Boolean = True, Optional sArguments$ = "") If bCheckFile Then ' Don't check file if it is a URL to browse If Not bFileExists(sFilePath, bPrompt:=True) Then Exit Sub End If Using p As New Process p.StartInfo = New ProcessStartInfo(sFilePath) p.StartInfo.Arguments = sArguments If bMaximized Then p.StartInfo.WindowStyle = ProcessWindowStyle.Maximized p.Start() End Using End Sub Public Function sDisplaySizeInBytes$(lSizeInBytes&, Optional bShowDetails As Boolean = False, Optional bRemoveDot0 As Boolean = False) ' Return a file size in a correct string format ' (see also StrFormatByteSizeA API in shlwapi.dll) Dim rNbKb! = CSng(Math.Round(lSizeInBytes / 1024, 1)) Dim rNbMb! = CSng(Math.Round(lSizeInBytes / (1024 * 1024), 1)) Dim rNbGb! = CSng(Math.Round(lSizeInBytes / (1024 * 1024 * 1024), 1)) Dim sResult$ = "" If bShowDetails Then sResult = sDisplayNumeric(lSizeInBytes) & " bytes" If rNbKb >= 1 Then sResult &= " (" & sDisplayNumeric(rNbKb) & " Kb" If rNbMb >= 1 Then sResult &= " = " & sDisplayNumeric(rNbMb) & " Mb" If rNbGb >= 1 Then sResult &= " = " & sDisplayNumeric(rNbGb) & " Gb" If rNbKb >= 1 Or rNbMb >= 1 Or rNbGb >= 1 Then sResult &= ")" Else If rNbGb >= 1 Then sResult = sDisplayNumeric(rNbGb, bRemoveDot0) & " Gb" ElseIf rNbMb >= 1 Then sResult = sDisplayNumeric(rNbMb, bRemoveDot0) & " Mb" ElseIf rNbKb >= 1 Then sResult = sDisplayNumeric(rNbKb, bRemoveDot0) & " Kb" Else sResult = sDisplayNumeric(lSizeInBytes, bRemoveDot0:=True) & " bytes" End If End If sDisplaySizeInBytes = sResult End Function Public Function sDisplayTime$(rNbSeconds#) ' Return a during time in a String Dim sDisplay$ = "" Dim sSep$ = "" Dim rNbMn# = rNbSeconds / 60 Dim rNbHours# = rNbMn / 60 Dim rNbDays# = rNbHours / 24 Dim iNbDays% = CInt(Fix(rNbDays)) If iNbDays >= 1 Then sDisplay &= sSep & iNbDays & " d." : sSep = " " rNbHours -= iNbDays * 24 rNbMn -= iNbDays * 24 * 60 rNbSeconds -= iNbDays * 24 * 3600 End If Dim iNbHours% = CInt(Fix(rNbHours)) If iNbHours >= 1 Then sDisplay &= sSep & iNbHours & " h." : sSep = " " rNbMn -= iNbHours * 60 rNbSeconds -= iNbHours * 3600 End If Dim iNbMn% = CInt(Fix(rNbMn)) If iNbMn >= 1 Then sDisplay &= sSep & iNbMn & " mn" : sSep = " " rNbSeconds -= iNbMn * 60 End If Dim rNbSecondsSng! = CSng(rNbSeconds) ' 14/12/2016 Hide 0 sec. if there are mn, h or days If rNbSecondsSng = 0 AndAlso (iNbMn > 0 OrElse iNbHours > 0 OrElse iNbDays > 0) Then ' Display nothing else ElseIf rNbSeconds >= 0 Then sDisplay &= sSep & sDisplayNumeric(rNbSecondsSng, bRemoveDot0:=True) & " sec." End If Return sDisplay End Function Public Function sDisplayNumeric$(rValue!, Optional bRemoveDot0 As Boolean = True, Optional iNbDigits% = 1) ' Show a numeric with 1 digit accuracy by default ' The standard numeric format is correct, ' we just have to remove useless ending dot if the value is zero Dim nfi As Globalization.NumberFormatInfo = New Globalization.NumberFormatInfo nfi.NumberGroupSeparator = " " ' Thousand and million separator... Const sDot$ = "." nfi.NumberDecimalSeparator = sDot ' Decimal separator ' 3 groups for billion, million and thousand nfi.NumberGroupSizes = New Integer() {3, 3, 3} nfi.NumberDecimalDigits = iNbDigits ' 1 digit accuracy Dim sResult$ = rValue.ToString("n", nfi) ' n : general numeric If bRemoveDot0 Then If iNbDigits = 1 Then sResult = sResult.Replace(".0", "") ElseIf iNbDigits > 1 Then Dim i% Dim sb As New StringBuilder(sDot) For i = 1 To iNbDigits : sb.Append("0") : Next sResult = sResult.Replace(sb.ToString, "") End If End If Return sResult End Function #End Region #Region "Writing files" ' Attribute to prevent the IDE to stop in this function if an exception is thrown <System.Diagnostics.DebuggerStepThrough()> Public Function bFileLocked(sFilePath$, Optional bReadOnly As Boolean = False, Optional bNonExistentOk As Boolean = False, Optional bPrompt As Boolean = False, Optional bPromptClose As Boolean = False, Optional bPromptRetry As Boolean = False) As Boolean ' Check if a file is locked, for writing or just reading ' (for example if a file is not locked by Excel) ' bReadOnly : Check if a file is locked just for reading ' bNonExistentOk : If the file doesn't exist yet then there is no problem ' bPrompt : Alert the user, otherwise continue ' bPromptClose : Alert the user to close the file (if bPrompt is set to false) ' bPromptRetry : Alert the user to close the file again and again, ' while the file is locked (if bPrompt is set to false) Dim bLocked As Boolean = True If bNonExistentOk Then If Not bFileExists(sFilePath) Then Return False ' It does not exist so it is not locked Else ' It does not exists so it can't be read nor written If Not bFileExists(sFilePath, bPrompt) Then Return True End If Retry: Dim userResponse As MsgBoxResult = MsgBoxResult.Cancel Try ' If Excel locked the file, the file can still be open for reading ' if the sharing mode is also set to IO.FileShare.ReadWrite Dim mode As IO.FileMode = IO.FileMode.Open Dim access As IO.FileAccess = IO.FileAccess.ReadWrite If bReadOnly Then access = IO.FileAccess.Read Using fs As New IO.FileStream(sFilePath, mode, access, IO.FileShare.ReadWrite) End Using ' fs.Close() bLocked = False Catch ex As Exception Dim msgbs As MsgBoxStyle = MsgBoxStyle.Exclamation If bPrompt Then ShowErrorMsg(ex, "bFileLocked", "Can't access to the file : " & IO.Path.GetFileName(sFilePath) & vbCrLf & sFilePath, sPossibleErrCause) ElseIf bPromptClose OrElse bPromptRetry Then Dim sQuestion$ = "" If bPromptRetry Then msgbs = msgbs Or MsgBoxStyle.RetryCancel sQuestion = vbLf & "Retry ?" End If If bReadOnly Then userResponse = MsgBox("Please close the file : " & IO.Path.GetFileName(sFilePath) & vbLf & sFilePath & sQuestion, msgbs, m_sMsgTitle) Else userResponse = MsgBox("The file can't be written : " & IO.Path.GetFileName(sFilePath) & vbLf & sFilePath & vbLf & "Please close it as the case may be, or change it's attributes," & vbLf & "or its permissions." & sQuestion, msgbs, m_sMsgTitle) End If End If End Try If bLocked And userResponse = MsgBoxResult.Retry Then GoTo Retry Return bLocked End Function Public Function bDeleteFile(sFilePath$, Optional bPromptIfErr As Boolean = False) As Boolean If Not bFileExists(sFilePath) Then Return True If bFileLocked(sFilePath, bPromptClose:=bPromptIfErr, bPromptRetry:=bPromptIfErr) Then _ Return False Try IO.File.Delete(sFilePath) Return True Catch ex As Exception If bPromptIfErr Then _ ShowErrorMsg(ex, "Can't delete file : " & IO.Path.GetFileName(sFilePath) & vbCrLf & sFilePath, sPossibleErrCause) Return False End Try End Function Public Function bWriteFile(sFilePath$, sbContenu As StringBuilder, Optional bDefautEncoding As Boolean = True, Optional encode As Encoding = Nothing, Optional bPromptIfErr As Boolean = True, Optional bAppend As Boolean = False, Optional ByRef sMsgErr$ = "") As Boolean If Not bAppend AndAlso Not bDeleteFile(sFilePath, bPromptIfErr:=True) Then Return False Try If bDefautEncoding Then encode = Encoding.Default Using sw As New IO.StreamWriter(sFilePath, append:=bAppend, encoding:=encode) sw.Write(sbContenu.ToString()) End Using Return True Catch ex As Exception Dim sMsg$ = "Can't write file : " & IO.Path.GetFileName(sFilePath) & vbCrLf & sFilePath & vbCrLf & sPossibleErrCause sMsgErr = sMsg & vbCrLf & ex.Message If bPromptIfErr Then ShowErrorMsg(ex, "bWriteFile", sMsg) Return False End Try End Function #End Region #Region "String stream class" ' Equivalent of mscorlib.dll: System.IO.StreamReader.ReadLine() As String ' but for a string Public Class clsStringStream Private m_iNumLine% = 0 ' Debug Private m_sString$ Private m_iPos% = 0 Private c13 As Char = ChrW(13) ' vbCr Private c10 As Char = ChrW(10) ' vbLf Public Sub New(sString$) m_sString = sString End Sub Public Function asLines(Optional bCheckCrCrLf As Boolean = False) As String() Dim lst As New Collections.Generic.List(Of String) Dim iNumLine2% = 0 Do Dim sLine$ = StringReadLine(bCheckCrCrLf) If IsNothing(sLine) Then sLine = "" lst.Add(sLine) iNumLine2 += 1 Loop While m_iPos < m_sString.Length Return lst.ToArray End Function ' Attribute for inline to avoid function overhead <MethodImpl(MethodImplOptions.AggressiveInlining)> Public Function StringReadLine$(Optional bCheckCrCrLf As Boolean = False) If String.IsNullOrEmpty(m_sString) Then Return Nothing Dim iLong% = m_sString.Length Dim iNum% = m_iPos Do While iNum < iLong Dim ch As Char = m_sString.Chars(iNum) Select Case ch Case c13, c10 Dim str$ = m_sString.Substring(m_iPos, iNum - m_iPos) m_iPos = iNum + 1 If Not bCheckCrCrLf Then If ch = c13 AndAlso m_iPos < iLong AndAlso m_sString.Chars(m_iPos) = c10 Then m_iPos += 1 Return str End If Dim chNext As Char If m_iPos < iLong Then chNext = m_sString.Chars(m_iPos) Dim chNext2 As Char If m_iPos < iLong - 1 Then chNext2 = m_sString.Chars(m_iPos + 1) If ch = c13 AndAlso m_iPos < iLong - 1 AndAlso chNext = c13 AndAlso chNext2 = c10 Then m_iPos += 2 ElseIf ch = c13 AndAlso m_iPos < iLong AndAlso chNext = c10 Then m_iPos += 1 End If m_iNumLine += 1 Return str End Select iNum += 1 Loop If iNum > m_iPos Then Dim str2$ = m_sString.Substring(m_iPos, iNum - m_iPos) m_iPos = iNum m_iNumLine += 1 Return str2 End If Return Nothing End Function End Class #End Region Public Function asCmdLineArg(sCmdLine$, Optional bRemoveSpaces As Boolean = True) As String() ' Return arguments of the command line ' "Filenames with spaces are quoted", FilenamesWhihoutSpaceAreNotQuoted ' Example : "Filename with spaces 1" UnspacedFilename "Filename with spaces 2" Dim asArgs$() = Nothing If String.IsNullOrEmpty(sCmdLine) Then ReDim asArgs(0) asArgs(0) = "" asCmdLineArg = asArgs Exit Function End If Dim lstArgs As New List(Of String) ' 16/10/2016 Const iASCQuotes% = 34 Const sDbleQuote$ = """" ' Only one " in fact : Chr$(34) Dim sFile$, sDelimiter$ Dim sCmd$, iCmdLen%, iEnd%, iStart%, iStart2% Dim bEnd As Boolean, bQuotedFile As Boolean Dim iNextCar% = 1 sCmd = sCmdLine iCmdLen = Len(sCmd) iStart = 1 Do bQuotedFile = False : sDelimiter = " " If Mid(sCmd, iStart, 2) = sDbleQuote & sDbleQuote Then bQuotedFile = True : sDelimiter = sDbleQuote iEnd = iStart + 1 GoTo NextItem End If If Mid(sCmd, iStart, 1) = sDbleQuote Then bQuotedFile = True : sDelimiter = sDbleQuote iStart2 = iStart If bQuotedFile AndAlso iStart2 < iCmdLen Then iStart2 += 1 iEnd = InStr(iStart2 + 1, sCmd, sDelimiter) ' 16/10/2016 DblQuote " can replace space iNextCar = 1 Dim iQuotedEnd% = InStr(iStart2 + 1, sCmd, sDbleQuote) If iQuotedEnd > 0 AndAlso iEnd > 0 AndAlso iQuotedEnd < iEnd Then iEnd = iQuotedEnd : bQuotedFile = True : sDelimiter = sDbleQuote : iNextCar = 0 End If If iEnd = 0 Then bEnd = True : iEnd = iCmdLen + 1 sFile = Mid(sCmd, iStart2, iEnd - iStart2) If bRemoveSpaces Then sFile = Trim$(sFile) If sFile.Length > 0 Then lstArgs.Add(sFile) If bEnd Or iEnd = iCmdLen Then Exit Do NextItem: iStart = iEnd + iNextCar ' 1 ' 16/10/2016 DblQuote " can replace space 'If bQuotedFile Then iStart = iEnd + 2 If iStart > iCmdLen Then Exit Do Loop asArgs = lstArgs.ToArray() For iNumArg As Integer = 0 To UBound(asArgs) Dim sArg$ = asArgs(iNumArg) Dim iLen% = Len(sArg) If iLen = 1 AndAlso Asc(sArg.Chars(0)) = iASCQuotes Then asArgs(iNumArg) = "" Next iNumArg Return asArgs End Function End Module modUtilReg.vb ' File modUtilReg.vb : Registry module utility ' ------------------ Imports Microsoft.Win32 Module modUtilReg ' Microsoft Win32 to Microsoft .NET Framework API Map : Registry Functions ' http://msdn.microsoft.com/en-us/library/aa302340.aspx#win32map_registryfunctions Public Const sShellKey$ = "shell" Public Const sCmdKey$ = "command" Private Const sMsgErrPossibleCause$ = "Possible cause : adding context menus requires administrator privileges" & vbCrLf & "Run as admin. the application for this operation" Public Function bAddContextMenuFileType(sExtension$, sFileType$, Optional sExtensionDescription$ = "", Optional bRemove As Boolean = False) As Boolean ' Add (or Remove) in the registry a ClassesRoot file type ' to associate a file extension to a default application ' (via double-click or for example the context menu Open, see the next function bAddContextMenu) ' Example : associate .dat file extension to MyApplication.exe Try If bRemove Then If bClassesRootRegistryKeyExists(sExtension) Then Registry.ClassesRoot.DeleteSubKeyTree(sExtension) End If Else If Not bClassesRootRegistryKeyExists(sExtension) Then Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sExtension) rk.SetValue("", sFileType) If sExtensionDescription.Length > 0 Then rk.SetValue("Content Type", sExtensionDescription) End If End Using End If End If Return True Catch ex As Exception ShowErrorMsg(ex, "bAddContextMenuFileType", sMsgErrPossibleCause) Return False End Try End Function Public Function bAddContextMenu(sFileType$, sCmd$, Optional bPrompt As Boolean = True, Optional bRemove As Boolean = False, Optional sCmdDescription$ = "", Optional sExePath$ = "", Optional sCmdDef$ = """%1""", Optional sFileTypeDescription$ = "", Optional bRemoveFileType As Boolean = False) As Boolean ' Add (or Remove) in the registry a context menu for a ClassesRoot file type ' (see the previous function bAddContextMenuFileType) ' to associate a command menu for a file extension (or for every file) to a default application ' (via double-click or the context menu Open, for example, in the Windows File Explorer) ' Example one : associate the menu Open for .dat file extension to MyApplication.exe ' Example two : associate the menu Open for every file to MyApplication.exe ' Example three : associate the menu Print for .doc file extension to MyApplication.exe ' Example four : associate the menu Search for every folder to MyApplication.exe Try ' Fisrt check the main key If Not bClassesRootRegistryKeyExists(sFileType) Then If bRemove Then bAddContextMenu = True : Exit Function Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sFileType) If sFileTypeDescription.Length > 0 Then rk.SetValue("", sFileTypeDescription) End If End Using End If Dim sCleDescriptionCmd$ = sFileType & "\" & sShellKey & "\" & sCmd If bRemove Then If bRemoveFileType Then If bClassesRootRegistryKeyExists(sFileType) Then Registry.ClassesRoot.DeleteSubKeyTree(sFileType) If bPrompt Then _ MsgBox("The context menu [" & sFileType & "]" & vbLf & "has been successfully removed from registry", MsgBoxStyle.Information, m_sMsgTitle) Else If bPrompt Then _ MsgBox("The context menu [" & sFileType & "]" & vbLf & "can't be found in the registry", MsgBoxStyle.Information, m_sMsgTitle) End If Else If bClassesRootRegistryKeyExists(sCleDescriptionCmd) Then Registry.ClassesRoot.DeleteSubKeyTree(sCleDescriptionCmd) If bPrompt Then _ MsgBox("The context menu [" & sCmdDescription & "]" & vbLf & "has been successfully removed from registry for the files of the type :" & vbLf & "[" & sFileType & "]", MsgBoxStyle.Information, m_sMsgTitle) Else If bPrompt Then _ MsgBox("The context menu [" & sCmdDescription & "]" & vbLf & "can't be found in the registry for the files of the type :" & vbLf & "[" & sFileType & "]", MsgBoxStyle.Information, m_sMsgTitle) End If End If bAddContextMenu = True Exit Function End If Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sCleDescriptionCmd) rk.SetValue("", sCmdDescription) End Using 'rk.Close() Dim sCleCmd$ = sFileType & "\" & sShellKey & "\" & sCmd & "\" & sCmdKey Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sCleCmd) ' Add quotes " if the path contains spaces If sExePath.IndexOf(" ", StringComparison.Ordinal) > -1 Then _ sExePath = """" & sExePath & """" rk.SetValue("", sExePath & " " & sCmdDef) End Using If bPrompt Then _ MsgBox("The context menu [" & sCmdDescription & "]" & vbLf & "has been successfully added from registry for the files of the type :" & vbLf & "[" & sFileType & "]", MsgBoxStyle.Information, m_sMsgTitle) Return True Catch ex As Exception ShowErrorMsg(ex, "bAddContextMenu", sMsgErrPossibleCause) Return False End Try End Function Public Function bClassesRootRegistryKeyExists(sKey$, Optional sSubKey$ = "") As Boolean Try Using rkCRCle As RegistryKey = Registry.ClassesRoot.OpenSubKey(sKey & "\" & sSubKey) If IsNothing(rkCRCle) Then Return False End Using Return True Catch Return False End Try End Function Public Function bClassesRootRegistryKeyExists(sKey$, sSubKey$, ByRef sSubKeyValue$) As Boolean sSubKeyValue = "" Try Using rkCRCle As RegistryKey = Registry.ClassesRoot.OpenSubKey(sKey) If IsNothing(rkCRCle) Then Return False Dim oValue As Object = rkCRCle.GetValue(sSubKey) If IsNothing(oValue) Then Return False Dim sSubKeyValue0$ = CStr(oValue) If IsNothing(sSubKeyValue0) Then Return False sSubKeyValue = sSubKeyValue0 End Using Return True Catch Return False End Try End Function Public Function bLocalMachineRegistryKeyExists(sKey$, Optional sSubKey$ = "", Optional ByRef sSubKeyValue$ = "", Optional sNewSubKeyValue$ = "") As Boolean sSubKeyValue = "" Try Dim bWrite As Boolean = False If sNewSubKeyValue.Length > 0 Then bWrite = True Using rkLMCle As RegistryKey = Registry.LocalMachine.OpenSubKey(sKey, writable:=bWrite) Dim oValue As Object = rkLMCle.GetValue(sSubKey) If IsNothing(oValue) Then Return False Dim sSubKeyVal0$ = CStr(oValue) If IsNothing(sSubKeyVal0) Then Return False sSubKeyValue = sSubKeyVal0 If bWrite Then oValue = CInt(sNewSubKeyValue) rkLMCle.SetValue(sSubKey, oValue, RegistryValueKind.DWord) End If End Using Return True Catch Return False End Try End Function Public Function bCurrentUserRegistryKeyExists(sKey$, Optional sSubKey$ = "", Optional ByRef sSubKeyValue$ = "") As Boolean sSubKeyValue = "" Try Using rkCUCle As RegistryKey = Registry.CurrentUser.OpenSubKey(sKey) Dim oValue As Object = rkCUCle.GetValue(sSubKey) If IsNothing(oValue) Then Return False Dim sSubKeyValue0$ = CStr(oValue) If IsNothing(sSubKeyValue0) Then Return False sSubKeyValue = sSubKeyValue0 End Using Return True Catch Return False End Try End Function Public Function asCurrentUserRegistrySubKeys(sKey$) As String() Try Using rkCUCle As RegistryKey = Registry.CurrentUser.OpenSubKey(sKey) If IsNothing(rkCUCle) Then Return Nothing Return rkCUCle.GetSubKeyNames End Using Catch Return Nothing End Try End Function End Module UniversalComparer.vb ' File UniversalComparer.vb : Generic comparer for any class ' ------------------------- 'Imports System.Collections.Generic Imports System.Reflection ' http://archive.visualstudiomagazine.com/2005_02/magazine/columns/net2themax/Listing2.aspx Public Class UniversalComparer(Of T) : Implements IComparer, IComparer(Of T) Private sortKeys() As SortKey Private m_bMsg As Boolean = False Private m_sSorting$ = "" Public Sub New(sort As String) If String.IsNullOrEmpty(sort) Then Exit Sub m_sSorting = sort Dim type As Type = GetType(T) ' Split the list of properties. Dim props() As String = sort.Split(","c) ' Prepare the array that holds information on sort criteria. ReDim sortKeys(props.Length - 1) ' Parse the sort string. For i As Integer = 0 To props.Length - 1 ' Get the N-th member name. Dim memberName As String = props(i).Trim() If memberName.EndsWith(" desc", StringComparison.OrdinalIgnoreCase) Then ' Discard the DESC qualifier. sortKeys(i).Descending = True memberName = memberName.Remove(memberName.Length - 5).TrimEnd() End If ' Search for a field or a property with this name. sortKeys(i).FieldInfo = type.GetField(memberName) sortKeys(i).sMemberName = memberName If sortKeys(i).FieldInfo Is Nothing Then sortKeys(i).PropertyInfo = type.GetProperty(memberName) End If Next i End Sub Public Function Compare(x As Object, y As Object) As Integer _ Implements IComparer.Compare ' Implementation of IComparer.Compare Return Compare(CType(x, T), CType(y, T)) End Function Public Function Compare(x As T, y As T) As Integer _ Implements IComparer(Of T).Compare ' Implementation of IComparer(Of T).Compare ' Deal with the simplest cases first. If x Is Nothing Then ' Two null objects are equal. If y Is Nothing Then Return 0 ' A null object is less than any non-null object. Return -1 ElseIf y Is Nothing Then ' Any non-null object is greater than a null object. Return 1 End If ' Iterate over all the sort keys. For i As Integer = 0 To sortKeys.Length - 1 Dim oValue_x As Object, oValue_y As Object Dim sortKey As SortKey = sortKeys(i) ' Read either the field or the property. If sortKey.FieldInfo IsNot Nothing Then oValue_x = sortKey.FieldInfo.GetValue(x) oValue_y = sortKey.FieldInfo.GetValue(y) Else If IsNothing(sortKey.PropertyInfo) Then If Not m_bMsg Then MsgBox( "A sorting key can't be found : the specified field doesn't exists" & vbLf & "or is not in public scope !" & vbLf & GetType(T).ToString & " : " & sortKeys(i).sMemberName & " : " & m_sSorting, MsgBoxStyle.Critical, "UniversalComparer:Compare") m_bMsg = True End If Return 0 End If oValue_x = sortKey.PropertyInfo.GetValue(x, Nothing) oValue_y = sortKey.PropertyInfo.GetValue(y, Nothing) End If Dim iRes% If oValue_x Is Nothing And oValue_y Is Nothing Then ' Two null objects are equal. iRes = 0 ElseIf oValue_x Is Nothing Then ' A null object is always less than a non-null object. iRes = -1 ElseIf oValue_y Is Nothing Then ' Any object is greater than a null object. iRes = 1 Else ' Compare the two values, assuming that they support IComparable. iRes = DirectCast(oValue_x, IComparable).CompareTo(oValue_y) End If ' If values are different, return this value to caller. If iRes <> 0 Then ' Negate it if sort direction is descending. If sortKey.Descending Then iRes = -iRes Return iRes End If Next i ' If we get here the two objects are equal. Return 0 End Function Private Structure SortKey ' Nested type to store detail on sort keys Public FieldInfo As FieldInfo Public PropertyInfo As PropertyInfo ' True if sort is descending. Public Descending As Boolean Public sMemberName$ End Structure End Class