DBReport v1.0.5.*
Table des procédures 1 - AssemblyInfo.vb 2 - frmDBReport.vb 2.1 - Private Sub Activation 2.2 - Private Sub chkAlertNotNullable_Enter 2.3 - Private Sub chkDisplayCollation_Enter 2.4 - Private Sub chkDisplayDefaultValue_Enter 2.5 - Private Sub chkDisplayDescription_Enter 2.6 - Private Sub chkDisplayFieldType_Enter 2.7 - Private Sub chkDisplayLinkName_Enter 2.8 - Private Sub chkDisplayTableEngine_Enter 2.9 - Private Sub chkSortColumns_Enter 2.10 - Private Sub chkSortIndexes_Enter 2.11 - Private Sub chkSortLinks_Enter 2.12 - Private Sub cmdCancel_Click 2.13 - Private Sub cmdDBReport_Click 2.14 - Private Sub cmdDBReport_Enter 2.15 - Private Sub cmdResetConfig_Click 2.16 - Private Sub cmdResetSettings_Enter 2.17 - Private Sub DBReport 2.18 - Private Sub frmDBReport_FormClosing 2.19 - Private Sub frmRapportBD_Load 2.20 - Private Sub ResetDisplaySettings 2.21 - Private Sub SaveAndRestoreSettings 2.22 - Private Sub ShowLongMessage 2.23 - Private Sub ShowLongMessageDeleg 2.24 - Private Sub ShowMessage 2.25 - Private Sub ShowMessageDeleg 2.26 - Private Sub tbDBName_Enter 2.27 - Private Sub tbDBProvider_Enter 2.28 - Private Sub tbDBServer_Enter 2.29 - Private Sub tbUserName_Enter 2.30 - Private Sub tbUserPassword_Enter 3 - modDBReport.vb 3.1 - Private Sub CreateHeader 3.2 - Private Sub CreateLinkReport 3.3 - Private Sub CreateTableReport 3.4 - Private Sub ShowLongMsg 3.5 - Private Sub ShowMessageDeleg 3.6 - Private Sub ShowMsg 3.7 - Private Sub ShowMySqlInfos 3.8 - Public Function bCreateDBReport 3.9 - Public Function bGetMySqlParameters 3.10 - Public Sub GetMySqlColumnsCollation 3.11 - Public Sub GetMySqlTablesCollationAndEngine 4 - modUtil.vb 4.1 - Public Function is64BitProcess 4.2 - Public Sub CopyToClipBoard 4.3 - Public Sub SetMsgTitle 4.4 - Public Sub ShowErrorMsg 4.5 - Public Sub TruncateChildTextAccordingToControlWidth 5 - modUtilFile.vb 5.1 - Public Function asCmdLineArg 5.2 - Public Function asLines 5.3 - Public Function asReadFile 5.4 - Public Function bDeleteFile 5.5 - Public Function bFileExists 5.6 - Public Function bFileIsWritable 5.7 - Public Function bLetOpenFile 5.8 - Public Function bWriteFile 5.9 - Public Function GetEncoding 5.10 - Public Function sDisplayNumeric$ 5.11 - Public Function sDisplaySizeInBytes$ 5.12 - Public Function sDisplayTime$ 5.13 - Public FunctionbFileIsAvailable 5.14 - Public FunctionbFileLocked 5.15 - Public FunctionStringReadLine$ 5.16 - Public Sub LetOpenFile 5.17 - Public Sub New 5.18 - Public Sub StartAssociateApp 6 - clsShowMsg.vb 6.1 - Public Delegate Sub ShowMessageDelegate 6.2 - Public ReadOnly Property sMessage$ 6.3 - Public Sub New 6.4 - Public Sub ShowLongMsg 6.5 - Public Sub ShowMsg 7 - clsSortDic.vb 7.1 - Public Function Sort 8 - UniversalComparer.vb 8.1 - Public Function Compare 8.2 - Public Function Compare 8.3 - Public Sub New AssemblyInfo.vb ' File AssemblyInfo.vb ' -------------------- Imports System.Reflection <Assembly: AssemblyTitle("DBReport")> <Assembly: AssemblyDescription("DBReport : A DataBase structure Reporting tool for database administrators")> <Assembly: AssemblyCompany("ORS Production")> <Assembly: AssemblyProduct("DBReport")> <Assembly: AssemblyCopyright("Copyright © ORS Production 2017")> <Assembly: AssemblyTrademark("DBReport")> <Assembly: AssemblyVersion("1.0.5.*")> frmDBReport.vb ' DBReport : A DataBase structure Reporting tool for database administrators ' -------------------------------------------------------------------------- ' Documentation : DBReport.html ' http://patrice.dargenton.free.fr/CodesSources/DBReport.html ' http://patrice.dargenton.free.fr/CodesSources/DBReport.vbproj.html ' Version 1.05 - 05/03/2017 ' 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 frmDBReport.vb : Main form ' ------------------- Imports System.Text ' for StringBuilder Public Class frmDBReport #Region "Settings" ' In release mode, do not save password in config file, it may not be secure in all situations Private Const bSavePassWord As Boolean = Not bRelease Private Const bSortColumnsDef As Boolean = False Private Const bSortIndexesDef As Boolean = True ' To make the comparison easier Private Const bDisplayFieldDescriptionDef As Boolean = True Private Const bDisplayFieldTypeDef As Boolean = True Private Const bDisplayDefaultValueDef As Boolean = True Private Const bDisplayLinkNameDef As Boolean = False Private Const bSortLinksDef As Boolean = True ' To make the comparison easier Private Const bAlertNotNullableDef As Boolean = True Private Const bDisplayTableEngineDef As Boolean = True Private Const bDisplayCollationDef As Boolean = True #End Region Private Const sMsgDBProvider$ = _ "Name of the database provider installed in the DotNet Framework" & _ " (e.g. 'MySql.Data.MySqlClient' if mysql-connector-net-6.9.8.msi is used)" Private Const sMsgDBServer$ = "Name of the server (e.g. 'localhost' or '127.0.0.1')" Private Const sMsgDBName$ = "Name of the database for which you want to export the structure" Private Const sMsgUserName$ = _ "Login name (e.g. 'root', a registered user that can view the database structure)" Private Const sMsgUserPassword$ = _ "Login password for the selected user (leave blank if no password is set for this user)" Private Const sMsgDBReport$ = "Click 'DB report' to create the database report" Private Const sMsgResetSettings$ = "Click to restore default display settings of the database report" Private Const sMsgSortColumns$ = "Sort columns of each table" Private Const sMsgSortIndexes$ = _ "Sort indexes of each table (to make the database structure comparison easier)" Private Const sMsgSortLinks$ = _ "Sort links between tables (to make the database structure comparison easier)" Private Const sMsgDisplayFieldDefaultValue$ = "Display default value of each field" Private Const sMsgDisplayFieldType$ = "Display field type of each field" Private Const sMsgDisplayLinkName$ = "Display the name of links between two tables" Private Const sMsgDisplayDescription$ = "Display the description of tables and fields, if available" Private Const sMsgAlertNotNullable$ = "Alert about non-nullable field risks" Private Const sMsgDisplayTableEngine$ = "Display the table engine for a MySql database (MyISAM, InnoDB, ...)" Private Const sMsgDisplayCollation$ = "Display the collation for a MySql database (utf8_general_ci, ...)" Private WithEvents m_delegMsg As New clsDelegMsg Private Sub frmRapportBD_Load(sender As Object, e As EventArgs) Handles Me.Load SetMsgTitle(sMsgTitle) Dim sTxt$ = sMsgTitle & " " & sAppVersion & " (" & sAppDate & ")" If bDebug Then sTxt &= " - Debug" 'If is64BitProcess() Then sTxt &= " - 64 bits" Else sTxt &= " - 32 bits" If Not is64BitProcess() Then sTxt &= " - 32 bits" Me.Text = sTxt ResetDisplaySettings() SaveAndRestoreSettings(bSave:=False) Me.cmdDBReport.Select() Me.ToolTip1.SetToolTip(Me.tbDBProvider, sMsgDBProvider) Me.ToolTip1.SetToolTip(Me.lblDBProvider, sMsgDBProvider) Me.ToolTip1.SetToolTip(Me.tbDBServer, sMsgDBServer) Me.ToolTip1.SetToolTip(Me.lblDBServer, sMsgDBServer) Me.ToolTip1.SetToolTip(Me.tbDBName, sMsgDBName) Me.ToolTip1.SetToolTip(Me.lblDBName, sMsgDBName) Me.ToolTip1.SetToolTip(Me.tbUserName, sMsgUserName) Me.ToolTip1.SetToolTip(Me.lblUserName, sMsgUserName) Me.ToolTip1.SetToolTip(Me.tbUserPassword, sMsgUserPassword) Me.ToolTip1.SetToolTip(Me.lblUserPassword, sMsgUserPassword) Me.ToolTip1.SetToolTip(Me.cmdDBReport, sMsgDBReport) Me.ToolTip1.SetToolTip(Me.cmdResetSettings, sMsgResetSettings) Me.ToolTip1.SetToolTip(Me.chkAlertNotNullable, sMsgAlertNotNullable) Me.ToolTip1.SetToolTip(Me.chkDisplayDescription, sMsgDisplayDescription) Me.ToolTip1.SetToolTip(Me.chkDisplayFieldDefaultValue, sMsgDisplayFieldDefaultValue) Me.ToolTip1.SetToolTip(Me.chkDisplayFieldType, sMsgDisplayFieldType) Me.ToolTip1.SetToolTip(Me.chkDisplayLinkName, sMsgDisplayLinkName) Me.ToolTip1.SetToolTip(Me.chkSortColumns, sMsgSortColumns) Me.ToolTip1.SetToolTip(Me.chkSortIndexes, sMsgSortIndexes) Me.ToolTip1.SetToolTip(Me.chkSortLinks, sMsgSortLinks) Me.ToolTip1.SetToolTip(Me.chkDisplayTableEngine, sMsgDisplayTableEngine) Me.ToolTip1.SetToolTip(Me.chkDisplayCollation, sMsgDisplayCollation) If bDebug Then Me.tbDBProvider.Text = sMySqlClient Me.tbDBServer.Text = "localhost" Me.tbDBName.Text = "northwind" Me.chkAlertNotNullable.Checked = False ' northwind Me.tbUserName.Text = "root" Me.tbUserPassword.Text = "" End If End Sub Private Sub frmDBReport_FormClosing(sender As Object, e As FormClosingEventArgs) Handles Me.FormClosing SaveAndRestoreSettings(bSave:=True) End Sub Private Sub SaveAndRestoreSettings(bSave As Boolean) If bSave Then My.Settings.DBProvider = Me.tbDBProvider.Text My.Settings.DBServer = Me.tbDBServer.Text My.Settings.DBName = Me.tbDBName.Text My.Settings.UserName = Me.tbUserName.Text If bSavePassWord Then _ My.Settings.UserPassword = Me.tbUserPassword.Text My.Settings.DisplayTableAndFieldDescription = Me.chkDisplayDescription.Checked My.Settings.DisplayFieldType = Me.chkDisplayFieldType.Checked My.Settings.DisplayFieldDefaultValue = Me.chkDisplayFieldDefaultValue.Checked My.Settings.DisplayLinkName = Me.chkDisplayLinkName.Checked My.Settings.SortColumns = Me.chkSortColumns.Checked My.Settings.SortIndexes = Me.chkSortIndexes.Checked My.Settings.SortLinks = Me.chkSortLinks.Checked My.Settings.AlertNotNullable = Me.chkAlertNotNullable.Checked My.Settings.MySqlDisplayTableEngine = Me.chkDisplayTableEngine.Checked My.Settings.MySqlDisplayCollation = Me.chkDisplayCollation.Checked Else Me.tbDBProvider.Text = My.Settings.DBProvider Me.tbDBServer.Text = My.Settings.DBServer Me.tbDBName.Text = My.Settings.DBName Me.tbUserName.Text = My.Settings.UserName Me.tbUserPassword.Text = My.Settings.UserPassword Me.chkDisplayDescription.Checked = My.Settings.DisplayTableAndFieldDescription Me.chkDisplayFieldType.Checked = My.Settings.DisplayFieldType Me.chkDisplayFieldDefaultValue.Checked = My.Settings.DisplayFieldDefaultValue Me.chkDisplayLinkName.Checked = My.Settings.DisplayLinkName Me.chkSortColumns.Checked = My.Settings.SortColumns Me.chkSortIndexes.Checked = My.Settings.SortIndexes Me.chkSortLinks.Checked = My.Settings.SortLinks Me.chkAlertNotNullable.Checked = My.Settings.AlertNotNullable Me.chkDisplayTableEngine.Checked = My.Settings.MySqlDisplayTableEngine Me.chkDisplayCollation.Checked = My.Settings.MySqlDisplayCollation End If End Sub Private Sub cmdResetConfig_Click(sender As Object, e As EventArgs) Handles cmdResetSettings.Click ResetDisplaySettings() End Sub Private Sub ResetDisplaySettings() Me.chkDisplayDescription.Checked = bDisplayFieldDescriptionDef Me.chkDisplayFieldType.Checked = bDisplayFieldTypeDef Me.chkDisplayFieldDefaultValue.Checked = bDisplayDefaultValueDef Me.chkDisplayLinkName.Checked = bDisplayLinkNameDef ' False Me.chkSortColumns.Checked = bSortColumnsDef ' False Me.chkSortIndexes.Checked = bSortIndexesDef Me.chkSortLinks.Checked = bSortLinksDef Me.chkAlertNotNullable.Checked = bAlertNotNullableDef Me.chkDisplayTableEngine.Checked = bDisplayTableEngineDef Me.chkDisplayCollation.Checked = bDisplayCollationDef End Sub Private Sub Activation(bActivate As Boolean) Me.cmdCancel.Enabled = Not bActivate Me.cmdDBReport.Enabled = bActivate Me.cmdResetSettings.Enabled = bActivate Me.tbDBProvider.Enabled = bActivate Me.tbDBServer.Enabled = bActivate Me.tbDBName.Enabled = bActivate Me.tbUserName.Enabled = bActivate Me.tbUserPassword.Enabled = bActivate Me.chkDisplayDescription.Enabled = bActivate Me.chkDisplayFieldType.Enabled = bActivate Me.chkDisplayFieldDefaultValue.Enabled = bActivate Me.chkDisplayLinkName.Enabled = bActivate Me.chkSortColumns.Enabled = bActivate Me.chkSortIndexes.Enabled = bActivate Me.chkSortLinks.Enabled = bActivate Me.chkAlertNotNullable.Enabled = bActivate Me.chkDisplayTableEngine.Enabled = bActivate Me.chkDisplayCollation.Enabled = bActivate End Sub Private Sub ShowLongMessage(sMsg$) Me.lblInfo.Text = sMsg 'Me.ShowMessage(sMsg) End Sub Private Sub ShowMessage(sMsg$) Me.ToolStripStatusLabel1.Text = sMsg TruncateChildTextAccordingToControlWidth(Me.ToolStripStatusLabel1, Me, appendEllipsis:=True) Application.DoEvents() 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 cmdDBReport_Click(sender As Object, e As EventArgs) Handles cmdDBReport.Click DBReport() End Sub Private Sub DBReport() Dim sServer$ = Me.tbDBServer.Text Dim sDBName$ = Me.tbDBName.Text Dim sUserLogin$ = Me.tbUserName.Text Dim sPW$ = Me.tbUserPassword.Text Dim sDBProvider$ = Me.tbDBProvider.Text Dim sConnection$ = _ "server=" & sServer & "; " & _ "userid=" & sUserLogin & "; " & _ "password=" & sPW & "; " & _ "database=" & sDBName & ";" Activation(bActivate:=False) m_delegMsg.m_bCancel = False If Not bFileExists(Application.StartupPath & "\DatabaseSchemaReader.dll", bPrompt:=True) Then GoTo Fin If sDBProvider = sMySqlClient Then If Not bFileExists(Application.StartupPath & "\MySql.Data.dll", bPrompt:=True) Then GoTo Fin End If Dim sb = New StringBuilder() Dim prm As New clsPrmDBR prm.sConnection = sConnection prm.sDBProvider = sDBProvider prm.sDBName = sDBName prm.sServer = sServer prm.sUserLogin = sUserLogin prm.sDBReportVersion = sAppVersion ' 23/10/2016 prm.bDisplayTableAndFieldDescription = Me.chkDisplayDescription.Checked prm.bDisplayFieldDefaultValue = Me.chkDisplayFieldDefaultValue.Checked prm.bDisplayFieldType = Me.chkDisplayFieldType.Checked prm.bDisplayLinkName = Me.chkDisplayLinkName.Checked prm.bSortColumns = Me.chkSortColumns.Checked prm.bSortIndexes = Me.chkSortIndexes.Checked prm.bSortLinks = Me.chkSortLinks.Checked prm.bAlertNotNullable = Me.chkAlertNotNullable.Checked prm.sForeignKeyDeleteRuleDef = My.Settings.ForeignKeyDeleteRule ' 05/03/2017 RESTRICT prm.sForeignKeyUpdateRuleDef = My.Settings.ForeignKeyUpdateRule ' 05/03/2017 RESTRICT ' 05/03/2017 'prm.mySqlprm.sSQLModeDef = "STRICT_TRANS_TABLES,NO_ENGINE_SUBSTITUTION" 'prm.mySqlprm.sInnodbStrictModeDef = "ON" 'prm.mySqlprm.iTimeOutMaxDef = 99999 'prm.mySqlprm.iNetReadTimeoutSecDef = iNoDefaultTimeOut 'prm.mySqlprm.iNetWriteTimeoutSecDef = iNoDefaultTimeOut 'prm.mySqlprm.sTableEngineDef = "InnoDB" 'prm.mySqlprm.sServerCollationDef = "utf8_general_ci" 'prm.mySqlprm.sDatabaseCollationDef = "utf8_general_ci" 'prm.mySqlprm.sTableCollationDef = "utf8_general_ci" 'prm.mySqlprm.sColumnCollationDef = "utf8_general_ci" prm.mySqlprm.sSQLModeDef = My.Settings.MySqlSQLMode prm.mySqlprm.sInnodbStrictModeDef = My.Settings.MySqlInnodbStrictMode prm.mySqlprm.iTimeOutMaxDef = My.Settings.MySqlTimeOutMaxSec prm.mySqlprm.iNetReadTimeoutSecDef = My.Settings.MySqlNetReadTimeoutSec prm.mySqlprm.iNetWriteTimeoutSecDef = My.Settings.MySqlNetWriteTimeoutSec prm.mySqlprm.sTableEngineDef = My.Settings.MySqlTableEngine prm.mySqlprm.sServerCollationDef = My.Settings.MySqlServerCollation prm.mySqlprm.sDatabaseCollationDef = My.Settings.MySqlDatabaseCollation prm.mySqlprm.sTableCollationDef = My.Settings.MySqlTableCollation prm.mySqlprm.sColumnCollationDef = My.Settings.MySqlColumnCollation prm.mySqlprm.bDisplayTableEngine = Me.chkDisplayTableEngine.Checked prm.mySqlprm.bDisplayCollation = Me.chkDisplayCollation.Checked If bDebug Then ' For Norhwind : prm.mySqlprm.sColumnCollationDef = "utf8_unicode_ci" 'prm.mySqlprm.sTableCollationDef = "utf8_general_ci" 'prm.mySqlprm.sDatabaseCollationDef = "utf8_general_ci" 'prm.mySqlprm.sServerCollationDef = "utf8_general_ci" 'prm.mySqlprm.sTableEngineDef = "InnoDB" End If If bCreateDBReport(prm, m_delegMsg, sMsgDBOff, sMsgCompoMySQLNotInst, sb) Then Dim sPath$ = Application.StartupPath & "\DBReport_" & sDBName & ".txt" If Not bWriteFile(sPath, sb) Then GoTo Fin LetOpenFile(sPath) Else If Me.m_delegMsg.m_bCancel Then ShowLongMessage("") ShowMessage("Cancelled by user.") End If End If Fin: Activation(bActivate:=True) End Sub Private Sub cmdCancel_Click(sender As Object, e As EventArgs) Handles cmdCancel.Click Me.m_delegMsg.m_bCancel = True End Sub Private Sub tbDBProvider_Enter(sender As Object, e As EventArgs) Handles tbDBProvider.Enter ShowLongMessage(sMsgDBProvider) End Sub Private Sub tbDBServer_Enter(sender As Object, e As EventArgs) Handles tbDBServer.Enter ShowLongMessage(sMsgDBServer) End Sub Private Sub tbDBName_Enter(sender As Object, e As EventArgs) Handles tbDBName.Enter ShowLongMessage(sMsgDBName) End Sub Private Sub tbUserName_Enter(sender As Object, e As EventArgs) Handles tbUserName.Enter ShowLongMessage(sMsgUserName) End Sub Private Sub tbUserPassword_Enter(sender As Object, e As EventArgs) Handles tbUserPassword.Enter ShowLongMessage(sMsgUserPassword) End Sub Private Sub cmdDBReport_Enter(sender As Object, e As EventArgs) Handles cmdDBReport.Enter ShowLongMessage(sMsgDBReport) End Sub Private Sub cmdResetSettings_Enter(sender As Object, e As EventArgs) Handles cmdResetSettings.Enter ShowLongMessage(sMsgResetSettings) End Sub Private Sub chkSortColumns_Enter(sender As Object, e As EventArgs) Handles chkSortColumns.Enter ShowLongMessage(sMsgSortColumns) End Sub Private Sub chkSortIndexes_Enter(sender As Object, e As EventArgs) Handles chkSortIndexes.Enter ShowLongMessage(sMsgSortIndexes) End Sub Private Sub chkSortLinks_Enter(sender As Object, e As EventArgs) Handles chkSortLinks.Enter ShowLongMessage(sMsgSortLinks) End Sub Private Sub chkDisplayDefaultValue_Enter(sender As Object, e As EventArgs) Handles chkDisplayFieldDefaultValue.Enter ShowLongMessage(sMsgDisplayFieldDefaultValue) End Sub Private Sub chkDisplayFieldType_Enter(sender As Object, e As EventArgs) Handles chkDisplayFieldType.Enter ShowLongMessage(sMsgDisplayFieldType) End Sub Private Sub chkDisplayLinkName_Enter(sender As Object, e As EventArgs) Handles chkDisplayLinkName.Enter ShowLongMessage(sMsgDisplayLinkName) End Sub Private Sub chkAlertNotNullable_Enter(sender As Object, e As EventArgs) Handles chkAlertNotNullable.Enter ShowLongMessage(sMsgAlertNotNullable) End Sub Private Sub chkDisplayDescription_Enter(sender As Object, e As EventArgs) Handles chkDisplayDescription.Enter ShowLongMessage(sMsgDisplayDescription) End Sub Private Sub chkDisplayTableEngine_Enter(sender As Object, e As EventArgs) Handles chkDisplayTableEngine.Enter ShowLongMessage(sMsgDisplayTableEngine) End Sub Private Sub chkDisplayCollation_Enter(sender As Object, e As EventArgs) Handles chkDisplayCollation.Enter ShowLongMessage(sMsgDisplayCollation) End Sub End Class modDBReport.vb ' File modDBReport.vb ' ------------------- Imports System.Text ' StringBuilder Imports MySql.Data.MySqlClient Public Module modDBReport Public Const sMySqlClient$ = "MySql.Data.MySqlClient" Public Const sMsgError$ = "Error !" Public Const sMsgDone$ = "Done." Public Const sMsgDBOff$ = "Could not connect to database !" & vbCrLf & _ "Possible cause : the database server has not been started," & vbCrLf & _ " or wrong database name or account used." Public Const sMsgCompoMySQLNotInst$ = _ "Possible cause : mysql-connector-net-6.9.8.msi is not installed" Private Const iNoDefaultTimeOut% = -1 Private Const sMsgEmpty$ = "[Empty]" Private m_dTimeStart As Date Private m_delegMsg As clsDelegMsg Private WithEvents m_dbReader As DatabaseSchemaReader.DatabaseReader Private Sub ShowMsg(sMsg$) m_delegMsg.ShowMsg(sMsg) End Sub Private Sub ShowLongMsg(sMsg$) m_delegMsg.ShowLongMsg(sMsg) End Sub Private Sub ShowMessageDeleg(sender As Object, e As DatabaseSchemaReader.ReaderEventArgs) _ Handles m_dbReader.ReaderProgress If bDebug Then Debug.WriteLine("") Debug.WriteLine("") Debug.WriteLine("Reading database schema : " & e.ProgressType.ToString & ", " & _ e.SchemaObjectType.ToString) ' & ", " & e.Name & ", " & e.Index & ", " & e.Count) Dim dTimeEnd = Now() Dim ts = dTimeEnd - m_dTimeStart Const sDateTimeFormat = "dd\/MM\/yyyy HH:mm:ss" Dim sTime$ = m_dTimeStart.ToString(sDateTimeFormat) & " -> " & _ dTimeEnd.ToString(sDateTimeFormat) & " : " & sDisplayTime(ts.TotalSeconds) Debug.WriteLine(sTime) End If ShowMsg("Reading database schema : " & e.ProgressType.ToString & ", " & _ e.SchemaObjectType.ToString) ' & ", " & e.Name & ", " & e.Index & ", " & e.Count) End Sub #Region "Classes" Public Class clsPrmDBR Public sConnection$, sDBProvider$, sUserLogin$, sServer$, sDBName$, sDBReportVersion$ Public bDisplayTableAndFieldDescription As Boolean Public bDisplayFieldType As Boolean Public bDisplayFieldDefaultValue As Boolean Public bDisplayLinkName As Boolean Public bSortColumns As Boolean Public bSortIndexes As Boolean Public bSortLinks As Boolean Public bAlertNotNullable As Boolean Public sForeignKeyDeleteRuleDef$ ' 05/03/2017 Public sForeignKeyUpdateRuleDef$ ' 05/03/2017 Public mySqlprm As New clsPrmMySql ' 05/03/2017 End Class Public Class clsPrmMySql Public bDisplayTableEngine As Boolean Public bDisplayCollation As Boolean Public sSQLModeDef$ Public sInnodbStrictModeDef$ Public iTimeOutMaxDef% Public iNetReadTimeoutSecDef% Public iNetWriteTimeoutSecDef% Public sTableEngineDef$ Public sServerCollationDef$ Public sDatabaseCollationDef$ Public sTableCollationDef$ Public sColumnCollationDef$ End Class ' http://dev.mysql.com/doc/refman/5.7/en/server-system-variables.html Public Class enumMySqlPrm ' sql_mode controls what SQL syntax MySQL accepts, and determines whether it silently ' ignores errors, or validates input syntax and data values. For example, if sql_mode ' is empty, implicit conversions can be performed without error (but only with warnings) ' Default : STRICT_TRANS_TABLES,NO_ENGINE_SUBSTITUTION ' https://dev.mysql.com/doc/refman/5.7/en/sql-mode.html Public Const sql_mode$ = "sql_mode" ' This is analogous to sql_mode in MySQL, it enables additional error checks for InnoDB tables. ' The default value is ON since MySQL 5.7.7 Public Const innodb_strict_mode$ = "innodb_strict_mode" Public Const collation_server$ = "collation_server" ' Default collation for new databases Public Const DEFAULT_COLLATION_NAME$ = "DEFAULT_COLLATION_NAME" ' Database default collation Public Const net_read_timeout_sec = "net_read_timeout" Public Const net_write_timeout_sec = "net_write_timeout" End Class Public Class clsLink ' Relationship between two tables Public Id$ = "" Public Name$ = "" Public Table$ = "" Public Count% = 0 Public dc As DatabaseSchemaReader.DataSchema.DatabaseConstraint ' (for foreing key) End Class #End Region Public Function bCreateDBReport(prm As clsPrmDBR, delegMsg As clsDelegMsg, _ sMsgErr$, sMsgErrPossibleCause$, ByRef sb As StringBuilder) As Boolean ' Library used : https://dbschemareader.codeplex.com Try m_delegMsg = delegMsg ShowMsg("Connecting to database...") If delegMsg.m_bCancel Then Return False m_dTimeStart = Now() Dim lstMySqlPrm As New List(Of String) Dim dicSqlPrm As New Dictionary(Of String, String) Dim dicSqlTE As New Dictionary(Of String, String) Dim dicSqlTC As New Dictionary(Of String, String) Dim dicSqlCC As New Dictionary(Of String, String) Dim bMySql As Boolean = False If prm.sDBProvider = sMySqlClient Then bMySql = True If bMySql Then If Not bGetMySqlParameters(prm.sConnection, prm.sDBName, dicSqlPrm, lstMySqlPrm, _ sMsgErr, sMsgErrPossibleCause) Then Return False GetMySqlTablesCollationAndEngine(prm.sConnection, prm.sDBName, dicSqlTE, dicSqlTC) GetMySqlColumnsCollation(prm.sConnection, prm.sDBName, dicSqlCC) End If m_dbReader = New DatabaseSchemaReader.DatabaseReader(prm.sConnection, prm.sDBProvider) m_dbReader.Owner = prm.sDBName ' 22/08/2016 ShowMsg("Reading database schema...") If delegMsg.m_bCancel Then Return False Dim schema = m_dbReader.ReadAll Const sDateTimeFormat = "dd\/MM\/yyyy HH:mm:ss" If bDebug Then Dim dTimeEnd = Now() Dim ts = dTimeEnd - m_dTimeStart Dim sTime$ = m_dTimeStart.ToString(sDateTimeFormat) & " -> " & _ dTimeEnd.ToString(sDateTimeFormat) & " : " & sDisplayTime(ts.TotalSeconds) Debug.WriteLine(sTime & " : ReadAll") End If ShowMsg("Building database report...") If delegMsg.m_bCancel Then Return False sb = New StringBuilder() CreateHeader(sb, prm) If bMySql Then ShowMySqlInfos(sb, prm, lstMySqlPrm, dicSqlPrm) CreateTableReport(sb, prm, schema, bMySql, dicSqlTE, dicSqlTC, dicSqlCC) CreateLinkReport(sb, prm, schema) ShowMsg(sMsgDone) ShowLongMsg("") Dim dTimeEnd2 = Now() Dim ts2 = dTimeEnd2 - m_dTimeStart Dim sTime2$ = m_dTimeStart.ToString(sDateTimeFormat) & " -> " & _ dTimeEnd2.ToString(sDateTimeFormat) & " : " & sDisplayTime(ts2.TotalSeconds) sb.AppendLine() sb.AppendLine("Report created : " & sTime2) Return True Catch ex As Exception ShowMsg(sMsgError) Dim sFinalErrMsg$ = "" ShowErrorMsg(ex, "bCreateDBReport", sMsgErr, sMsgErrPossibleCause, sFinalErrMsg:=sFinalErrMsg) ShowLongMsg(sFinalErrMsg) Return False End Try End Function Private Sub CreateHeader(sb As StringBuilder, prm As clsPrmDBR) sb.AppendLine() sb.AppendLine("Database report " & prm.sDBReportVersion) ' 23/10/2016 sb.AppendLine("--------------------") sb.AppendLine() sb.AppendLine("Login : " & prm.sUserLogin) sb.AppendLine("Server : " & prm.sServer) sb.AppendLine("Database : " & prm.sDBName) If prm.bSortColumns Then sb.AppendLine("Columns : Sorted") Else 'sb.AppendLine("Columns : Not sorted") End If If prm.bSortIndexes Then sb.AppendLine("Indexes : Sorted") Else 'sb.AppendLine("Indexes : Not sorted") End If sb.AppendLine() End Sub Private Sub ShowMySqlInfos(sb As StringBuilder, prm As clsPrmDBR, _ lstMySqlPrm As List(Of String), dicSqlPrm As Dictionary(Of String, String)) sb.AppendLine("MySql parameters :") For Each sPrm In lstMySqlPrm Dim sVal = dicSqlPrm(sPrm) Dim sDisplayedPrm$ = sPrm If sPrm = enumMySqlPrm.sql_mode Then If sVal <> prm.mySqlprm.sSQLModeDef Then If sVal.Length = 0 Then sVal = sMsgEmpty sVal &= " (Default : " & prm.mySqlprm.sSQLModeDef & ")" End If End If If sPrm = enumMySqlPrm.innodb_strict_mode Then If sVal <> prm.mySqlprm.sInnodbStrictModeDef Then If sVal.Length = 0 Then sVal = sMsgEmpty sVal &= " (Default : " & prm.mySqlprm.sInnodbStrictModeDef & ")" End If End If If sPrm = enumMySqlPrm.collation_server Then If Not prm.mySqlprm.bDisplayCollation Then Continue For If sVal <> prm.mySqlprm.sServerCollationDef Then sDisplayedPrm = "Default collation for new databases (collation_server)" If sVal.Length = 0 Then sVal = sMsgEmpty sVal &= " (Default : " & prm.mySqlprm.sServerCollationDef & ")" Else Continue For End If End If If sPrm = enumMySqlPrm.DEFAULT_COLLATION_NAME Then If Not prm.mySqlprm.bDisplayCollation Then Continue For If sVal <> prm.mySqlprm.sDatabaseCollationDef Then sDisplayedPrm = "Database default collation (DEFAULT_COLLATION_NAME)" If sVal.Length = 0 Then sVal = sMsgEmpty sVal &= " (Default : " & prm.mySqlprm.sDatabaseCollationDef & ")" Else Continue For End If End If If sPrm = enumMySqlPrm.net_read_timeout_sec OrElse _ sPrm = enumMySqlPrm.net_write_timeout_sec Then Dim iValDef% = 0 If sPrm = enumMySqlPrm.net_read_timeout_sec Then _ iValDef = prm.mySqlprm.iNetReadTimeoutSecDef If sPrm = enumMySqlPrm.net_write_timeout_sec Then _ iValDef = prm.mySqlprm.iNetWriteTimeoutSecDef If sVal = prm.mySqlprm.iTimeOutMaxDef.ToString Then sVal = sVal & " (no limit)" Else Dim iVal = Convert.ToInt32(sVal) sVal = sVal & " (" & sDisplayTime(iVal) & ")" End If If iValDef > iNoDefaultTimeOut Then Dim sValDef$ = iValDef.ToString If sValDef = prm.mySqlprm.iTimeOutMaxDef.ToString Then sValDef = sValDef & " (no limit)" Else sValDef = sValDef & " (" & sDisplayTime(iValDef) & ")" End If sVal &= " (Default : " & sValDef & ")" End If End If If dicSqlPrm.ContainsKey(sPrm) Then sb.AppendLine(sDisplayedPrm & " : " & sVal) Next sb.AppendLine() End Sub Private Sub CreateTableReport(sb As StringBuilder, prm As clsPrmDBR, _ schema As DatabaseSchemaReader.DataSchema.DatabaseSchema, bMySql As Boolean, _ dicSqlTE As Dictionary(Of String, String), _ dicSqlTC As Dictionary(Of String, String), _ dicSqlCC As Dictionary(Of String, String)) ' Lister les clés étrangères pour préciser : ' Build foreign key list to specify : ' "not nullable without default value" -> "not nullable foreign key" Dim hsForeignKeys As New HashSet(Of String) If prm.bAlertNotNullable Then For Each table In schema.Tables For Each fk In table.ForeignKeys Dim sId$ = fk.Columns(0) Dim sCleFK2$ = table.Name & ":" & sId hsForeignKeys.Add(sCleFK2) Next Next End If For Each table In schema.Tables Dim sTableTitle$ = table.Name If prm.bDisplayTableAndFieldDescription AndAlso table.Description.Length > 0 Then _ sTableTitle &= " : " & table.Description If bMySql Then If prm.mySqlprm.bDisplayTableEngine AndAlso dicSqlTE.ContainsKey(table.Name) Then Dim sTE$ = dicSqlTE(table.Name) If sTE <> prm.mySqlprm.sTableEngineDef Then sTableTitle &= " (engine : " & sTE & ")" End If If prm.mySqlprm.bDisplayCollation AndAlso dicSqlTC.ContainsKey(table.Name) Then Dim sTC$ = dicSqlTC(table.Name) If sTC <> prm.mySqlprm.sTableCollationDef Then sTableTitle &= " (collation : " & sTC & ")" End If End If sb.AppendLine(sTableTitle) ' Noter tous les champs nullables pour alerter sur les clés uniques ' Hashset of nullable fields of the table, to warn uniqueness Dim hsNullablesCol As New HashSet(Of String) ' key : column name Dim lstCol As New List(Of String) For Each col In table.Columns Dim sTitle$ = col.Name If col.Nullable Then hsNullablesCol.Add(sTitle) Dim bDefVal As Boolean = False ' 23/10/2016 Distinguish empty string to null 'If Not String.IsNullOrEmpty(col.DefaultValue) Then bDefVal = True If Not IsNothing(col.DefaultValue) Then bDefVal = True If prm.bDisplayFieldType Then sTitle &= " (" & col.DbDataType & ")" If prm.bDisplayFieldDefaultValue AndAlso bDefVal Then Dim sDisplay$ = col.DefaultValue If sDisplay.Length = 0 Then sDisplay = "''" ' ' 23/10/2016 sTitle &= " (" & sDisplay & ")" End If If prm.bDisplayTableAndFieldDescription AndAlso col.Description.Length > 0 Then _ sTitle &= " : " & col.Description If col.IsAutoNumber Then sTitle &= " (autonumber)" ElseIf Not col.Nullable Then If prm.bAlertNotNullable Then If Not bDefVal Then Dim sCleFK$ = table.Name & ":" & col.Name If hsForeignKeys.Contains(sCleFK) Then sTitle &= " (not nullable foreign key)" Else sTitle &= " (not nullable without default value)" End If Else sTitle &= " (not nullable)" End If End If End If If bMySql AndAlso prm.mySqlprm.bDisplayCollation Then Dim sCle$ = table.Name & ":" & col.Name If dicSqlCC.ContainsKey(sCle) Then Dim sCC$ = dicSqlCC(sCle) If sCC <> prm.mySqlprm.sColumnCollationDef Then sTitle &= " (collation : " & sCC & ")" End If End If lstCol.Add(sTitle) Next If prm.bSortColumns Then lstCol.Sort() For Each sCol In lstCol sb.AppendLine(" " & sCol) Next Dim dicIndexes As New SortDic(Of String, DatabaseSchemaReader.DataSchema.DatabaseIndex) For Each ind In table.Indexes dicIndexes.Add(ind.Name, ind) Next Dim sSorting$ = "" If prm.bSortIndexes Then sSorting = "Name" For Each ind In dicIndexes.Sort(sSorting) Dim sUnique$ = "" Dim sPrimary$ = "" If ind.IsUnique Then sUnique = ", Unique" If Not IsNothing(table.PrimaryKey) AndAlso _ table.PrimaryKey.Name = ind.Name Then sPrimary = ", Primary" End If ' MySQL (5.6) ne peut garantir l'unicité si un des champs d'une clé unique peut être nul ' on peut alors avoir des doublons dans la table ' MySQL (5.6) can't guarantee uniqueness (unicity) if one field of a unique key ' is nullable, you can have duplicates records in the table Dim sWarnNF$ = "" Const sWarnNFTxt = " (nullable field for a unique index)" If ind.Columns.Count = 1 Then If ind.IsUnique AndAlso hsNullablesCol.Contains(ind.Columns(0).Name) Then _ sWarnNF = sWarnNFTxt sb.AppendLine(" Index : " & ind.Columns(0).Name & sPrimary & sUnique & sWarnNF) Else sb.AppendLine(" Index : " & ind.Name & sPrimary & sUnique & ", " & _ ind.Columns.Count & " fields" & " :") For Each chp In ind.Columns sWarnNF = "" If ind.IsUnique AndAlso hsNullablesCol.Contains(chp.Name) Then _ sWarnNF = sWarnNFTxt sb.AppendLine(" field : " & chp.Name & sWarnNF) Next End If Next sb.AppendLine() Next sb.AppendLine() End Sub Private Sub CreateLinkReport(sb As StringBuilder, prm As clsPrmDBR, _ schema As DatabaseSchemaReader.DataSchema.DatabaseSchema) sb.AppendLine("Links") ' Relationships between tables For Each table In schema.Tables sb.AppendLine() Dim sTableTitle$ = table.Name If prm.bDisplayTableAndFieldDescription AndAlso table.Description.Length > 0 Then _ sTableTitle &= " : " & table.Description sb.AppendLine(sTableTitle) Dim dicLinks As New SortDic(Of String, clsLink) For Each fk In table.ForeignKeys Dim sId$ = fk.Columns(0) Dim sLinkTable$ = fk.RefersToTable Dim iCount% = 1 Dim sKey$ = sLinkTable & " : " & sId Retry: ' 04/09/2016 A constraint may be duplicated If iCount > 1 Then sKey = sLinkTable & " : " & sId & ":" & iCount End If Dim l0 As New clsLink l0.Id = sId l0.Name = fk.Name l0.Table = sLinkTable l0.dc = fk l0.Count = iCount If dicLinks.ContainsKey(sKey) Then iCount += 1 GoTo Retry End If dicLinks.Add(sKey, l0) Next Dim sSorting$ = "" If prm.bSortLinks Then If prm.bDisplayLinkName Then sSorting = "Name" Else sSorting = "Table, Id" End If End If For Each fk0 In dicLinks.Sort(sSorting) Dim fk = fk0.dc Dim sId$ = fk.Columns(0) Dim sLinkTable$ = fk.RefersToTable Dim sLinkName$ = "" Dim sCount$ = "" If prm.bDisplayLinkName Then sLinkName = " : " & fk.Name ElseIf fk0.Count > 1 Then sCount = " (" & fk0.Count & ")" ' 04/09/2016 End If Dim sDelRule$ = "" Dim sUpdRule$ = "" 'Const sRestrict$ = "RESTRICT" Dim sRestrictDef$ = prm.sForeignKeyDeleteRuleDef If fk.DeleteRule <> sRestrictDef Then sDelRule = " (Delete rule : " & _ CStr(IIf(String.IsNullOrEmpty(fk.DeleteRule), "undefined", fk.DeleteRule)) & ")" sRestrictDef = prm.sForeignKeyUpdateRuleDef If fk.UpdateRule <> sRestrictDef Then sUpdRule = " (Update rule : " & _ CStr(IIf(String.IsNullOrEmpty(fk.UpdateRule), "undefined", fk.UpdateRule)) & ")" sb.AppendLine(" " & sLinkTable & " : " & _ sId & sCount & sLinkName & sDelRule & sUpdRule) Next Next End Sub #Region "MySql parameters" Public Function bGetMySqlParameters(sMySQLConnectionString$, sDbName$, _ dicMySqlPrm As Dictionary(Of String, String), lstMySqlPrm As List(Of String), _ sMsgErr$, sMsgErrPossibleCause$) As Boolean ShowMsg("Loading MySql parameters...") Try Using oConnMySQL As New MySql.Data.MySqlClient.MySqlConnection oConnMySQL.ConnectionString = sMySQLConnectionString oConnMySQL.Open() ' Syntax ok in phpMyAdmin but not there !? 'sSQL = "SHOW VARIABLES WHERE (Variable_Name LIKE '%sql_mode' OR Variable_Name LIKE '%timeout');" Dim lstSQL As New List(Of String) ' http://dev.mysql.com/doc/refman/5.7/en/server-system-variables.html ' Ordered list (a dictionary is not ordered) lstMySqlPrm.Add("version_comment") lstMySqlPrm.Add("version") lstMySqlPrm.Add("protocol_version") lstMySqlPrm.Add("sql_mode") lstMySqlPrm.Add("innodb_strict_mode") lstMySqlPrm.Add("net_read_timeout") lstMySqlPrm.Add("net_write_timeout") lstMySqlPrm.Add("collation_server") lstMySqlPrm.Add("DEFAULT_COLLATION_NAME") lstSQL.Add("SHOW VARIABLES WHERE Variable_Name IN (" & _ "'version', 'version_comment', 'protocol_version', 'sql_mode', " & _ "'innodb_strict_mode', 'net_read_timeout', 'net_write_timeout');") lstSQL.Add("SELECT 'DEFAULT_COLLATION_NAME', DEFAULT_COLLATION_NAME FROM " & _ "information_schema.SCHEMATA WHERE schema_name = '" & sDbName & "';") lstSQL.Add("SHOW VARIABLES LIKE 'collation_server'") Dim iNbRecords% = 0 For Each sSQL In lstSQL Using cmd2 As New MySqlCommand(sSQL, oConnMySQL) Using reader As MySqlDataReader = cmd2.ExecuteReader() If reader.HasRows Then Do While reader.Read() iNbRecords += 1 Dim sPrmName$ = reader.GetString(0) Dim sPrmValue$ = reader.GetString(1) dicMySqlPrm.Add(sPrmName, sPrmValue) Loop Else Debug.WriteLine("bGetMySqlParameters : No rows found.") End If End Using End Using Next End Using Return True Catch ex As Exception ShowMsg(sMsgError) Dim sFinalErrMsg$ = "" ShowErrorMsg(ex, "bGetMySqlParameters", sMsgErr, sMsgErrPossibleCause, sFinalErrMsg:=sFinalErrMsg) ShowLongMsg(sFinalErrMsg) Return False Finally End Try End Function Public Sub GetMySqlTablesCollationAndEngine(sMySQLConnectionString$, sDbName$, _ dicMySqlTE As Dictionary(Of String, String), _ dicMySqlTC As Dictionary(Of String, String)) ShowMsg("Loading MySql tables collation...") Try Using oConnMySQL As New MySql.Data.MySqlClient.MySqlConnection oConnMySQL.ConnectionString = sMySQLConnectionString oConnMySQL.Open() Dim lstSQL As New List(Of String) lstSQL.Add("SELECT TABLE_NAME, ENGINE, COLLATION_NAME FROM information_schema.`TABLES` T," & _ " information_schema.`COLLATION_CHARACTER_SET_APPLICABILITY` CCSA" & _ " WHERE CCSA.collation_name = T.table_collation AND T.table_schema = '" & sDbName & "';") Dim iNbRecords% = 0 For Each sSQL In lstSQL Using cmd2 As New MySqlCommand(sSQL, oConnMySQL) Using reader As MySqlDataReader = cmd2.ExecuteReader() If reader.HasRows Then Do While reader.Read() iNbRecords += 1 Dim sPrmName$ = reader.GetString(0) Dim sPrmValue1$ = reader.GetString(1) Dim sPrmValue2$ = reader.GetString(2) dicMySqlTE.Add(sPrmName, sPrmValue1) dicMySqlTC.Add(sPrmName, sPrmValue2) Loop Else Debug.WriteLine("GetMySqlTablesCollationAndEngine : No rows found.") End If End Using End Using Next End Using Catch ex As Exception ShowErrorMsg(ex, "GetMySqlTablesCollationAndEngine") Finally End Try End Sub Public Sub GetMySqlColumnsCollation(sMySQLConnectionString$, sDbName$, _ dicMySqlCC As Dictionary(Of String, String)) ShowMsg("Loading MySql columns collation...") Try Using oConnMySQL As New MySql.Data.MySqlClient.MySqlConnection oConnMySQL.ConnectionString = sMySQLConnectionString oConnMySQL.Open() Dim lstSQL As New List(Of String) lstSQL.Add("SELECT table_name, C.column_name, COLLATION_NAME FROM " & _ "information_schema.`COLUMNS` C WHERE table_schema = '" & sDbName & "';") Dim iNbRecords% = 0 For Each sSQL In lstSQL Using cmd2 As New MySqlCommand(sSQL, oConnMySQL) Using reader As MySqlDataReader = cmd2.ExecuteReader() If reader.HasRows Then Do While reader.Read() iNbRecords += 1 Dim sTableName$ = reader.GetString(0) Dim sColName$ = reader.GetString(1) If reader.IsDBNull(2) Then Continue Do Dim sPrmValue$ = reader.GetString(2) Dim sKey$ = sTableName & ":" & sColName dicMySqlCC.Add(sKey, sPrmValue) Loop Else Debug.WriteLine("GetMySqlColumnsCollation : No rows found.") End If End Using End Using Next End Using Catch ex As Exception ShowErrorMsg(ex, "GetMySqlColumnsCollation") Finally End Try End Sub #End Region End Module modUtil.vb ' File modUtil.vb : Utility module ' --------------- Module modUtil Public m_sMsgTitle$ = sMsgTitle Public Sub SetMsgTitle(sTitreMsg$) m_sMsgTitle = sTitreMsg End Sub Public Sub ShowErrorMsg(ByRef ex As Exception, _ Optional sFctTitle$ = "", 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 sFctTitle <> "" Then sMsg = "Function : " & sFctTitle 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$) ' Copier des informations dans le presse-papier de Windows ' (elles resteront jusqu'à ce que l'application soit fermée) ' Copy text into Windows clipboard Try Dim dataObj As New DataObject dataObj.SetData(DataFormats.Text, sInfo) Clipboard.SetDataObject(dataObj) Catch ex As Exception ' Le presse-papier peut être indisponible ShowErrorMsg(ex, "CopyToClipBoard", bCopyErrMsgClipBoard:=False) End Try End Sub Public Function is64BitProcess() As Boolean Return (IntPtr.Size = 8) End Function ''' <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> Public Sub TruncateChildTextAccordingToControlWidth(child As ToolStripStatusLabel, _ 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 rMarge! = 0.1 'If child.Size.Width >= parent.Size.Width * 0.9 Then If child.Size.Width >= parent.Size.Width * (1 - rMarge) 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 + rMarge) * 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 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 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 Using fs As New IO.FileStream(sFilePath, mode, access, share) fs.Close() End Using 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 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 ' Read the BOM Dim bom = New Byte(3) {} Using file = New IO.FileStream(filename, IO.FileMode.Open, IO.FileAccess.Read) 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 ' 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 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 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 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 Using fs As New IO.FileStream(sFilePath, _ IO.FileMode.Open, IO.FileAccess.Read, IO.FileShare.ReadWrite) Using sr As New IO.StreamReader(fs, encod0) ' Do exactly as sr.ReadLine() Dim sStream As New clsStringStream(sr.ReadToEnd) Return sStream.asLines(bCheckCrCrLf) End Using : End Using Else Return IO.File.ReadAllLines(sFilePath, encod0) End If Catch ex As Exception ShowErrorMsg(ex, "asReadFile") 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 Dim p As New Process p.StartInfo = New ProcessStartInfo(sFilePath) p.StartInfo.Arguments = sArguments If bMaximized Then p.StartInfo.WindowStyle = ProcessWindowStyle.Maximized p.Start() 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 ByRef sMsgErr$ = "") As Boolean If Not bDeleteFile(sFilePath, bPromptIfErr:=True) Then Return False Dim sw As IO.StreamWriter = Nothing Try If bDefautEncoding Then encode = Encoding.Default sw = New IO.StreamWriter(sFilePath, append:=False, Encoding:=encode) sw.Write(sbContenu.ToString()) sw.Close() 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 Finally If Not IsNothing(sw) Then sw.Close() 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 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 clsDelegMsg ' Managing class for messages displayed by the delegate Public Delegate Sub ShowMessageDelegate(sender As Object, e As clsMsgEventArgs) Public Event EvShowMessage As ShowMessageDelegate Public Event EvShowLongMessage As ShowMessageDelegate Public m_bCancel 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 End Class clsSortDic.vb ' File clsSortDic.vb : Sortable dictionary class ' ------------------ Public Class SortDic(Of TKey, TValue) : Inherits Dictionary(Of TKey, TValue) Public Function Sort(Optional sSorting$ = "") As TValue() ' Sort the dictionary and return sorted elements Dim iNbLignes% = Me.Count Dim arrayTvalue(iNbLignes - 1) As TValue Dim iNumLigne% = 0 For Each kvp As KeyValuePair(Of TKey, TValue) In Me arrayTvalue(iNumLigne) = kvp.Value iNumLigne += 1 Next ' If no sorting is specified, simply return the array If sSorting.Length = 0 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 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) 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.ToLower().EndsWith(" desc") 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(o1 As Object, o2 As Object) As Integer _ Implements IComparer.Compare ' Implementation of IComparer.Compare Return Compare(CType(o1, T), CType(o2, T)) End Function Public Function Compare(o1 As T, o2 As T) As Integer _ Implements IComparer(Of T).Compare ' Implementation of IComparer(Of T).Compare ' Deal with the simplest cases first. If o1 Is Nothing Then ' Two null objects are equal. If o2 Is Nothing Then Return 0 ' A null object is less than any non-null object. Return -1 ElseIf o2 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 value1 As Object, value2 As Object Dim sortKey As SortKey = sortKeys(i) ' Read either the field or the property. If sortKey.FieldInfo IsNot Nothing Then value1 = sortKey.FieldInfo.GetValue(o1) value2 = sortKey.FieldInfo.GetValue(o2) 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 value1 = sortKey.PropertyInfo.GetValue(o1, Nothing) value2 = sortKey.PropertyInfo.GetValue(o2, Nothing) End If Dim res As Integer If value1 Is Nothing And value2 Is Nothing Then ' Two null objects are equal. res = 0 ElseIf value1 Is Nothing Then ' A null object is always less than a non-null object. res = -1 ElseIf value2 Is Nothing Then ' Any object is greater than a null object. res = 1 Else ' Compare the two values, assuming that they support IComparable. res = DirectCast(value1, IComparable).CompareTo(value2) End If ' If values are different, return this value to caller. If res <> 0 Then ' Negate it if sort direction is descending. If sortKey.Descending Then res = -res Return res 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