diff --git a/Distribution/DBaddin32.xll b/Distribution/DBaddin32.xll index aa5e6516..3062219f 100644 Binary files a/Distribution/DBaddin32.xll and b/Distribution/DBaddin32.xll differ diff --git a/Distribution/DBaddin64.xll b/Distribution/DBaddin64.xll index ce5e7bbd..3f1d53dd 100644 Binary files a/Distribution/DBaddin64.xll and b/Distribution/DBaddin64.xll differ diff --git a/docs/DBFuncs.md b/docs/DBFuncs.md index 22e13bc3..c2ee6142 100644 --- a/docs/DBFuncs.md +++ b/docs/DBFuncs.md @@ -257,6 +257,13 @@ This builds a Powerquery compliant string (quoted using double quotes) from the When E1 contains "test", this results in "a test". +#### preventRefresh + +
preventRefresh(setPreventRefresh, onlyForThisWB (optional))
+ +sets preventRefresh flag globally or just for the current workbook (if onlyForThisWB is set), similar to clicking the ribbon toggle button "refresh prevention". This setting is not persisted with the workbook! + + ### Modifications of DBFunc Behaviour There are some options to modify diff --git a/docs/DBaddin.ldproj b/docs/DBaddin.ldproj new file mode 100644 index 00000000..fdee86a5 --- /dev/null +++ b/docs/DBaddin.ldproj @@ -0,0 +1,14 @@ + + + + ../source/DBaddin.sln + + + + Private + Protected + InternalProtected + + Release + VisualBasic + \ No newline at end of file diff --git "a/docs/Live Documenter.exe - Verkn\303\274pfung.lnk" "b/docs/Live Documenter.exe - Verkn\303\274pfung.lnk" deleted file mode 100644 index b792670f..00000000 Binary files "a/docs/Live Documenter.exe - Verkn\303\274pfung.lnk" and /dev/null differ diff --git a/source/AdHocSQL.vb b/source/AdHocSQL.vb index e265a1e2..d22d4d22 100644 --- a/source/AdHocSQL.vb +++ b/source/AdHocSQL.vb @@ -1,15 +1,16 @@ -Imports System.Data +Imports System.ComponentModel ' for BackgroundWorker callback handling +Imports System.Data Imports System.Windows.Forms -Imports System.ComponentModel ' for BackgroundWorker callback handling + ''' User-form for ad-hoc SQL execution Public Class AdHocSQL ''' common connection settings factored in helper class Private myDBConnHelper As DBConnHelper ''' stored environment to reset after change - Private storedUserSetEnv As String = "" + Private ReadOnly storedUserSetEnv As String = "" ''' stored database to reset after change - Private userSetDB As String = "" + Private ReadOnly userSetDB As String = "" ''' create new AdHocSQL dialog ''' @@ -322,6 +323,9 @@ Public Class AdHocSQL sender.CurrentRow.Cells(e.ColumnIndex).TooltipText = "Data raised exception: " + e.Exception.Message + " (" + e.Context.ToString() + ")" End Sub + ''' show context menu for SQLText, displaying config menu as a MenuStrip + ''' + ''' Private Sub SQLText_MouseDown(sender As Object, e As MouseEventArgs) Handles SQLText.MouseDown If e.Button = Windows.Forms.MouseButtons.Right Then Me.ConfigMenuStrip = ConfigFiles.ConfigContextMenu diff --git a/source/AddInEvents.vb b/source/AddInEvents.vb index bb7257b0..782f5f73 100644 --- a/source/AddInEvents.vb +++ b/source/AddInEvents.vb @@ -4,24 +4,9 @@ Imports Microsoft.Office.Interop Imports Microsoft.Office.Interop.Excel ' for event procedures... Imports Microsoft.Office.Core Imports Microsoft.Vbe.Interop -Imports System.Diagnostics Imports System.Runtime.InteropServices Imports System.Collections.Generic -Public Module CheckInstance - Public Sub checkHiddenExcelInstance() - Try - ' check for multiple excel instances - If Process.GetProcessesByName("Excel").Length > 1 Then - For Each procinstance As Process In Process.GetProcessesByName("Excel") - If procinstance.MainWindowTitle = "" Then - UserMsg("Another hidden excel instance detected (PID: " + procinstance.Id + "), this may cause problems with querying DB Data") - End If - Next - End If - Catch ex As Exception : End Try - End Sub -End Module ''' AddIn Connection class, also handling Events from Excel (Open, Close, Activate) @@ -63,9 +48,9 @@ Public Class AddInEvents End If Catch ex As Exception : End Try ' for finding out what happened attach internal trace to ExcelDNA LogDisplay - theLogDisplaySource = New TraceSource("ExcelDna.Integration") + theLogDisplaySource = New Diagnostics.TraceSource("ExcelDna.Integration") ' and also define a LogSource for DBAddin itself for writing text log messages - theLogFileSource = New TraceSource("DBAddin") + theLogFileSource = New Diagnostics.TraceSource("DBAddin") ' IntelliSense needed for DB- and supporting functions ExcelDna.IntelliSense.IntelliSenseServer.Install() @@ -292,7 +277,7 @@ done: ''' Private Sub Application_WorkbookActivate(Wb As Excel.Workbook) Handles Application.WorkbookActivate ' avoid when being activated by DBFuncsAction - If Not DBModifs.preventChangeWhileFetching And Not Wb.IsAddin Then + If Not DBModifHelper.preventChangeWhileFetching And Not Wb.IsAddin Then ' in case AutoOpen hasn't been triggered (e.g. when Excel was started via Internet Explorer)... If DBModifDefColl Is Nothing Then DBModifDefColl = New Dictionary(Of String, Dictionary(Of String, DBModif)) @@ -343,7 +328,7 @@ done: ''' name of command button, defines whether a DBModification is invoked (starts with DBMapper/DBAction/DBSeqnce) Private Shared Sub cbClick(cbName As String) ' reset non interactive messages (used for VBA invocations) and hadError for interactive invocations - nonInteractiveErrMsgs = "" : DBModifs.hadError = False + nonInteractiveErrMsgs = "" : DBModifHelper.hadError = False Dim DBModifType As String = Left(cbName, 8) If DBModifType <> "DBSeqnce" Then Dim targetRange As Excel.Range @@ -418,7 +403,7 @@ done: ''' Private Sub Application_SheetActivate(Sh As Object) Handles Application.SheetActivate ' avoid when being activated by DBFuncsAction - If Not DBModifs.preventChangeWhileFetching Then + If Not DBModifHelper.preventChangeWhileFetching Then ' only when needed assign button handler for this sheet ... If Not IsNothing(DBModifDefColl) AndAlso DBModifDefColl.Count > 0 Then assignHandler(Sh) End If @@ -426,7 +411,7 @@ done: Private WbIsClosing As Boolean = False - ''' Clean up after closing workbook, only set flag here, actual cleanup is only done if workbook is really closed (in WB_Deactivate event) + ''' Clean up after closing workbook, only set flag here, the actual cleanup is only done if workbook is really closed (in WB_Deactivate event) ''' ''' Private Sub Application_WorkbookBeforeClose(Wb As Workbook, ByRef Cancel As Boolean) Handles Application.WorkbookBeforeClose @@ -437,6 +422,7 @@ done: ''' Private Sub Application_WorkbookDeactivate(Wb As Workbook) Handles Application.WorkbookDeactivate Try + If WbIsClosing AndAlso preventRefreshFlagColl.ContainsKey(Wb.Name) Then preventRefreshFlagColl.Remove(Wb.Name) If WbIsClosing AndAlso Not IsNothing(DBModifDefColl) AndAlso DBModifDefColl.Count > 0 Then DBModifDefColl.Clear() theRibbon.Invalidate() @@ -452,7 +438,7 @@ done: ''' Private Sub Application_SheetChange(Sh As Object, Target As Range) Handles Application.SheetChange ' avoid entering into insert/update check resp. doCUDMarks if not list-object (data table), whole column modified, no DBMapper present and prevention while fetching (on refresh) being set - If Not IsNothing(Target.ListObject) AndAlso Not Target.Rows.Count = Sh.Rows.Count AndAlso DBModifDefColl.ContainsKey("DBMapper") AndAlso Not DBModifs.preventChangeWhileFetching Then + If Not IsNothing(Target.ListObject) AndAlso Not Target.Rows.Count = Sh.Rows.Count AndAlso DBModifDefColl.ContainsKey("DBMapper") AndAlso Not DBModifHelper.preventChangeWhileFetching Then Dim targetName As String = getDBModifNameFromRange(Target) If Left(targetName, 8) = "DBMapper" Then DirectCast(DBModifDefColl("DBMapper").Item(targetName), DBMapper).insertCUDMarks(Target) diff --git a/source/ConfigFiles.vb b/source/ConfigFiles.vb index bc8b0dfc..71cc7226 100644 --- a/source/ConfigFiles.vb +++ b/source/ConfigFiles.vb @@ -24,6 +24,7 @@ Public Module ConfigFiles Public specialFolderMaxDepth As Integer ''' store found sub-menus in this collection Private specialConfigFoldersTempColl As Collection + ''' collection structure for the two menu types, one in ribbon (Xelement) and MenuStrip (ToolStripMenuItem, used in AdHocSQL/SQLText context menu) Private Structure MenuClassStruct Dim ribbonmenu As XElement Dim contextmenu As ToolStripMenuItem @@ -147,8 +148,9 @@ Public Module ConfigFiles ''' creates the ribbon config tree menu and the context menu for the AdHocSQL Dialog by reading the menu elements from the config store folder files/sub-folders Public Sub createConfigTreeMenu() - Dim currentBar, button As XElement - Dim currentStrip As New ToolStripMenuItem + ' collecting menu items in + Dim currentBar As XElement ' for ribbon + Dim currentStrip As New ToolStripMenuItem ' for context menu in AdHocSQL/SQLText ' also get the documentation that was provided in setting ConfigDocQuery into ConfigDocCollection (used in config menu when clicking entry + Ctrl/Shift) Dim ConfigDocQuery As String = fetchSetting("ConfigDocQuery" + env(), fetchSetting("ConfigDocQuery", "")) @@ -162,8 +164,8 @@ Public Module ConfigFiles Else ' top level menu currentBar = New XElement(xnspace + "menu") - ' add refresh button to top level - button = New XElement(xnspace + "button") + ' add refresh button to top level only for ribbon menu + Dim button As New XElement(xnspace + "button") button.SetAttributeValue("id", "refreshConfig") button.SetAttributeValue("label", "refresh DBConfig Tree") button.SetAttributeValue("imageMso", "Refresh") @@ -176,12 +178,13 @@ Public Module ConfigFiles specialConfigFoldersTempColl = Nothing ExcelDnaUtil.Application.StatusBar = "" currentBar.SetAttributeValue("xmlns", xnspace) - ' avoid exception in ribbon... + ' avoid exception in ribbon by respecting the entry limit... ConfigMenuXML = currentBar.ToString() If ConfigMenuXML.Length > maxSizeRibbonMenu Then UserMsg("Too many entries in " + ConfigStoreFolder + ", can't display them in a ribbon menu ..") ConfigMenuXML = "" End If + ' add all collected ToolStripMenuItem of currentStrip to top-level menu, copying needed because AddRange removes items from original collection Dim addedContextMenu As ToolStripMenuItem() ReDim addedContextMenu(currentStrip.DropDownItems.Count - 1) currentStrip.DropDownItems.CopyTo(addedContextMenu, 0) @@ -252,6 +255,7 @@ Public Module ConfigFiles ' normal case or max menu depth branch: just follow the path and enter all entries as buttons Else For i = 0 To UBound(fileList) + ' add ribbon menu leaf element newBar = New XElement(xnspace + "button") menuID += 1 newBar.SetAttributeValue("id", "m" + menuID.ToString()) @@ -260,6 +264,7 @@ Public Module ConfigFiles newBar.SetAttributeValue("label", Folderpath + Left$(fileList(i).Name, Len(fileList(i).Name) - 4)) newBar.SetAttributeValue("onAction", "getConfig") currentBar.Add(newBar) + ' add context menu strip leaf element (including event handler) Dim eventHandler As New System.EventHandler(AddressOf contextMenuClickEventHandler) newStrip = New ToolStripMenuItem(text:=Folderpath + Left$(fileList(i).Name, Len(fileList(i).Name) - 4), image:=Nothing, onClick:=eventHandler) With { .Tag = rootPath + "\" + fileList(i).Name, @@ -278,11 +283,13 @@ Public Module ConfigFiles ExcelDnaUtil.Application.StatusBar = "Filling DBConfigs Menu: " + rootPath + "\" + DirList(i).Name ' only add new menu element if below max. menu depth for ribbons If MenuFolderDepth < maxMenuDepth Then + ' add ribbon menu element newBar = New XElement(xnspace + "menu") menuID += 1 newBar.SetAttributeValue("id", "m" + menuID.ToString()) newBar.SetAttributeValue("label", DirList(i).Name) currentBar.Add(newBar) + ' add context menu strip element (no event handler needed) newStrip = New ToolStripMenuItem With { .Text = DirList(i).Name } @@ -292,6 +299,7 @@ Public Module ConfigFiles MenuFolderDepth -= 1 Else newBar = currentBar + newStrip = currentStrip readAllFiles(rootPath + "\" + DirList(i).Name, newBar, newStrip, Folderpath + DirList(i).Name + "\") End If Next @@ -300,7 +308,7 @@ Public Module ConfigFiles End Try End Sub - ''' the event-handler for the context menu entries of the AdHocSQL context menu + ''' the event-handler for the context menu entries of the AdHocSQL context menu, used either to show the documentation for the entries or to insert the queries defined in the xcl files ''' the tool-strip menu item that sent the event ''' Public Sub contextMenuClickEventHandler(sender As Object, e As Object) @@ -310,12 +318,12 @@ Public Module ConfigFiles ' get the file content defined in sender.Tag (absolute path of xcl definition file) ' ConfigArray: Configs are tab separated pairs of vbTab <...> vbTab... Dim ConfigArray As String() = Split(getFileContent(sender.Tag), vbTab) - ' fetch query out of DBListFetch definition + ' fetch query from DBListFetch definition (includes quotes at beginning/end) Dim functionParts As String() = functionSplit(ConfigArray(1), ",", """", "DBListFetch", "(", ")") If functionParts IsNot Nothing Then ' either put query into SQLText content if empty If theAdHocSQLDlg.SQLText.Text.Length = 0 Then - theAdHocSQLDlg.SQLText.Text = functionParts(0).Substring(1, functionParts(0).Length - 2) + theAdHocSQLDlg.SQLText.Text = functionParts(0).Substring(1, functionParts(0).Length - 2) ' remove quotes at beginning/end Else ' or attach extracted table (after FROM part) to existing content, if a FROM part is available Dim startPosOfTable As Integer = functionParts(0).IndexOf("FROM") @@ -359,6 +367,7 @@ Public Module ConfigFiles ' end node: add callable entry (= button) If InStr(1, nameParts, " ") = 0 Or MenuDepth >= specialFolderMaxDepth Or MenuDepth + MenuFolderDepth >= maxMenuDepth Then Dim entryName As String = Mid$(fullPathName, InStrRev(fullPathName, "\") + 1) + ' add ribbon menu leaf element newBar = New XElement(xnspace + "button") menuID += 1 newBar.SetAttributeValue("id", "m" + menuID.ToString()) @@ -367,6 +376,7 @@ Public Module ConfigFiles newBar.SetAttributeValue("tag", fullPathName) newBar.SetAttributeValue("onAction", "getConfig") currentBar.Add(newBar) + ' add context menu strip leaf element (including event handler) Dim eventHandler As New System.EventHandler(AddressOf contextMenuClickEventHandler) newStrip = New ToolStripMenuItem(text:=Left$(entryName, Len(entryName) - 4), image:=Nothing, onClick:=eventHandler) With { .Tag = fullPathName, @@ -385,11 +395,13 @@ Public Module ConfigFiles newMenuClass.ribbonmenu = newBar newMenuClass.contextmenu = newStrip Else + ' add ribbon menu element newBar = New XElement(xnspace + "menu") menuID += 1 newBar.SetAttributeValue("id", "m" + menuID.ToString()) newBar.SetAttributeValue("label", newName) currentBar.Add(newBar) + ' add context menu strip element (no event handler needed) newStrip = New ToolStripMenuItem With { .Text = newName } diff --git a/source/DBDocumentation.vb b/source/DBDocumentation.vb index aec9cc4d..d5c1de13 100644 --- a/source/DBDocumentation.vb +++ b/source/DBDocumentation.vb @@ -1,5 +1,6 @@ Imports System.Windows.Forms +''' Simple Popup Window for displaying Database documentation Public Class DBDocumentation Private Sub CancelBtn_Click(sender As Object, e As EventArgs) Handles CancelBtn.Click Me.Close() diff --git a/source/DBModif.vb b/source/DBModif.vb index c1bc1b3d..0b349167 100644 --- a/source/DBModif.vb +++ b/source/DBModif.vb @@ -1,17 +1,16 @@ Imports ExcelDna.Integration +Imports Microsoft.Office.Core Imports Microsoft.Office.Interop -Imports System.Windows.Forms Imports System.Collections.Generic Imports System.Runtime.InteropServices -Imports Microsoft.Office.Core Imports System.Collections Imports System.Data Imports System.Data.Common Imports System.Data.Odbc Imports System.Data.OleDb Imports System.Data.SqlClient -Imports System.Text Imports System.Linq +Imports System.Text ''' Abstraction of a DB Modification Object (concrete classes DBMapper, DBAction or DBSeqnce) Public MustInherit Class DBModif @@ -719,9 +718,9 @@ exitSub: If deleteBeforeMapperInsert Then Try Dim DmlCmd As IDbCommand = idbcnn.CreateCommand() - If Not TransactionOpen Then DBModifs.trans = idbcnn.BeginTransaction() + If Not TransactionOpen Then DBModifHelper.trans = idbcnn.BeginTransaction() With DmlCmd - .Transaction = DBModifs.trans + .Transaction = DBModifHelper.trans .CommandText = "DELETE FROM " + openingQuote + String.Join(closingQuote + "." + openingQuote, Strings.Split(tableName, ".")) + closingQuote .CommandTimeout = CmdTimeout .CommandType = CommandType.Text @@ -742,18 +741,18 @@ exitSub: Dim SelectStmt As String = "SELECT * FROM " + openingQuote + String.Join(closingQuote + "." + openingQuote, Strings.Split(tableName, ".")) + closingQuote If TypeName(idbcnn) = "SqlConnection" Then ' decent behaviour for SQL Server - Using comm As New SqlCommand("SET ARITHABORT ON", idbcnn, DBModifs.trans) + Using comm As New SqlCommand("SET ARITHABORT ON", idbcnn, DBModifHelper.trans) comm.ExecuteNonQuery() End Using - da = New SqlDataAdapter(New SqlCommand(SelectStmt, idbcnn, DBModifs.trans)) With { + da = New SqlDataAdapter(New SqlCommand(SelectStmt, idbcnn, DBModifHelper.trans)) With { .UpdateBatchSize = 20 } ElseIf TypeName(idbcnn) = "OleDbConnection" Then - da = New OleDbDataAdapter(New OleDbCommand(SelectStmt, idbcnn, DBModifs.trans)) With { + da = New OleDbDataAdapter(New OleDbCommand(SelectStmt, idbcnn, DBModifHelper.trans)) With { .UpdateBatchSize = 20 } Else - da = New OdbcDataAdapter(New OdbcCommand(SelectStmt, idbcnn, DBModifs.trans)) + da = New OdbcDataAdapter(New OdbcCommand(SelectStmt, idbcnn, DBModifHelper.trans)) End If da.SelectCommand.CommandTimeout = CmdTimeout Catch ex As Exception @@ -942,11 +941,11 @@ exitSub: ExcelDnaUtil.Application.StatusBar = "Assigning transaction to CommandBuilders" Try da.UpdateCommand.UpdatedRowSource = UpdateRowSource.None - da.UpdateCommand.Transaction = DBModifs.trans + da.UpdateCommand.Transaction = DBModifHelper.trans da.DeleteCommand.UpdatedRowSource = UpdateRowSource.None - da.DeleteCommand.Transaction = DBModifs.trans + da.DeleteCommand.Transaction = DBModifHelper.trans da.InsertCommand.UpdatedRowSource = UpdateRowSource.None - da.InsertCommand.Transaction = DBModifs.trans + da.InsertCommand.Transaction = DBModifHelper.trans Catch ex As Exception notifyUserOfDataError("Error in setting Transaction for Insert/Update/Delete Commands for Data Adapter for " + tableName + ": " + ex.Message, 1) GoTo cleanup @@ -1185,9 +1184,9 @@ cleanup: ExcelDnaUtil.Application.StatusBar = False If deleteBeforeMapperInsert And Not TransactionOpen Then If hadError Then - DBModifs.trans.Rollback() + DBModifHelper.trans.Rollback() Else - DBModifs.trans.Commit() + DBModifHelper.trans.Commit() End If End If ' close connection to return it to the pool (automatically closes recordset objects, so no need for checkrst.Close() or rst.Close())... @@ -1558,15 +1557,15 @@ Public Class DBSeqnce : Inherits DBModif Dim nextdefinition() As String = Split(sequenceParams(i + 1), ":") If Not DBModifDefColl(nextdefinition(0)).Item(nextdefinition(1)).openDatabase(env) Then Exit Sub End If - DBModifs.trans = idbcnn.BeginTransaction() + DBModifHelper.trans = idbcnn.BeginTransaction() TransactionIsOpen = True Case "DBCommitRollback" If Not hadError Then LogInfo("DBCommitTrans... ") - DBModifs.trans.Commit() + DBModifHelper.trans.Commit() Else LogInfo("DBRollbackTrans... ") - DBModifs.trans.Rollback() + DBModifHelper.trans.Rollback() End If TransactionIsOpen = False Case Else @@ -1604,793 +1603,6 @@ Public Class DBSeqnce : Inherits DBModif End Class -Public Class DBModifDummy : Inherits DBModif - - Public Sub New() - MyBase.New(Nothing) - End Sub - - Public Sub executeRefresh(srcExtent) - doDBRefresh(srcExtent:=srcExtent) - End Sub - -End Class - -''' global helper functions for DBModifiers -Public Module DBModifs - ''' DBModif definition collections of DBmodif types (key of top level dictionary) with values being collections of DBModifierNames (key of contained dictionaries) and DBModifiers (value of contained dictionaries)) - Public DBModifDefColl As Dictionary(Of String, Dictionary(Of String, DBModif)) - ''' main db connection for DB modifiers - Public idbcnn As System.Data.IDbConnection - ''' avoid entering Application.SheetChange Event handler during listfetch/setquery - Public preventChangeWhileFetching As Boolean = False - ''' indicates an error in execution of DBModifiers, used for commit/rollback and for non-interactive message return - Public hadError As Boolean - ''' used to work around the fact that when started by Application.Run, Formulas are sometimes returned as local - Public listSepLocal As String = ExcelDnaUtil.Application.International(Excel.XlApplicationInternational.xlListSeparator) - ''' common transaction, needed for DBSequence and all other DB Modifiers - Public trans As DbTransaction = Nothing - ''' opening quote, e.g. [ for SQL Server - Public openingQuote As String - ''' closing quote, e.g. ] for SQL Server - Public closingQuote As String - ''' Replacement for closing quote, if needed, e.g. SQL Server requires ] to be replaced by ]] - Public closingQuoteReplacement As String - ''' Mapping of field names to parameter names (Param + number) - Public FieldParamMap As Dictionary(Of String, String) - - ''' cast .NET data type to ADO.NET DbType - ''' given .NET data type - ''' ADO.NET DbType - Public Function TypeToDbType(t As Type, columnName As String, schemaDataTypeCollection As Collection) As DbType - ' use the provider specific type information if it exists - If schemaDataTypeCollection.Contains(columnName) Then - Select Case schemaDataTypeCollection(columnName) - Case "char" : TypeToDbType = DbType.AnsiStringFixedLength - Case "nchar" : TypeToDbType = DbType.StringFixedLength - Case "varchar" : TypeToDbType = DbType.AnsiString - Case "nvarchar" : TypeToDbType = DbType.String - Case "uniqueidentifier" : TypeToDbType = DbType.Guid - Case "binary" : TypeToDbType = DbType.Binary - Case "datetime2" : TypeToDbType = DbType.DateTime2 - Case "time" : TypeToDbType = DbType.Time - Case Else - Try - TypeToDbType = DirectCast([Enum].Parse(GetType(DbType), t.Name), DbType) - Catch ex As Exception - TypeToDbType = DbType.Object - End Try - End Select - Exit Function - End If - Try - TypeToDbType = DirectCast([Enum].Parse(GetType(DbType), t.Name), DbType) - ' for most string types AnsiString is better - If TypeToDbType = DbType.String Then TypeToDbType = DbType.AnsiString - Catch ex As Exception - TypeToDbType = DbType.Object - End Try - End Function - - ''' opens a database connection - ''' number of the environment as given in the settings - ''' database to replace database selection parameter in connection string of environment - ''' True on success - Public Function openIdbConnection(env As Integer, database As String) As Boolean - openIdbConnection = False - - Dim theConnString As String = fetchSetting("ConstConnString" + env.ToString(), "") - If theConnString = "" Then - UserMsg("No connection string given for environment: " + env.ToString() + ", please correct and rerun.", "Open Connection Error") - Exit Function - End If - Dim dbidentifier As String = fetchSetting("DBidentifierCCS" + env.ToString(), "") - If dbidentifier = "" Then - UserMsg("No DB identifier given for environment: " + env.ToString() + ", please correct and rerun.", "Open Connection Error") - Exit Function - End If - - ' change the database in the connection string - theConnString = Change(theConnString, dbidentifier, database, ";") - ' need to change/set the connection timeout in the connection string as the property is readonly then... - If InStr(theConnString, "Connection Timeout=") > 0 Then - theConnString = Change(theConnString, "Connection Timeout=", CnnTimeout.ToString(), ";") - ElseIf InStr(theConnString, "Connect Timeout=") > 0 Then - theConnString = Change(theConnString, "Connect Timeout=", CnnTimeout.ToString(), ";") - Else - theConnString += ";Connection Timeout=" + CnnTimeout.ToString() - End If - - Try - If Left(theConnString.ToUpper, 5) = "ODBC;" Then - ' change to ODBC driver setting, if SQLOLEDB - theConnString = Replace(theConnString, fetchSetting("ConnStringSearch" + env.ToString(), "provider=SQLOLEDB"), fetchSetting("ConnStringReplace" + env.ToString(), "driver=SQL SERVER")) - ' remove "ODBC;" - theConnString = Right(theConnString, theConnString.Length - 5) - idbcnn = New OdbcConnection(theConnString) - ElseIf InStr(theConnString.ToLower, "provider=sqloledb") Or InStr(theConnString.ToLower, "driver=sql server") Then - ' remove provider=SQLOLEDB; (or whatever is in ConnStringSearch<>) for sql server as this is not allowed for ado.net (e.g. from a connection string for MS Query/Office) - theConnString = Replace(theConnString, fetchSetting("ConnStringSearch" + env.ToString(), "provider=SQLOLEDB") + ";", "") - idbcnn = New SqlConnection(theConnString) - ElseIf InStr(theConnString.ToLower, "oledb") Then - idbcnn = New OleDbConnection(theConnString) - Else - ' try with odbc - idbcnn = New OdbcConnection(theConnString) - End If - Catch ex As Exception - UserMsg("Error creating connection object: " + ex.Message + ", connection string: " + theConnString, "Open Connection Error") - idbcnn = Nothing - ExcelDnaUtil.Application.StatusBar = False - Exit Function - End Try - - LogInfo("open connection with " + theConnString) - ExcelDnaUtil.Application.StatusBar = "Trying " + CnnTimeout.ToString() + " sec. with connection string: " + theConnString - Try - idbcnn.Open() - openIdbConnection = True - Catch ex As Exception - UserMsg("Error connecting to DB: " + ex.Message + ", connection string: " + theConnString, "Open Connection Error") - idbcnn = Nothing - End Try - ExcelDnaUtil.Application.StatusBar = False - End Function - - ''' in case there is a defined DBMapper underlying the DBListFetch/DBSetQuery target area then change the extent of it (oldRange) to the new area given in theRange - ''' new extent after refresh of DBListFetch/DBSetQuery function - ''' extent before refresh of DBListFetch/DBSetQuery function - Public Sub resizeDBMapperRange(theRange As Excel.Range, oldRange As Excel.Range) - Dim actWbNames As Excel.Names - Try : actWbNames = ExcelDnaUtil.Application.ActiveWorkbook.Names : Catch ex As Exception - LogWarn("Exception when trying to get the active workbook names for getting DBModifier definitions: " + ex.Message + ", this might be either due to errors in the VBA-IDE (missing references) or due to opening this workbook from an MS-Office hyperlink, starting up Excel (timing issue). Switch to another workbook and back to fix.") - Exit Sub - End Try - ' only do this for the active workbook... - If theRange.Parent.Parent Is ExcelDnaUtil.Application.ActiveWorkbook Then - ' getDBModifNameFromRange gets any DBModifName (starting with DBMapper/DBAction...) intersecting theRange, so we can reassign it to the changed range with this... - Dim dbMapperRangeName As String = getDBModifNameFromRange(theRange) - ' only allow resizing of dbMapperRange if it was EXACTLY matching the FORMER target range of the DB Function - If Left(dbMapperRangeName, 8) = "DBMapper" AndAlso oldRange.Address = actWbNames.Item(dbMapperRangeName).RefersToRange.Address Then - ' (re)assign db mapper range name to the passed (changed) DBListFetch/DBSetQuery function target range - Try : theRange.Name = dbMapperRangeName - Catch ex As Exception - Throw New Exception("Error when assigning name '" + dbMapperRangeName + "' to DBListFetch/DBSetQuery target range: " + ex.Message) - End Try - ' pass the associated DBMapper the new target range - Try - Dim extendedMapper As DBMapper = DBModifDefColl("DBMapper").Item(dbMapperRangeName) - extendedMapper.setTargetRange(theRange) - Catch ex As Exception - Throw New Exception("Error passing new Range to the associated DBMapper object when extending '" + dbMapperRangeName + "' to DBListFetch/DBSetQuery target range: " + ex.Message) - End Try - End If - End If - End Sub - - ''' creates a DBModif at the current active cell or edits an existing one defined in targetDefName (after being called in defined range or from ribbon + Ctrl + Shift) - ''' - ''' - Public Sub createDBModif(createdDBModifType As String, Optional targetDefName As String = "") - Dim actWb As Excel.Workbook = Nothing - Try : actWb = ExcelDnaUtil.Application.ActiveWorkbook : Catch ex As Exception - UserMsg("Exception when trying to get the active workbook for creating DB Modifier: " + ex.Message + ", this might be either due to errors in the VBA-IDE (missing references) or due to opening this workbook from an MS-Office hyperlink, starting up Excel (timing issue). Switch to another workbook and back to fix.") - Exit Sub - End Try - If IsNothing(actWb) Then Exit Sub - Dim actWbNames As Excel.Names = Nothing - Try : actWbNames = actWb.Names : Catch ex As Exception - UserMsg("Exception when trying to get the active workbook names for creating DB Modifier: " + ex.Message + ", this might be either due to errors in the VBA-IDE (missing references) or due to opening this workbook from an MS-Office hyperlink, starting up Excel (timing issue). Switch to another workbook and back to fix.") - Exit Sub - End Try - Dim existingDBModif As DBModif = Nothing - Dim existingDefName As String = targetDefName - - ' fetch parameters if there is an existing definition... - If DBModifDefColl.ContainsKey(createdDBModifType) AndAlso DBModifDefColl(createdDBModifType).ContainsKey(existingDefName) Then - existingDBModif = DBModifDefColl(createdDBModifType).Item(existingDefName) - ' reset the target range to a potentially changed area - If createdDBModifType <> "DBSeqnce" Then - Dim existingDefRange As Excel.Range = Nothing - Try - existingDefRange = ExcelDnaUtil.Application.Range(existingDefName) - Catch ex As Exception - ' if target name relates to an invalid (offset) formula, getting a range fails ... - If InStr(actWbNames.Item(existingDefName).RefersTo, "OFFSET(") > 0 Then - UserMsg("Offset formula that '" + existingDefName + "' refers to, did not return a valid range." + vbCrLf + "Please check the offset formula to return a valid range !", "DBModifier Definitions Error") - ExcelDnaUtil.Application.Dialogs(Excel.XlBuiltInDialog.xlDialogNameManager).Show() - Exit Sub - End If - End Try - existingDBModif.setTargetRange(existingDefRange) - End If - End If - - ' prepare DBModifier Create Dialog - Dim theDBModifCreateDlg As New DBModifCreate() - With theDBModifCreateDlg - ' store DBModification type in tag for validation purposes... - .Tag = createdDBModifType - .envSel.DataSource = environdefs - .envSel.SelectedIndex = -1 - .DBModifName.Text = Replace(existingDefName, createdDBModifType, "") - .DBModifName.Tag = existingDefName - .RepairDBSeqnce.Hide() - .NameLabel.Text = IIf(createdDBModifType = "DBSeqnce", "DBSequence", createdDBModifType) + " Name:" - .Text = "Edit " + IIf(createdDBModifType = "DBSeqnce", "DBSequence", createdDBModifType) + " definition" - If createdDBModifType <> "DBMapper" Then - .TablenameLabel.Hide() - .PrimaryKeysLabel.Hide() - .AdditionalStoredProcLabel.Hide() - .IgnoreColumnsLabel.Hide() - .Tablename.Hide() - .PrimaryKeys.Hide() - .insertIfMissing.Hide() - .addStoredProc.Hide() - .IgnoreColumns.Hide() - .CUDflags.Hide() - .AutoIncFlag.Hide() - .IgnoreDataErrors.Hide() - End If - If createdDBModifType = "DBAction" Then - .paramRangesStr.Top = .Tablename.Top - .TablenameLabel.Show() - .TablenameLabel.Text = "Parameter Range Names:" - .paramRangesStr.Left = .Tablename.Left - .paramEnclosing.Top = .PrimaryKeys.Top - .PrimaryKeysLabel.Show() - .PrimaryKeysLabel.Text = "Parameter enclosing char:" - .paramEnclosing.Left = .PrimaryKeys.Left - .convertAsDate.Top = .IgnoreColumns.Top - .IgnoreColumnsLabel.Text = "Cols num params date:" - .IgnoreColumnsLabel.Show() - .convertAsDate.Left = .IgnoreColumns.Left - .convertAsString.Top = .addStoredProc.Top - .AdditionalStoredProcLabel.Show() - .AdditionalStoredProcLabel.Text = "Cols num params string:" - .convertAsString.Left = .addStoredProc.Left - .parametrized.Top = .CUDflags.Top - .parametrized.Left = .CUDflags.Left - .continueIfRowEmpty.Top = .IgnoreDataErrors.Top - .continueIfRowEmpty.Left = .IgnoreDataErrors.Left - Else - .TablenameLabel.Text = "Tablename:" - .PrimaryKeysLabel.Text = "Primary keys count:" - .IgnoreColumnsLabel.Text = "Ignore columns:" - .AdditionalStoredProcLabel.Text = "Additional stored procedure:" - .parametrized.Hide() - .paramRangesStr.Hide() - .paramEnclosing.Hide() - .convertAsDate.Hide() - .convertAsString.Hide() - .continueIfRowEmpty.Hide() - End If - If createdDBModifType = "DBSeqnce" Then - theDBModifCreateDlg.FormBorderStyle = FormBorderStyle.Sizable - ' hide controls irrelevant for DBSeqnce - .TargetRangeAddress.Hide() - .envSel.Hide() - .EnvironmentLabel.Hide() - .Database.Hide() - .DatabaseLabel.Hide() - .DBSeqenceDataGrid.Top = 55 - .DBSeqenceDataGrid.Height = 320 - .execOnSave.Top = .CreateCB.Top - .AskForExecute.Top = .CreateCB.Top - .execOnSave.Anchor = AnchorStyles.Bottom Or AnchorStyles.Left - .AskForExecute.Anchor = AnchorStyles.Bottom Or AnchorStyles.Left - ' fill Data grid-view for DBSequence - Dim cb As New DataGridViewComboBoxColumn With { - .HeaderText = "Sequence Step", - .ReadOnly = False - } - cb.ValueType() = GetType(String) - Dim ds As New List(Of String) - - ' first add the DBMapper and DBAction definitions available in the Workbook - For Each DBModiftype As String In DBModifDefColl.Keys - ' avoid DB Sequences (might be - indirectly - self referencing, leading to endless recursion) - If DBModiftype <> "DBSeqnce" Then - For Each nodeName As String In DBModifDefColl(DBModiftype).Keys - ds.Add(DBModiftype + ":" + nodeName) - Next - End If - Next - - ' then add DBRefresh items for allowing refreshing DBFunctions (DBListFetch and DBSetQuery) during a Sequence - Dim searchCell As Excel.Range - For Each ws As Excel.Worksheet In actWb.Worksheets - ExcelDnaUtil.Application.Statusbar = "Looking for DBFunctions in " + ws.Name + " for adding possibility to DB Sequence" - For Each theFunc As String In {"DBListFetch(", "DBSetQuery(", "DBRowFetch("} - searchCell = ws.Cells.Find(What:=theFunc, After:=ws.Range("A1"), LookIn:=Excel.XlFindLookIn.xlFormulas, LookAt:=Excel.XlLookAt.xlPart, SearchOrder:=Excel.XlSearchOrder.xlByRows, SearchDirection:=Excel.XlSearchDirection.xlNext, MatchCase:=False) - Dim firstFoundAddress As String = "" - If searchCell IsNot Nothing Then firstFoundAddress = searchCell.Address - While searchCell IsNot Nothing - Dim underlyingName As String = getUnderlyingDBNameFromRange(searchCell) - ds.Add("Refresh " + theFunc + searchCell.Parent.Name + "!" + searchCell.Address + "):" + underlyingName) - searchCell = ws.Cells.FindNext(searchCell) - If searchCell.Address = firstFoundAddress Then Exit While - End While - Next - ' reset the cell find dialog.... - searchCell = Nothing - searchCell = ws.Cells.Find(What:="", After:=ws.Range("A1"), LookIn:=Excel.XlFindLookIn.xlFormulas, LookAt:=Excel.XlLookAt.xlPart, SearchOrder:=Excel.XlSearchOrder.xlByRows, SearchDirection:=Excel.XlSearchDirection.xlNext, MatchCase:=False) - Next - ExcelDnaUtil.Application.Statusbar = False - ' at last add special items DBBeginTrans and DBCommitTrans for setting DB Transaction brackets - ds.Add("DBBegin:Begins DB Transaction") - ds.Add("DBCommitRollback:Commits or Rolls back DB Transaction") - ' and bind the dataset to the combo-box - cb.DataSource() = ds - .DBSeqenceDataGrid.Columns.Add(cb) - .DBSeqenceDataGrid.Columns(0).Width = 400 - Else - theDBModifCreateDlg.FormBorderStyle = FormBorderStyle.FixedDialog - theDBModifCreateDlg.MinimumSize = New Drawing.Size(width:=490, height:=290) - theDBModifCreateDlg.Size = New Drawing.Size(width:=490, height:=290) - ' hide controls irrelevant for DBMapper and DBAction - .DBSeqenceDataGrid.Hide() - End If - - ' delegate filling of dialog fields to created DBModif object - If existingDBModif IsNot Nothing Then existingDBModif.setDBModifCreateFields(theDBModifCreateDlg) - ' reflect parametrized settings of DBAction in GUI - theDBModifCreateDlg.setDBActionParametrizedGUI() - - ' display dialog for parameters - If theDBModifCreateDlg.ShowDialog() = DialogResult.Cancel Then Exit Sub - - ' only for DBMapper or DBAction: change or add target range name, for DBAction check template placeholders - If createdDBModifType <> "DBSeqnce" Then - Dim targetRange As Excel.Range - If existingDBModif Is Nothing Then - targetRange = ExcelDnaUtil.Application.Selection - Else - targetRange = existingDBModif.getTargetRange() - End If - - If existingDefName = "" Then - Try - actWbNames.Add(Name:=createdDBModifType + .DBModifName.Text, RefersTo:=targetRange) - Catch ex As Exception - UserMsg("Error when assigning range name '" + createdDBModifType + .DBModifName.Text + "' to active cell: " + ex.Message, "DBModifier Creation Error") - Exit Sub - End Try - Else - ' rename named range... - actWbNames.Item(existingDefName).Name = createdDBModifType + .DBModifName.Text - End If - - ' cross check with template parameter placeholders - If createdDBModifType = "DBAction" And theDBModifCreateDlg.paramRangesStr.Text <> "" Then - Dim templateSQL As String = "" - For Each aCell As Excel.Range In targetRange - templateSQL += aCell.Value - Next - Dim paramEnclosing As String = IIf(theDBModifCreateDlg.paramEnclosing.Text = "", "!", theDBModifCreateDlg.paramEnclosing.Text) - Dim paramNum As Integer = 0 - For Each paramRange In Split(theDBModifCreateDlg.paramRangesStr.Text, ",") - paramNum += 1 : Dim placeHolder As String = paramEnclosing + paramNum.ToString() + paramEnclosing - If InStr(templateSQL, placeHolder) = 0 Then - UserMsg("Didn't find a corresponding placeholder (" + placeHolder + ") in DBAction template SQL for parameter " + paramNum.ToString() + ", this might be an error!", "DBAction Validation", MsgBoxStyle.Exclamation) - End If - templateSQL = templateSQL.Replace(placeHolder, "match" + paramNum.ToString()) - Next - If templateSQL Like "*" + paramEnclosing + "*" + paramEnclosing + "*" Then - UserMsg("found placeholders (" + paramEnclosing + "*" + paramEnclosing + ") not covered by parameters in DBAction template SQL (" + templateSQL + "), this might be an error!", "DBAction Validation", MsgBoxStyle.Exclamation) - End If - End If - End If - - Dim CustomXmlParts As Object = actWb.CustomXMLParts.SelectByNamespace("DBModifDef") - If CustomXmlParts.Count = 0 Then - ' in case no CustomXmlPart in Namespace DBModifDef exists in the workbook, add one - actWb.CustomXMLParts.Add("") - CustomXmlParts = actWb.CustomXMLParts.SelectByNamespace("DBModifDef") - End If - - ' remove old node in case of renaming DBModifier - ' Elements have names of DBModif types, attribute Name is given name () - If Not IsNothing(CustomXmlParts(1).SelectSingleNode("/ns0:root/ns0:" + createdDBModifType + "[@Name='" + Replace(existingDefName, createdDBModifType, "") + "']")) Then - CustomXmlParts(1).SelectSingleNode("/ns0:root/ns0:" + createdDBModifType + "[@Name='" + Replace(existingDefName, createdDBModifType, "") + "']").Delete - End If - - ' NamespaceURI:="DBModifDef" is required to avoid adding a xmlns attribute to each element. - CustomXmlParts(1).SelectSingleNode("/ns0:root").AppendChildNode(createdDBModifType, NamespaceURI:="DBModifDef") - ' new appended elements are last, get it to append further child elements - Dim dbModifNode As CustomXMLNode = CustomXmlParts(1).SelectSingleNode("/ns0:root").LastChild - ' append the detailed settings to the definition element - dbModifNode.AppendChildNode("Name", NodeType:=MsoCustomXMLNodeType.msoCustomXMLNodeAttribute, NodeValue:= .DBModifName.Text) - dbModifNode.AppendChildNode("execOnSave", NamespaceURI:="DBModifDef", NodeValue:= .execOnSave.Checked.ToString()) - dbModifNode.AppendChildNode("askBeforeExecute", NamespaceURI:="DBModifDef", NodeValue:= .AskForExecute.Checked.ToString()) - If createdDBModifType = "DBMapper" Then - dbModifNode.AppendChildNode("env", NamespaceURI:="DBModifDef", NodeValue:=(.envSel.SelectedIndex + 1).ToString()) ' if not selected, set environment to 0 (default anyway) - dbModifNode.AppendChildNode("database", NamespaceURI:="DBModifDef", NodeValue:= .Database.Text) - dbModifNode.AppendChildNode("tableName", NamespaceURI:="DBModifDef", NodeValue:= .Tablename.Text) - dbModifNode.AppendChildNode("primKeysStr", NamespaceURI:="DBModifDef", NodeValue:= .PrimaryKeys.Text) - dbModifNode.AppendChildNode("insertIfMissing", NamespaceURI:="DBModifDef", NodeValue:= .insertIfMissing.Checked.ToString()) - dbModifNode.AppendChildNode("executeAdditionalProc", NamespaceURI:="DBModifDef", NodeValue:= .addStoredProc.Text) - dbModifNode.AppendChildNode("ignoreColumns", NamespaceURI:="DBModifDef", NodeValue:= .IgnoreColumns.Text) - dbModifNode.AppendChildNode("CUDFlags", NamespaceURI:="DBModifDef", NodeValue:= .CUDflags.Checked.ToString()) - dbModifNode.AppendChildNode("AutoIncFlag", NamespaceURI:="DBModifDef", NodeValue:= .AutoIncFlag.Checked.ToString()) - dbModifNode.AppendChildNode("IgnoreDataErrors", NamespaceURI:="DBModifDef", NodeValue:= .IgnoreDataErrors.Checked.ToString()) - ElseIf createdDBModifType = "DBAction" Then - dbModifNode.AppendChildNode("env", NamespaceURI:="DBModifDef", NodeValue:=(.envSel.SelectedIndex + 1).ToString()) - dbModifNode.AppendChildNode("database", NamespaceURI:="DBModifDef", NodeValue:= .Database.Text) - dbModifNode.AppendChildNode("parametrized", NamespaceURI:="DBModifDef", NodeValue:= .parametrized.Checked.ToString()) - dbModifNode.AppendChildNode("continueIfRowEmpty", NamespaceURI:="DBModifDef", NodeValue:= .continueIfRowEmpty.Checked.ToString()) - If .paramRangesStr.Text <> "" Then dbModifNode.AppendChildNode("paramRangesStr", NamespaceURI:="DBModifDef", NodeValue:= .paramRangesStr.Text) - If .paramEnclosing.Text <> "" Then dbModifNode.AppendChildNode("paramEnclosing", NamespaceURI:="DBModifDef", NodeValue:= .paramEnclosing.Text) - If .convertAsDate.Text <> "" Then dbModifNode.AppendChildNode("convertAsDate", NamespaceURI:="DBModifDef", NodeValue:= .convertAsDate.Text) - If .convertAsString.Text <> "" Then dbModifNode.AppendChildNode("convertAsString", NamespaceURI:="DBModifDef", NodeValue:= .convertAsString.Text) - ElseIf createdDBModifType = "DBSeqnce" Then - ' "repaired" mode (indicating rewriting DBSequence Steps) - If .Tag = "repaired" Then - Dim repairedSequence() As String = Split(.RepairDBSeqnce.Text, vbCrLf) - For i As Integer = 0 To UBound(repairedSequence) - dbModifNode.AppendChildNode("seqStep", NamespaceURI:="DBModifDef", NodeValue:=repairedSequence(i)) - Next - Else - For i As Integer = 0 To .DBSeqenceDataGrid.Rows().Count - 2 - dbModifNode.AppendChildNode("seqStep", NamespaceURI:="DBModifDef", NodeValue:= .DBSeqenceDataGrid.Rows(i).Cells(0).Value) - Next - End If - End If - ' any features added directly to DBModif definition in XML need to be re-added now - If existingDBModif IsNot Nothing Then existingDBModif.addHiddenFeatureDefs(dbModifNode) - ' refresh mapper definitions to reflect changes immediately... - getDBModifDefinitions(actWb) - ' extend Data-range for new DBMappers immediately after definition... - If createdDBModifType = "DBMapper" Then - DirectCast(DBModifDefColl("DBMapper").Item(createdDBModifType + .DBModifName.Text), DBMapper).extendDataRange() - End If - - End With - End Sub - - ''' check one param range input (name) and return the range if successful - ''' name of parameter range - ''' - Public Function checkAndReturnRange(paramRange As String) As Excel.Range - Dim actWbNames As Excel.Names - Try : actWbNames = ExcelDnaUtil.Application.ActiveWorkbook.Names : Catch ex As Exception - Throw New Exception("Exception when trying to get the active workbook names for executeTemplateSQL: " + ex.Message + ", this might be either due to errors in the VBA-IDE (missing references) or due to opening this workbook from an MS-Office hyperlink, starting up Excel (timing issue). Switch to another workbook and back to fix.") - End Try - ' either get the range from a workbook based name or current sheet name (no ! in name) - If InStr(paramRange, "!") = 0 Then - If Not existsName(paramRange) Then - Throw New Exception("Name '" + paramRange + "' doesn't exist as a workbook name (you need to qualify names defined in worksheets with sheet_name!range_name).") - Else - checkAndReturnRange = actWbNames.Item(paramRange).RefersToRange - End If - Else - ' .. or from a worksheet based name from a sheet - Dim wsNameParts() As String = Split(paramRange, "!") - Dim sheetName As String = wsNameParts(0).Replace("'", "") - Dim nameSheet = ExcelDnaUtil.Application.ActiveWorkbook.Worksheets(sheetName) - If existsSheet(sheetName, ExcelDnaUtil.Application.ActiveWorkbook) Then - If nameSheet Is ExcelDnaUtil.Application.ActiveSheet Then - ' different access to names from current sheet, these are in actWbNames with full qualification - If existsName(paramRange) Then - checkAndReturnRange = actWbNames.Item(paramRange).RefersToRange - Else - Throw New Exception("Name '" + paramRange + "' is not defined in current worksheet") - End If - Else - If existsNameInSheet(wsNameParts(1), nameSheet) Then - checkAndReturnRange = getRangeFromNameInSheet(wsNameParts(1), nameSheet) - Else - Throw New Exception("Name '" + paramRange + "' is not defined in worksheet '" + sheetName + "'") - End If - End If - Else - Throw New Exception("Sheet '" + sheetName + "' referred to in '" + paramRange + "' does not exist in active workbook") - End If - End If - End Function - - ''' gets defined names for DBModifier (DBMapper/DBAction/DBSeqnce) invocation in the current workbook and updates Ribbon with it - Public Sub getDBModifDefinitions(actWb As Excel.Workbook, Optional onlyCheck As Boolean = False) - - ' load DBModifier definitions (objects) into Global collection DBModifDefColl - LogInfo("reading DBModifier Definitions for Workbook: " + actWb.Name) - Try - DBModifDefColl.Clear() - Dim CustomXmlParts As Object = actWb.CustomXMLParts.SelectByNamespace("DBModifDef") - If CustomXmlParts.Count = 1 Then - Dim actWbNames As Excel.Names - Try : actWbNames = actWb.Names : Catch ex As Exception - UserMsg("Exception when trying to get the active workbook names for getting DBModifier definitions: " + ex.Message + ", this might be either due to errors in the VBA-IDE (missing references) or due to opening this workbook from an MS-Office hyperlink, starting up Excel (timing issue). Switch to another workbook and back to fix.") - Exit Sub - End Try - - ' read DBModifier definitions from CustomXMLParts - For Each customXMLNodeDef As CustomXMLNode In CustomXmlParts(1).SelectSingleNode("/ns0:root").ChildNodes - Dim DBModiftype As String = Left(customXMLNodeDef.BaseName, 8) - If DBModiftype = "DBSeqnce" Or DBModiftype = "DBMapper" Or DBModiftype = "DBAction" Then - Dim nodeName As String - If customXMLNodeDef.Attributes.Count > 0 Then - nodeName = DBModiftype + customXMLNodeDef.Attributes(1).Text - Else - nodeName = customXMLNodeDef.BaseName - End If - LogInfo("reading DBModifier Definition for " + nodeName) - Dim targetRange As Excel.Range = Nothing - ' for DBMappers and DBActions the data of the DBModification is stored in Ranges, so check for those and get the Range - If DBModiftype = "DBMapper" Or DBModiftype = "DBAction" Then - For Each rangename As Excel.Name In actWbNames - Dim rangenameName As String = Replace(rangename.Name, rangename.Parent.Name + "!", "") - If rangenameName = nodeName Then - If InStr(rangename.RefersTo, "#REF!") > 0 Then - UserMsg(DBModiftype + " definitions range " + rangename.Name + " contains #REF!", "DBModifier Definitions Error") - Exit For - End If - ' might fail if target name relates to an invalid (offset) formula ... - Try - targetRange = rangename.RefersToRange - Catch ex As Exception - If InStr(rangename.RefersTo, "OFFSET(") > 0 Then - UserMsg("Offset formula that '" + nodeName + "' refers to, did not return a valid range." + vbCrLf + "Please check the offset formula to return a valid range !", "DBModifier Definitions Error") - ExcelDnaUtil.Application.Dialogs(Excel.XlBuiltInDialog.xlDialogNameManager).Show() - GoTo EndOuterLoop - End If - End Try - Exit For - End If - Next - If targetRange Is Nothing Then - Dim answer As MsgBoxResult = QuestionMsg("Required target range named '" + nodeName + "' cannot be found for this " + DBModiftype + " definition." + vbCrLf + "Should the target range name and definition be removed (If you still need the " + DBModiftype + ", (re)create the target range with this name again)?", , "DBModifier Definitions Error", MsgBoxStyle.Critical) - If answer = MsgBoxResult.Ok Then - ' remove name, in case it still exists - Try : actWbNames.Item(nodeName).Delete() : Catch ex As Exception : End Try - ' remove node - If Not IsNothing(CustomXmlParts(1).SelectSingleNode("/ns0:root/ns0:" + DBModiftype + "[@Name='" + Replace(nodeName, DBModiftype, "") + "']")) Then - Try : CustomXmlParts(1).SelectSingleNode("/ns0:root/ns0:" + DBModiftype + "[@Name='" + Replace(nodeName, DBModiftype, "") + "']").Delete : Catch ex As Exception - UserMsg("Error removing node in DBModif definitions: " + ex.Message) - End Try - End If - End If - Continue For - End If - End If - ' finally create the DBModif Object ... - Dim newDBModif As DBModif = Nothing - ' fill parameters into CustomXMLPart: - If DBModiftype = "DBMapper" Then - newDBModif = New DBMapper(customXMLNodeDef, targetRange) - ElseIf DBModiftype = "DBAction" Then - newDBModif = New DBAction(customXMLNodeDef, targetRange) - ElseIf DBModiftype = "DBSeqnce" Then - newDBModif = New DBSeqnce(customXMLNodeDef) - Else - UserMsg("Not supported DBModifier type: " + DBModiftype, "DBModifier Definitions Error") - End If - ' ... and add it to the collection DBModifDefColl - Dim defColl As Dictionary(Of String, DBModif) ' definition lookup collection for DBModifiername -> object - If newDBModif IsNot Nothing Then - If Not DBModifDefColl.ContainsKey(DBModiftype) Then - ' add to new DBModiftype "menu" - defColl = New Dictionary(Of String, DBModif) From { - {nodeName, newDBModif} - } - DBModifDefColl.Add(DBModiftype, defColl) - Else - ' add definition to existing DBModiftype "menu" - defColl = DBModifDefColl(DBModiftype) - If defColl.ContainsKey(nodeName) Then - UserMsg("DBModifier " + nodeName + " added twice, this potentially indicates legacy definitions that were modified!" + vbCrLf + "To fix, convert all other definitions in the same way and then remove the legacy definitions by editing the raw DB Modif definitions.", IIf(onlyCheck, "check", "get") + " DBModif Definitions") - Else - defColl.Add(nodeName, newDBModif) - End If - End If - End If - End If -EndOuterLoop: - Next - ElseIf CustomXmlParts.Count > 1 Then - UserMsg("Multiple CustomXmlParts for DBModifDef existing!", IIf(onlyCheck, "check", "get") + " DBModif Definitions") - End If - theRibbon.Invalidate() - Catch ex As Exception - UserMsg("Exception in getting DB Modifier Definitions: " + ex.Message, "DBModifier Definitions Error") - End Try - End Sub - - ''' correct quotes in field name - ''' field name to correct - ''' quote corrected field name - Public Function CorrectQuotes(fieldname As String) As String - CorrectQuotes = Replace(fieldname, closingQuote, closingQuoteReplacement) - End Function - - ''' gets DB Modification Name (DBMapper or DBAction) from theRange - ''' - ''' the retrieved name as a string (not name object !) - Public Function getDBModifNameFromRange(theRange As Excel.Range) As String - Dim nm As Excel.Name - Dim rng, testRng As Excel.Range - Dim theWbNames As Excel.Names - - getDBModifNameFromRange = "" - If theRange Is Nothing Then Exit Function - Try : theWbNames = theRange.Parent.Parent.Names : Catch ex As Exception - UserMsg("Exception getting the range's parent workbook names: " + ex.Message + ", this might be either due to errors in the VBA-IDE (missing references) or due to opening this workbook from an MS-Office hyperlink, starting up Excel (timing issue). Switch to another workbook and back to fix.") - Exit Function - End Try - Try - ' try all names in workbook - For Each nm In theWbNames - rng = Nothing - ' test whether range referring to that name (if it is a real range)... - Try : rng = nm.RefersToRange : Catch ex As Exception : End Try - If rng IsNot Nothing Then - testRng = Nothing - ' ...intersects with the passed range - Try : testRng = ExcelDnaUtil.Application.Intersect(theRange, rng) : Catch ex As Exception : End Try - If testRng IsNot Nothing And (InStr(1, nm.Name, "DBMapper") >= 1 Or InStr(1, nm.Name, "DBAction") >= 1) Then - ' and pass back the name if it does and is a DBMapper or a DBAction - getDBModifNameFromRange = nm.Name - Exit Function - End If - End If - Next - Catch ex As Exception - UserMsg("Exception: " + ex.Message, "get DBModif Name From Range") - End Try - End Function - - ''' To check for errors in passed range obj, makes use of the fact that Range.Value never passes Integer Values back except for Errors - ''' Range.Value to be checked for errors - ''' https://xldennis.wordpress.com/2006/11/22/dealing-with-cverr-values-in-net-%E2%80%93-part-i-the-problem/ and https://xldennis.wordpress.com/2006/11/29/dealing-with-cverr-values-in-net-part-ii-solutions/ - ''' true if error - Public Function IsXLCVErr(rangeval As Object) As Boolean - Return TypeOf (rangeval) Is Int32 - End Function - - ''' to convert the error number to text - ''' integer error number - ''' text of error - Public Function CVErrText(whichError As Integer) As String - Select Case whichError - Case -2146826281 : Return "#Div0!" - Case -2146826245 : Return "#GettingData" - Case -2146826246 : Return "#N/A" - Case -2146826259 : Return "#Name" - Case -2146826288 : Return "#Null!" - Case -2146826252 : Return "#Num!" - Case -2146826265 : Return "#Ref!" - Case -2146826273 : Return "#Value!" - Case Else : Return "unknown error !!" - End Select - End Function - - ''' execute given DBModifier, used for VBA call by Application.Run - ''' Full name of DB Modifier, including type at beginning - ''' if set to true, DBAddin will avoid to issue messages and return messages in exceptions which are returned (headless) - ''' empty string on success, error message otherwise - - Public Function executeDBModif(DBModifName As String, Optional headLess As Boolean = False) As String - hadError = False : nonInteractive = headLess - nonInteractiveErrMsgs = "" ' reset non-interactive messages - Dim DBModiftype As String = Left(DBModifName, 8) - If DBModiftype = "DBSeqnce" Or DBModiftype = "DBMapper" Or DBModiftype = "DBAction" Then - If Not DBModifDefColl(DBModiftype).ContainsKey(DBModifName) Then - If DBModifDefColl(DBModiftype).Count = 0 Then - nonInteractive = False - Return "No DBModifier contained in Workbook at all!" - End If - Dim DBModifavailable As String = "" - For Each DBMtype As String In {"DBMapper", "DBAction", "DBSeqnce"} - For Each DBMkey As String In DBModifDefColl(DBMtype).Keys - DBModifavailable += "," + DBMkey - Next - Next - nonInteractive = False - Return "DB Modifier '" + DBModifName + "' not existing, available: " + DBModifavailable - End If - LogInfo("Doing DBModifier '" + DBModifName + "' ...") - Try - DBModifDefColl(DBModiftype).Item(DBModifName).doDBModif() - Catch ex As Exception - nonInteractive = False - Return "DB Modifier '" + DBModifName + "' doDBModif had following error(s): " + ex.Message - End Try - nonInteractive = False - If hadError Then Return nonInteractiveErrMsgs - ElseIf DBModiftype = "Refresh " Then - ' DBModifName for DBfunction refresh is "Refresh Sheet-name!Address" where Sheet-name!Address is a cell containing the DBfunction - Dim RangeParts() As String = Split(Mid(DBModifName, 9), "!") - If RangeParts.Count = 2 And RangeParts(0) <> "" And RangeParts(1) <> "" Then - Dim SheetName = Replace(RangeParts(0), "'", "") ' for sheet-names with blanks surrounding quotations are needed, remove them here - Dim Address = RangeParts(1) - Dim srcExtent As String = "" - Try : srcExtent = getUnderlyingDBNameFromRange(ExcelDnaUtil.Application.Worksheets(SheetName).Range(Address)) : Catch ex As Exception : End Try - If srcExtent = "" Then Return "No valid address found in " + DBModifName + " (Sheet-name: " + SheetName + ", Address: " + Address + ")" - Dim aDBModifier As New DBModifDummy() - aDBModifier.executeRefresh(srcExtent) - Else - Return "No Worksheet/Address could be parsed from " + DBModifName - End If - Else - nonInteractive = False - Return "No valid type (" + DBModiftype + ") in passed DB Modifier '" + DBModifName + "', DB Modifier name must start with 'DBSeqnce', 'DBMapper' Or 'DBAction' !" - End If - Return "" ' no error, no message - End Function - - ''' set given execution parameter, used for VBA call by Application.Run - ''' execution parameter, like "selectedEnvironment" (zero based here!) or "CnnTimeout" - ''' execution parameter value - - Public Sub setExecutionParam(Param As String, Value As Object) - Try - If Param = "headLess" Then - nonInteractive = Value - nonInteractiveErrMsgs = "" ' reset non-interactive messages - ElseIf Param = "selectedEnvironment" Then - SettingsTools.selectedEnvironment = Value - theRibbon.InvalidateControl("envDropDown") - ElseIf Param = "ConstConnString" Then - SettingsTools.ConstConnString = Value - ElseIf Param = "CnnTimeout" Then - SettingsTools.CnnTimeout = Value - ElseIf Param = "CmdTimeout" Then - SettingsTools.CmdTimeout = Value - ElseIf Param = "preventRefreshFlag" Then - Functions.preventRefreshFlag = Value - theRibbon.InvalidateControl("preventRefresh") - Else - UserMsg("parameter " + Param + " not supported by setExecutionParams") - Exit Sub - End If - Catch ex As Exception - UserMsg("setting parameter " + Param + " with value " + CStr(Value) + " resulted in error " + ex.Message) - End Try - End Sub - - ''' get given execution parameter or setting parameter found by fetchSetting, used for VBA call by Application.Run - ''' execution parameter, like "selectedEnvironment" (zero based here!), "env()" or "CnnTimeout" - ''' execution or setting parameter value - - Public Function getExecutionParam(Param As String) As Object - If Param = "selectedEnvironment" Then - Return SettingsTools.selectedEnvironment - ElseIf Param = "env()" Then - Return SettingsTools.env() - ElseIf Param = "ConstConnString" Then - Return SettingsTools.ConstConnString - ElseIf Param = "CnnTimeout" Then - Return SettingsTools.CnnTimeout - ElseIf Param = "CmdTimeout" Then - Return SettingsTools.CmdTimeout - ElseIf Param = "preventRefreshFlag" Then - Return Functions.preventRefreshFlag - Else - Return fetchSetting(Param, "parameter " + Param + " neither supported by getExecutionParam nor found with fetchSetting(Param)") - End If - End Function - - ''' marks a row in a DBMapper for deletion, used as a ExcelCommand to have a keyboard shortcut - - Public Sub deleteRow() - Dim targetName As String = getDBModifNameFromRange(ExcelDnaUtil.Application.Selection) - If Left(targetName, 8) = "DBMapper" Then DirectCast(DBModifDefColl("DBMapper").Item(targetName), DBMapper).insertCUDMarks(ExcelDnaUtil.Application.Selection, deleteFlag:=True) - End Sub - - ''' inserts a row in a DBMapper, used as a ExcelCommand to have a keyboard shortcut - - Public Sub insertRow() - Dim targetName As String = getDBModifNameFromRange(ExcelDnaUtil.Application.Selection) - If Left(targetName, 8) = "DBMapper" Then - ' get the target range for the DBMapper to get the ListObject - Dim insertTarget As Excel.Range = DirectCast(DBModifDefColl("DBMapper").Item(targetName), DBMapper).getTargetRange - ' calculate insert row from selection and top row of insert target - Dim insertRow As Integer = ExcelDnaUtil.Application.Selection.Row - insertTarget.Row - ' just add a row to the ListObject, the rest (shifting down existing CUD Marks and adding "i") is being taken care of the Application_SheetChange event procedure and the insertCUDMarks method - insertTarget.ListObject.ListRows.Add(insertRow) - End If - End Sub -End Module ''' Custom Command builder base class for SQL Server, ODBC and OLE DB to avoid primary key problems with built-in ones ''' derived (transposed into VB.NET) from https://www.cogin.com/articles/CustomCommandBuilder.php @@ -2444,7 +1656,7 @@ Public Class CustomCommandBuilder End Class -''' Custom Command builder for SQLServer class''' +''' Custom Command builder for SQLServer class Public Class CustomSqlCommandBuilder Inherits CustomCommandBuilder @@ -2570,7 +1782,7 @@ Public Class CustomSqlCommandBuilder End Class -''' Custom Command builder for ODBC class''' +''' Custom Command builder for ODBC class Public Class CustomOdbcCommandBuilder Inherits CustomCommandBuilder @@ -2695,7 +1907,7 @@ Public Class CustomOdbcCommandBuilder End Class -''' Custom Command builder for OleDB class''' +''' Custom Command builder for OleDB class Public Class CustomOleDbCommandBuilder Inherits CustomCommandBuilder diff --git a/source/DBModifHelper.vb b/source/DBModifHelper.vb new file mode 100644 index 00000000..2405df38 --- /dev/null +++ b/source/DBModifHelper.vb @@ -0,0 +1,799 @@ +Imports ExcelDna.Integration +Imports System.Windows.Forms +Imports System.Collections.Generic +Imports Microsoft.Office.Interop +Imports System.Data +Imports System.Data.Common +Imports System.Data.Odbc +Imports System.Data.OleDb +Imports System.Data.SqlClient +Imports Microsoft.Office.Core + + +''' global helper functions for DBModifiers +Public Module DBModifHelper + ''' DBModif definition collections of DBmodif types (key of top level dictionary) with values being collections of DBModifierNames (key of contained dictionaries) and DBModifiers (value of contained dictionaries)) + Public DBModifDefColl As Dictionary(Of String, Dictionary(Of String, DBModif)) + ''' main db connection for DB modifiers + Public idbcnn As System.Data.IDbConnection + ''' avoid entering Application.SheetChange Event handler during listfetch/setquery + Public preventChangeWhileFetching As Boolean = False + ''' indicates an error in execution of DBModifiers, used for commit/rollback and for non-interactive message return + Public hadError As Boolean + ''' used to work around the fact that when started by Application.Run, Formulas are sometimes returned as local + Public listSepLocal As String = ExcelDnaUtil.Application.International(Excel.XlApplicationInternational.xlListSeparator) + ''' common transaction, needed for DBSequence and all other DB Modifiers + Public trans As DbTransaction = Nothing + ''' opening quote, e.g. [ for SQL Server + Public openingQuote As String + ''' closing quote, e.g. ] for SQL Server + Public closingQuote As String + ''' Replacement for closing quote, if needed, e.g. SQL Server requires ] to be replaced by ]] + Public closingQuoteReplacement As String + ''' Mapping of field names to parameter names (Param + number) + Public FieldParamMap As Dictionary(Of String, String) + + ''' cast .NET data type to ADO.NET DbType + ''' given .NET data type + ''' ADO.NET DbType + Public Function TypeToDbType(t As Type, columnName As String, schemaDataTypeCollection As Collection) As DbType + ' use the provider specific type information if it exists + If schemaDataTypeCollection.Contains(columnName) Then + Select Case schemaDataTypeCollection(columnName) + Case "char" : TypeToDbType = DbType.AnsiStringFixedLength + Case "nchar" : TypeToDbType = DbType.StringFixedLength + Case "varchar" : TypeToDbType = DbType.AnsiString + Case "nvarchar" : TypeToDbType = DbType.String + Case "uniqueidentifier" : TypeToDbType = DbType.Guid + Case "binary" : TypeToDbType = DbType.Binary + Case "datetime2" : TypeToDbType = DbType.DateTime2 + Case "time" : TypeToDbType = DbType.Time + Case Else + Try + TypeToDbType = DirectCast([Enum].Parse(GetType(DbType), t.Name), DbType) + Catch ex As Exception + TypeToDbType = DbType.Object + End Try + End Select + Exit Function + End If + Try + TypeToDbType = DirectCast([Enum].Parse(GetType(DbType), t.Name), DbType) + ' for most string types AnsiString is better + If TypeToDbType = DbType.String Then TypeToDbType = DbType.AnsiString + Catch ex As Exception + TypeToDbType = DbType.Object + End Try + End Function + + ''' opens a database connection + ''' number of the environment as given in the settings + ''' database to replace database selection parameter in connection string of environment + ''' True on success + Public Function openIdbConnection(env As Integer, database As String) As Boolean + openIdbConnection = False + + Dim theConnString As String = fetchSetting("ConstConnString" + env.ToString(), "") + If theConnString = "" Then + UserMsg("No connection string given for environment: " + env.ToString() + ", please correct and rerun.", "Open Connection Error") + Exit Function + End If + Dim dbidentifier As String = fetchSetting("DBidentifierCCS" + env.ToString(), "") + If dbidentifier = "" Then + UserMsg("No DB identifier given for environment: " + env.ToString() + ", please correct and rerun.", "Open Connection Error") + Exit Function + End If + + ' change the database in the connection string + theConnString = Change(theConnString, dbidentifier, database, ";") + ' need to change/set the connection timeout in the connection string as the property is readonly then... + If InStr(theConnString, "Connection Timeout=") > 0 Then + theConnString = Change(theConnString, "Connection Timeout=", CnnTimeout.ToString(), ";") + ElseIf InStr(theConnString, "Connect Timeout=") > 0 Then + theConnString = Change(theConnString, "Connect Timeout=", CnnTimeout.ToString(), ";") + Else + theConnString += ";Connection Timeout=" + CnnTimeout.ToString() + End If + + Try + If Left(theConnString.ToUpper, 5) = "ODBC;" Then + ' change to ODBC driver setting, if SQLOLEDB + theConnString = Replace(theConnString, fetchSetting("ConnStringSearch" + env.ToString(), "provider=SQLOLEDB"), fetchSetting("ConnStringReplace" + env.ToString(), "driver=SQL SERVER")) + ' remove "ODBC;" + theConnString = Right(theConnString, theConnString.Length - 5) + idbcnn = New OdbcConnection(theConnString) + ElseIf InStr(theConnString.ToLower, "provider=sqloledb") Or InStr(theConnString.ToLower, "driver=sql server") Then + ' remove provider=SQLOLEDB; (or whatever is in ConnStringSearch<>) for sql server as this is not allowed for ado.net (e.g. from a connection string for MS Query/Office) + theConnString = Replace(theConnString, fetchSetting("ConnStringSearch" + env.ToString(), "provider=SQLOLEDB") + ";", "") + idbcnn = New SqlConnection(theConnString) + ElseIf InStr(theConnString.ToLower, "oledb") Then + idbcnn = New OleDbConnection(theConnString) + Else + ' try with odbc + idbcnn = New OdbcConnection(theConnString) + End If + Catch ex As Exception + UserMsg("Error creating connection object: " + ex.Message + ", connection string: " + theConnString, "Open Connection Error") + idbcnn = Nothing + ExcelDnaUtil.Application.StatusBar = False + Exit Function + End Try + + LogInfo("open connection with " + theConnString) + ExcelDnaUtil.Application.StatusBar = "Trying " + CnnTimeout.ToString() + " sec. with connection string: " + theConnString + Try + idbcnn.Open() + openIdbConnection = True + Catch ex As Exception + UserMsg("Error connecting to DB: " + ex.Message + ", connection string: " + theConnString, "Open Connection Error") + idbcnn = Nothing + End Try + ExcelDnaUtil.Application.StatusBar = False + End Function + + ''' in case there is a defined DBMapper underlying the DBListFetch/DBSetQuery target area then change the extent of it (oldRange) to the new area given in theRange + ''' new extent after refresh of DBListFetch/DBSetQuery function + ''' extent before refresh of DBListFetch/DBSetQuery function + Public Sub resizeDBMapperRange(theRange As Excel.Range, oldRange As Excel.Range) + Dim actWbNames As Excel.Names + Try : actWbNames = ExcelDnaUtil.Application.ActiveWorkbook.Names : Catch ex As Exception + LogWarn("Exception when trying to get the active workbook names for getting DBModifier definitions: " + ex.Message + ", this might be either due to errors in the VBA-IDE (missing references) or due to opening this workbook from an MS-Office hyperlink, starting up Excel (timing issue). Switch to another workbook and back to fix.") + Exit Sub + End Try + ' only do this for the active workbook... + If theRange.Parent.Parent Is ExcelDnaUtil.Application.ActiveWorkbook Then + ' getDBModifNameFromRange gets any DBModifName (starting with DBMapper/DBAction...) intersecting theRange, so we can reassign it to the changed range with this... + Dim dbMapperRangeName As String = getDBModifNameFromRange(theRange) + ' only allow resizing of dbMapperRange if it was EXACTLY matching the FORMER target range of the DB Function + If Left(dbMapperRangeName, 8) = "DBMapper" AndAlso oldRange.Address = actWbNames.Item(dbMapperRangeName).RefersToRange.Address Then + ' (re)assign db mapper range name to the passed (changed) DBListFetch/DBSetQuery function target range + Try : theRange.Name = dbMapperRangeName + Catch ex As Exception + Throw New Exception("Error when assigning name '" + dbMapperRangeName + "' to DBListFetch/DBSetQuery target range: " + ex.Message) + End Try + ' pass the associated DBMapper the new target range + Try + Dim extendedMapper As DBMapper = DBModifDefColl("DBMapper").Item(dbMapperRangeName) + extendedMapper.setTargetRange(theRange) + Catch ex As Exception + Throw New Exception("Error passing new Range to the associated DBMapper object when extending '" + dbMapperRangeName + "' to DBListFetch/DBSetQuery target range: " + ex.Message) + End Try + End If + End If + End Sub + + ''' creates a DBModif at the current active cell or edits an existing one defined in targetDefName (after being called in defined range or from ribbon + Ctrl + Shift) + ''' + ''' + Public Sub createDBModif(createdDBModifType As String, Optional targetDefName As String = "") + Dim actWb As Excel.Workbook = Nothing + Try : actWb = ExcelDnaUtil.Application.ActiveWorkbook : Catch ex As Exception + UserMsg("Exception when trying to get the active workbook for creating DB Modifier: " + ex.Message + ", this might be either due to errors in the VBA-IDE (missing references) or due to opening this workbook from an MS-Office hyperlink, starting up Excel (timing issue). Switch to another workbook and back to fix.") + Exit Sub + End Try + If IsNothing(actWb) Then Exit Sub + Dim actWbNames As Excel.Names = Nothing + Try : actWbNames = actWb.Names : Catch ex As Exception + UserMsg("Exception when trying to get the active workbook names for creating DB Modifier: " + ex.Message + ", this might be either due to errors in the VBA-IDE (missing references) or due to opening this workbook from an MS-Office hyperlink, starting up Excel (timing issue). Switch to another workbook and back to fix.") + Exit Sub + End Try + Dim existingDBModif As DBModif = Nothing + Dim existingDefName As String = targetDefName + + ' fetch parameters if there is an existing definition... + If DBModifDefColl.ContainsKey(createdDBModifType) AndAlso DBModifDefColl(createdDBModifType).ContainsKey(existingDefName) Then + existingDBModif = DBModifDefColl(createdDBModifType).Item(existingDefName) + ' reset the target range to a potentially changed area + If createdDBModifType <> "DBSeqnce" Then + Dim existingDefRange As Excel.Range = Nothing + Try + existingDefRange = ExcelDnaUtil.Application.Range(existingDefName) + Catch ex As Exception + ' if target name relates to an invalid (offset) formula, getting a range fails ... + If InStr(actWbNames.Item(existingDefName).RefersTo, "OFFSET(") > 0 Then + UserMsg("Offset formula that '" + existingDefName + "' refers to, did not return a valid range." + vbCrLf + "Please check the offset formula to return a valid range !", "DBModifier Definitions Error") + ExcelDnaUtil.Application.Dialogs(Excel.XlBuiltInDialog.xlDialogNameManager).Show() + Exit Sub + End If + End Try + existingDBModif.setTargetRange(existingDefRange) + End If + End If + + ' prepare DBModifier Create Dialog + Dim theDBModifCreateDlg As New DBModifCreate() + With theDBModifCreateDlg + ' store DBModification type in tag for validation purposes... + .Tag = createdDBModifType + .envSel.DataSource = environdefs + .envSel.SelectedIndex = -1 + .DBModifName.Text = Replace(existingDefName, createdDBModifType, "") + .DBModifName.Tag = existingDefName + .RepairDBSeqnce.Hide() + .NameLabel.Text = IIf(createdDBModifType = "DBSeqnce", "DBSequence", createdDBModifType) + " Name:" + .Text = "Edit " + IIf(createdDBModifType = "DBSeqnce", "DBSequence", createdDBModifType) + " definition" + If createdDBModifType <> "DBMapper" Then + .TablenameLabel.Hide() + .PrimaryKeysLabel.Hide() + .AdditionalStoredProcLabel.Hide() + .IgnoreColumnsLabel.Hide() + .Tablename.Hide() + .PrimaryKeys.Hide() + .insertIfMissing.Hide() + .addStoredProc.Hide() + .IgnoreColumns.Hide() + .CUDflags.Hide() + .AutoIncFlag.Hide() + .IgnoreDataErrors.Hide() + End If + If createdDBModifType = "DBAction" Then + .paramRangesStr.Top = .Tablename.Top + .TablenameLabel.Show() + .TablenameLabel.Text = "Parameter Range Names:" + .paramRangesStr.Left = .Tablename.Left + .paramEnclosing.Top = .PrimaryKeys.Top + .PrimaryKeysLabel.Show() + .PrimaryKeysLabel.Text = "Parameter enclosing char:" + .paramEnclosing.Left = .PrimaryKeys.Left + .convertAsDate.Top = .IgnoreColumns.Top + .IgnoreColumnsLabel.Text = "Cols num params date:" + .IgnoreColumnsLabel.Show() + .convertAsDate.Left = .IgnoreColumns.Left + .convertAsString.Top = .addStoredProc.Top + .AdditionalStoredProcLabel.Show() + .AdditionalStoredProcLabel.Text = "Cols num params string:" + .convertAsString.Left = .addStoredProc.Left + .parametrized.Top = .CUDflags.Top + .parametrized.Left = .CUDflags.Left + .continueIfRowEmpty.Top = .IgnoreDataErrors.Top + .continueIfRowEmpty.Left = .IgnoreDataErrors.Left + Else + .TablenameLabel.Text = "Tablename:" + .PrimaryKeysLabel.Text = "Primary keys count:" + .IgnoreColumnsLabel.Text = "Ignore columns:" + .AdditionalStoredProcLabel.Text = "Additional stored procedure:" + .parametrized.Hide() + .paramRangesStr.Hide() + .paramEnclosing.Hide() + .convertAsDate.Hide() + .convertAsString.Hide() + .continueIfRowEmpty.Hide() + End If + If createdDBModifType = "DBSeqnce" Then + theDBModifCreateDlg.FormBorderStyle = FormBorderStyle.Sizable + ' hide controls irrelevant for DBSeqnce + .TargetRangeAddress.Hide() + .envSel.Hide() + .EnvironmentLabel.Hide() + .Database.Hide() + .DatabaseLabel.Hide() + .DBSeqenceDataGrid.Top = 55 + .DBSeqenceDataGrid.Height = 320 + .execOnSave.Top = .CreateCB.Top + .AskForExecute.Top = .CreateCB.Top + .execOnSave.Anchor = AnchorStyles.Bottom Or AnchorStyles.Left + .AskForExecute.Anchor = AnchorStyles.Bottom Or AnchorStyles.Left + ' fill Data grid-view for DBSequence + Dim cb As New DataGridViewComboBoxColumn With { + .HeaderText = "Sequence Step", + .ReadOnly = False + } + cb.ValueType() = GetType(String) + Dim ds As New List(Of String) + + ' first add the DBMapper and DBAction definitions available in the Workbook + For Each DBModiftype As String In DBModifDefColl.Keys + ' avoid DB Sequences (might be - indirectly - self referencing, leading to endless recursion) + If DBModiftype <> "DBSeqnce" Then + For Each nodeName As String In DBModifDefColl(DBModiftype).Keys + ds.Add(DBModiftype + ":" + nodeName) + Next + End If + Next + + ' then add DBRefresh items for allowing refreshing DBFunctions (DBListFetch and DBSetQuery) during a Sequence + Dim searchCell As Excel.Range + For Each ws As Excel.Worksheet In actWb.Worksheets + ExcelDnaUtil.Application.Statusbar = "Looking for DBFunctions in " + ws.Name + " for adding possibility to DB Sequence" + For Each theFunc As String In {"DBListFetch(", "DBSetQuery(", "DBRowFetch("} + searchCell = ws.Cells.Find(What:=theFunc, After:=ws.Range("A1"), LookIn:=Excel.XlFindLookIn.xlFormulas, LookAt:=Excel.XlLookAt.xlPart, SearchOrder:=Excel.XlSearchOrder.xlByRows, SearchDirection:=Excel.XlSearchDirection.xlNext, MatchCase:=False) + Dim firstFoundAddress As String = "" + If searchCell IsNot Nothing Then firstFoundAddress = searchCell.Address + While searchCell IsNot Nothing + Dim underlyingName As String = getUnderlyingDBNameFromRange(searchCell) + ds.Add("Refresh " + theFunc + searchCell.Parent.Name + "!" + searchCell.Address + "):" + underlyingName) + searchCell = ws.Cells.FindNext(searchCell) + If searchCell.Address = firstFoundAddress Then Exit While + End While + Next + ' reset the cell find dialog.... + searchCell = Nothing + searchCell = ws.Cells.Find(What:="", After:=ws.Range("A1"), LookIn:=Excel.XlFindLookIn.xlFormulas, LookAt:=Excel.XlLookAt.xlPart, SearchOrder:=Excel.XlSearchOrder.xlByRows, SearchDirection:=Excel.XlSearchDirection.xlNext, MatchCase:=False) + Next + ExcelDnaUtil.Application.Statusbar = False + ' at last add special items DBBeginTrans and DBCommitTrans for setting DB Transaction brackets + ds.Add("DBBegin:Begins DB Transaction") + ds.Add("DBCommitRollback:Commits or Rolls back DB Transaction") + ' and bind the dataset to the combo-box + cb.DataSource() = ds + .DBSeqenceDataGrid.Columns.Add(cb) + .DBSeqenceDataGrid.Columns(0).Width = 400 + Else + theDBModifCreateDlg.FormBorderStyle = FormBorderStyle.FixedDialog + theDBModifCreateDlg.MinimumSize = New Drawing.Size(width:=490, height:=290) + theDBModifCreateDlg.Size = New Drawing.Size(width:=490, height:=290) + ' hide controls irrelevant for DBMapper and DBAction + .DBSeqenceDataGrid.Hide() + End If + + ' delegate filling of dialog fields to created DBModif object + If existingDBModif IsNot Nothing Then existingDBModif.setDBModifCreateFields(theDBModifCreateDlg) + ' reflect parametrized settings of DBAction in GUI + theDBModifCreateDlg.setDBActionParametrizedGUI() + + ' display dialog for parameters + If theDBModifCreateDlg.ShowDialog() = DialogResult.Cancel Then Exit Sub + + ' only for DBMapper or DBAction: change or add target range name, for DBAction check template placeholders + If createdDBModifType <> "DBSeqnce" Then + Dim targetRange As Excel.Range + If existingDBModif Is Nothing Then + targetRange = ExcelDnaUtil.Application.Selection + Else + targetRange = existingDBModif.getTargetRange() + End If + + If existingDefName = "" Then + Try + actWbNames.Add(Name:=createdDBModifType + .DBModifName.Text, RefersTo:=targetRange) + Catch ex As Exception + UserMsg("Error when assigning range name '" + createdDBModifType + .DBModifName.Text + "' to active cell: " + ex.Message, "DBModifier Creation Error") + Exit Sub + End Try + Else + ' rename named range... + actWbNames.Item(existingDefName).Name = createdDBModifType + .DBModifName.Text + End If + + ' cross check with template parameter placeholders + If createdDBModifType = "DBAction" And theDBModifCreateDlg.paramRangesStr.Text <> "" Then + Dim templateSQL As String = "" + For Each aCell As Excel.Range In targetRange + templateSQL += aCell.Value + Next + Dim paramEnclosing As String = IIf(theDBModifCreateDlg.paramEnclosing.Text = "", "!", theDBModifCreateDlg.paramEnclosing.Text) + Dim paramNum As Integer = 0 + For Each paramRange In Split(theDBModifCreateDlg.paramRangesStr.Text, ",") + paramNum += 1 : Dim placeHolder As String = paramEnclosing + paramNum.ToString() + paramEnclosing + If InStr(templateSQL, placeHolder) = 0 Then + UserMsg("Didn't find a corresponding placeholder (" + placeHolder + ") in DBAction template SQL for parameter " + paramNum.ToString() + ", this might be an error!", "DBAction Validation", MsgBoxStyle.Exclamation) + End If + templateSQL = templateSQL.Replace(placeHolder, "match" + paramNum.ToString()) + Next + If templateSQL Like "*" + paramEnclosing + "*" + paramEnclosing + "*" Then + UserMsg("found placeholders (" + paramEnclosing + "*" + paramEnclosing + ") not covered by parameters in DBAction template SQL (" + templateSQL + "), this might be an error!", "DBAction Validation", MsgBoxStyle.Exclamation) + End If + End If + End If + + Dim CustomXmlParts As Object = actWb.CustomXMLParts.SelectByNamespace("DBModifDef") + If CustomXmlParts.Count = 0 Then + ' in case no CustomXmlPart in Namespace DBModifDef exists in the workbook, add one + actWb.CustomXMLParts.Add("") + CustomXmlParts = actWb.CustomXMLParts.SelectByNamespace("DBModifDef") + End If + + ' remove old node in case of renaming DBModifier + ' Elements have names of DBModif types, attribute Name is given name () + If Not IsNothing(CustomXmlParts(1).SelectSingleNode("/ns0:root/ns0:" + createdDBModifType + "[@Name='" + Replace(existingDefName, createdDBModifType, "") + "']")) Then + CustomXmlParts(1).SelectSingleNode("/ns0:root/ns0:" + createdDBModifType + "[@Name='" + Replace(existingDefName, createdDBModifType, "") + "']").Delete + End If + + ' NamespaceURI:="DBModifDef" is required to avoid adding a xmlns attribute to each element. + CustomXmlParts(1).SelectSingleNode("/ns0:root").AppendChildNode(createdDBModifType, NamespaceURI:="DBModifDef") + ' new appended elements are last, get it to append further child elements + Dim dbModifNode As CustomXMLNode = CustomXmlParts(1).SelectSingleNode("/ns0:root").LastChild + ' append the detailed settings to the definition element + dbModifNode.AppendChildNode("Name", NodeType:=MsoCustomXMLNodeType.msoCustomXMLNodeAttribute, NodeValue:= .DBModifName.Text) + dbModifNode.AppendChildNode("execOnSave", NamespaceURI:="DBModifDef", NodeValue:= .execOnSave.Checked.ToString()) + dbModifNode.AppendChildNode("askBeforeExecute", NamespaceURI:="DBModifDef", NodeValue:= .AskForExecute.Checked.ToString()) + If createdDBModifType = "DBMapper" Then + dbModifNode.AppendChildNode("env", NamespaceURI:="DBModifDef", NodeValue:=(.envSel.SelectedIndex + 1).ToString()) ' if not selected, set environment to 0 (default anyway) + dbModifNode.AppendChildNode("database", NamespaceURI:="DBModifDef", NodeValue:= .Database.Text) + dbModifNode.AppendChildNode("tableName", NamespaceURI:="DBModifDef", NodeValue:= .Tablename.Text) + dbModifNode.AppendChildNode("primKeysStr", NamespaceURI:="DBModifDef", NodeValue:= .PrimaryKeys.Text) + dbModifNode.AppendChildNode("insertIfMissing", NamespaceURI:="DBModifDef", NodeValue:= .insertIfMissing.Checked.ToString()) + dbModifNode.AppendChildNode("executeAdditionalProc", NamespaceURI:="DBModifDef", NodeValue:= .addStoredProc.Text) + dbModifNode.AppendChildNode("ignoreColumns", NamespaceURI:="DBModifDef", NodeValue:= .IgnoreColumns.Text) + dbModifNode.AppendChildNode("CUDFlags", NamespaceURI:="DBModifDef", NodeValue:= .CUDflags.Checked.ToString()) + dbModifNode.AppendChildNode("AutoIncFlag", NamespaceURI:="DBModifDef", NodeValue:= .AutoIncFlag.Checked.ToString()) + dbModifNode.AppendChildNode("IgnoreDataErrors", NamespaceURI:="DBModifDef", NodeValue:= .IgnoreDataErrors.Checked.ToString()) + ElseIf createdDBModifType = "DBAction" Then + dbModifNode.AppendChildNode("env", NamespaceURI:="DBModifDef", NodeValue:=(.envSel.SelectedIndex + 1).ToString()) + dbModifNode.AppendChildNode("database", NamespaceURI:="DBModifDef", NodeValue:= .Database.Text) + dbModifNode.AppendChildNode("parametrized", NamespaceURI:="DBModifDef", NodeValue:= .parametrized.Checked.ToString()) + dbModifNode.AppendChildNode("continueIfRowEmpty", NamespaceURI:="DBModifDef", NodeValue:= .continueIfRowEmpty.Checked.ToString()) + If .paramRangesStr.Text <> "" Then dbModifNode.AppendChildNode("paramRangesStr", NamespaceURI:="DBModifDef", NodeValue:= .paramRangesStr.Text) + If .paramEnclosing.Text <> "" Then dbModifNode.AppendChildNode("paramEnclosing", NamespaceURI:="DBModifDef", NodeValue:= .paramEnclosing.Text) + If .convertAsDate.Text <> "" Then dbModifNode.AppendChildNode("convertAsDate", NamespaceURI:="DBModifDef", NodeValue:= .convertAsDate.Text) + If .convertAsString.Text <> "" Then dbModifNode.AppendChildNode("convertAsString", NamespaceURI:="DBModifDef", NodeValue:= .convertAsString.Text) + ElseIf createdDBModifType = "DBSeqnce" Then + ' "repaired" mode (indicating rewriting DBSequence Steps) + If .Tag = "repaired" Then + Dim repairedSequence() As String = Split(.RepairDBSeqnce.Text, vbCrLf) + For i As Integer = 0 To UBound(repairedSequence) + dbModifNode.AppendChildNode("seqStep", NamespaceURI:="DBModifDef", NodeValue:=repairedSequence(i)) + Next + Else + For i As Integer = 0 To .DBSeqenceDataGrid.Rows().Count - 2 + dbModifNode.AppendChildNode("seqStep", NamespaceURI:="DBModifDef", NodeValue:= .DBSeqenceDataGrid.Rows(i).Cells(0).Value) + Next + End If + End If + ' any features added directly to DBModif definition in XML need to be re-added now + If existingDBModif IsNot Nothing Then existingDBModif.addHiddenFeatureDefs(dbModifNode) + ' refresh mapper definitions to reflect changes immediately... + getDBModifDefinitions(actWb) + ' extend Data-range for new DBMappers immediately after definition... + If createdDBModifType = "DBMapper" Then + DirectCast(DBModifDefColl("DBMapper").Item(createdDBModifType + .DBModifName.Text), DBMapper).extendDataRange() + End If + + End With + End Sub + + ''' check one param range input (name) and return the range if successful + ''' name of parameter range + ''' + Public Function checkAndReturnRange(paramRange As String) As Excel.Range + Dim actWbNames As Excel.Names + Try : actWbNames = ExcelDnaUtil.Application.ActiveWorkbook.Names : Catch ex As Exception + Throw New Exception("Exception when trying to get the active workbook names for executeTemplateSQL: " + ex.Message + ", this might be either due to errors in the VBA-IDE (missing references) or due to opening this workbook from an MS-Office hyperlink, starting up Excel (timing issue). Switch to another workbook and back to fix.") + End Try + ' either get the range from a workbook based name or current sheet name (no ! in name) + If InStr(paramRange, "!") = 0 Then + If Not existsName(paramRange) Then + Throw New Exception("Name '" + paramRange + "' doesn't exist as a workbook name (you need to qualify names defined in worksheets with sheet_name!range_name).") + Else + checkAndReturnRange = actWbNames.Item(paramRange).RefersToRange + End If + Else + ' .. or from a worksheet based name from a sheet + Dim wsNameParts() As String = Split(paramRange, "!") + Dim sheetName As String = wsNameParts(0).Replace("'", "") + Dim nameSheet = ExcelDnaUtil.Application.ActiveWorkbook.Worksheets(sheetName) + If existsSheet(sheetName, ExcelDnaUtil.Application.ActiveWorkbook) Then + If nameSheet Is ExcelDnaUtil.Application.ActiveSheet Then + ' different access to names from current sheet, these are in actWbNames with full qualification + If existsName(paramRange) Then + checkAndReturnRange = actWbNames.Item(paramRange).RefersToRange + Else + Throw New Exception("Name '" + paramRange + "' is not defined in current worksheet") + End If + Else + If existsNameInSheet(wsNameParts(1), nameSheet) Then + checkAndReturnRange = getRangeFromNameInSheet(wsNameParts(1), nameSheet) + Else + Throw New Exception("Name '" + paramRange + "' is not defined in worksheet '" + sheetName + "'") + End If + End If + Else + Throw New Exception("Sheet '" + sheetName + "' referred to in '" + paramRange + "' does not exist in active workbook") + End If + End If + End Function + + ''' gets defined names for DBModifier (DBMapper/DBAction/DBSeqnce) invocation in the current workbook and updates Ribbon with it + Public Sub getDBModifDefinitions(actWb As Excel.Workbook, Optional onlyCheck As Boolean = False) + + ' load DBModifier definitions (objects) into Global collection DBModifDefColl + LogInfo("reading DBModifier Definitions for Workbook: " + actWb.Name) + Try + DBModifDefColl.Clear() + Dim CustomXmlParts As Object = actWb.CustomXMLParts.SelectByNamespace("DBModifDef") + If CustomXmlParts.Count = 1 Then + Dim actWbNames As Excel.Names + Try : actWbNames = actWb.Names : Catch ex As Exception + UserMsg("Exception when trying to get the active workbook names for getting DBModifier definitions: " + ex.Message + ", this might be either due to errors in the VBA-IDE (missing references) or due to opening this workbook from an MS-Office hyperlink, starting up Excel (timing issue). Switch to another workbook and back to fix.") + Exit Sub + End Try + + ' read DBModifier definitions from CustomXMLParts + For Each customXMLNodeDef As CustomXMLNode In CustomXmlParts(1).SelectSingleNode("/ns0:root").ChildNodes + Dim DBModiftype As String = Left(customXMLNodeDef.BaseName, 8) + If DBModiftype = "DBSeqnce" Or DBModiftype = "DBMapper" Or DBModiftype = "DBAction" Then + Dim nodeName As String + If customXMLNodeDef.Attributes.Count > 0 Then + nodeName = DBModiftype + customXMLNodeDef.Attributes(1).Text + Else + nodeName = customXMLNodeDef.BaseName + End If + LogInfo("reading DBModifier Definition for " + nodeName) + Dim targetRange As Excel.Range = Nothing + ' for DBMappers and DBActions the data of the DBModification is stored in Ranges, so check for those and get the Range + If DBModiftype = "DBMapper" Or DBModiftype = "DBAction" Then + For Each rangename As Excel.Name In actWbNames + Dim rangenameName As String = Replace(rangename.Name, rangename.Parent.Name + "!", "") + If rangenameName = nodeName Then + If InStr(rangename.RefersTo, "#REF!") > 0 Then + UserMsg(DBModiftype + " definitions range " + rangename.Name + " contains #REF!", "DBModifier Definitions Error") + Exit For + End If + ' might fail if target name relates to an invalid (offset) formula ... + Try + targetRange = rangename.RefersToRange + Catch ex As Exception + If InStr(rangename.RefersTo, "OFFSET(") > 0 Then + UserMsg("Offset formula that '" + nodeName + "' refers to, did not return a valid range." + vbCrLf + "Please check the offset formula to return a valid range !", "DBModifier Definitions Error") + ExcelDnaUtil.Application.Dialogs(Excel.XlBuiltInDialog.xlDialogNameManager).Show() + GoTo EndOuterLoop + End If + End Try + Exit For + End If + Next + If targetRange Is Nothing Then + Dim answer As MsgBoxResult = QuestionMsg("Required target range named '" + nodeName + "' cannot be found for this " + DBModiftype + " definition." + vbCrLf + "Should the target range name and definition be removed (If you still need the " + DBModiftype + ", (re)create the target range with this name again)?", , "DBModifier Definitions Error", MsgBoxStyle.Critical) + If answer = MsgBoxResult.Ok Then + ' remove name, in case it still exists + Try : actWbNames.Item(nodeName).Delete() : Catch ex As Exception : End Try + ' remove node + If Not IsNothing(CustomXmlParts(1).SelectSingleNode("/ns0:root/ns0:" + DBModiftype + "[@Name='" + Replace(nodeName, DBModiftype, "") + "']")) Then + Try : CustomXmlParts(1).SelectSingleNode("/ns0:root/ns0:" + DBModiftype + "[@Name='" + Replace(nodeName, DBModiftype, "") + "']").Delete : Catch ex As Exception + UserMsg("Error removing node in DBModif definitions: " + ex.Message) + End Try + End If + End If + Continue For + End If + End If + ' finally create the DBModif Object ... + Dim newDBModif As DBModif = Nothing + ' fill parameters into CustomXMLPart: + If DBModiftype = "DBMapper" Then + newDBModif = New DBMapper(customXMLNodeDef, targetRange) + ElseIf DBModiftype = "DBAction" Then + newDBModif = New DBAction(customXMLNodeDef, targetRange) + ElseIf DBModiftype = "DBSeqnce" Then + newDBModif = New DBSeqnce(customXMLNodeDef) + Else + UserMsg("Not supported DBModifier type: " + DBModiftype, "DBModifier Definitions Error") + End If + ' ... and add it to the collection DBModifDefColl + Dim defColl As Dictionary(Of String, DBModif) ' definition lookup collection for DBModifiername -> object + If newDBModif IsNot Nothing Then + If Not DBModifDefColl.ContainsKey(DBModiftype) Then + ' add to new DBModiftype "menu" + defColl = New Dictionary(Of String, DBModif) From { + {nodeName, newDBModif} + } + DBModifDefColl.Add(DBModiftype, defColl) + Else + ' add definition to existing DBModiftype "menu" + defColl = DBModifDefColl(DBModiftype) + If defColl.ContainsKey(nodeName) Then + UserMsg("DBModifier " + nodeName + " added twice, this potentially indicates legacy definitions that were modified!" + vbCrLf + "To fix, convert all other definitions in the same way and then remove the legacy definitions by editing the raw DB Modif definitions.", IIf(onlyCheck, "check", "get") + " DBModif Definitions") + Else + defColl.Add(nodeName, newDBModif) + End If + End If + End If + End If +EndOuterLoop: + Next + ElseIf CustomXmlParts.Count > 1 Then + UserMsg("Multiple CustomXmlParts for DBModifDef existing!", IIf(onlyCheck, "check", "get") + " DBModif Definitions") + End If + theRibbon.Invalidate() + Catch ex As Exception + UserMsg("Exception in getting DB Modifier Definitions: " + ex.Message, "DBModifier Definitions Error") + End Try + End Sub + + ''' correct quotes in field name + ''' field name to correct + ''' quote corrected field name + Public Function CorrectQuotes(fieldname As String) As String + CorrectQuotes = Replace(fieldname, closingQuote, closingQuoteReplacement) + End Function + + ''' gets DB Modification Name (DBMapper or DBAction) from theRange + ''' + ''' the retrieved name as a string (not name object !) + Public Function getDBModifNameFromRange(theRange As Excel.Range) As String + Dim nm As Excel.Name + Dim rng, testRng As Excel.Range + Dim theWbNames As Excel.Names + + getDBModifNameFromRange = "" + If theRange Is Nothing Then Exit Function + Try : theWbNames = theRange.Parent.Parent.Names : Catch ex As Exception + UserMsg("Exception getting the range's parent workbook names: " + ex.Message + ", this might be either due to errors in the VBA-IDE (missing references) or due to opening this workbook from an MS-Office hyperlink, starting up Excel (timing issue). Switch to another workbook and back to fix.") + Exit Function + End Try + Try + ' try all names in workbook + For Each nm In theWbNames + rng = Nothing + ' test whether range referring to that name (if it is a real range)... + Try : rng = nm.RefersToRange : Catch ex As Exception : End Try + If rng IsNot Nothing Then + testRng = Nothing + ' ...intersects with the passed range + Try : testRng = ExcelDnaUtil.Application.Intersect(theRange, rng) : Catch ex As Exception : End Try + If testRng IsNot Nothing And (InStr(1, nm.Name, "DBMapper") >= 1 Or InStr(1, nm.Name, "DBAction") >= 1) Then + ' and pass back the name if it does and is a DBMapper or a DBAction + getDBModifNameFromRange = nm.Name + Exit Function + End If + End If + Next + Catch ex As Exception + UserMsg("Exception: " + ex.Message, "get DBModif Name From Range") + End Try + End Function + + ''' To check for errors in passed range obj, makes use of the fact that Range.Value never passes Integer Values back except for Errors + ''' Range.Value to be checked for errors + ''' https://xldennis.wordpress.com/2006/11/22/dealing-with-cverr-values-in-net-%E2%80%93-part-i-the-problem/ and https://xldennis.wordpress.com/2006/11/29/dealing-with-cverr-values-in-net-part-ii-solutions/ + ''' true if error + Public Function IsXLCVErr(rangeval As Object) As Boolean + Return TypeOf (rangeval) Is Int32 + End Function + + ''' to convert the error number to text + ''' integer error number + ''' text of error + Public Function CVErrText(whichError As Integer) As String + Select Case whichError + Case -2146826281 : Return "#Div0!" + Case -2146826245 : Return "#GettingData" + Case -2146826246 : Return "#N/A" + Case -2146826259 : Return "#Name" + Case -2146826288 : Return "#Null!" + Case -2146826252 : Return "#Num!" + Case -2146826265 : Return "#Ref!" + Case -2146826273 : Return "#Value!" + Case Else : Return "unknown error !!" + End Select + End Function + + ''' execute given DBModifier, used for VBA call by Application.Run + ''' Full name of DB Modifier, including type at beginning + ''' if set to true, DBAddin will avoid to issue messages and return messages in exceptions which are returned (headless) + ''' empty string on success, error message otherwise + + Public Function executeDBModif(DBModifName As String, Optional headLess As Boolean = False) As String + hadError = False : nonInteractive = headLess + nonInteractiveErrMsgs = "" ' reset non-interactive messages + Dim DBModiftype As String = Left(DBModifName, 8) + If DBModiftype = "DBSeqnce" Or DBModiftype = "DBMapper" Or DBModiftype = "DBAction" Then + If Not DBModifDefColl(DBModiftype).ContainsKey(DBModifName) Then + If DBModifDefColl(DBModiftype).Count = 0 Then + nonInteractive = False + Return "No DBModifier contained in Workbook at all!" + End If + Dim DBModifavailable As String = "" + For Each DBMtype As String In {"DBMapper", "DBAction", "DBSeqnce"} + For Each DBMkey As String In DBModifDefColl(DBMtype).Keys + DBModifavailable += "," + DBMkey + Next + Next + nonInteractive = False + Return "DB Modifier '" + DBModifName + "' not existing, available: " + DBModifavailable + End If + LogInfo("Doing DBModifier '" + DBModifName + "' ...") + Try + DBModifDefColl(DBModiftype).Item(DBModifName).doDBModif() + Catch ex As Exception + nonInteractive = False + Return "DB Modifier '" + DBModifName + "' doDBModif had following error(s): " + ex.Message + End Try + nonInteractive = False + If hadError Then Return nonInteractiveErrMsgs + ElseIf DBModiftype = "Refresh " Then + ' DBModifName for DBfunction refresh is "Refresh Sheet-name!Address" where Sheet-name!Address is a cell containing the DBfunction + Dim RangeParts() As String = Split(Mid(DBModifName, 9), "!") + If RangeParts.Length = 2 And RangeParts(0) <> "" And RangeParts(1) <> "" Then + Dim SheetName = Replace(RangeParts(0), "'", "") ' for sheet-names with blanks surrounding quotations are needed, remove them here + Dim Address = RangeParts(1) + Dim srcExtent As String = "" + Try : srcExtent = getUnderlyingDBNameFromRange(ExcelDnaUtil.Application.Worksheets(SheetName).Range(Address)) : Catch ex As Exception : End Try + If srcExtent = "" Then Return "No valid address found in " + DBModifName + " (Sheet-name: " + SheetName + ", Address: " + Address + ")" + Dim aDBModifier As New DBModifDummy() + aDBModifier.executeRefresh(srcExtent) + Else + Return "No Worksheet/Address could be parsed from " + DBModifName + End If + Else + nonInteractive = False + Return "No valid type (" + DBModiftype + ") in passed DB Modifier '" + DBModifName + "', DB Modifier name must start with 'DBSeqnce', 'DBMapper' Or 'DBAction' !" + End If + Return "" ' no error, no message + End Function + + ''' set given execution parameter, used for VBA call by Application.Run + ''' execution parameter, like "selectedEnvironment" (zero based here!) or "CnnTimeout" + ''' execution parameter value + + Public Sub setExecutionParam(Param As String, Value As Object) + Try + If Param = "headLess" Then + nonInteractive = Value + nonInteractiveErrMsgs = "" ' reset non-interactive messages + ElseIf Param = "selectedEnvironment" Then + SettingsTools.selectedEnvironment = Value + theRibbon.InvalidateControl("envDropDown") + ElseIf Param = "ConstConnString" Then + SettingsTools.ConstConnString = Value + ElseIf Param = "CnnTimeout" Then + SettingsTools.CnnTimeout = Value + ElseIf Param = "CmdTimeout" Then + SettingsTools.CmdTimeout = Value + ElseIf Param = "preventRefreshFlag" Then + Functions.preventRefreshFlag = Value + theRibbon.InvalidateControl("preventRefresh") + Else + UserMsg("parameter " + Param + " not supported by setExecutionParams") + Exit Sub + End If + Catch ex As Exception + UserMsg("setting parameter " + Param + " with value " + CStr(Value) + " resulted in error " + ex.Message) + End Try + End Sub + + ''' get given execution parameter or setting parameter found by fetchSetting, used for VBA call by Application.Run + ''' execution parameter, like "selectedEnvironment" (zero based here!), "env()" or "CnnTimeout" + ''' execution or setting parameter value + + Public Function getExecutionParam(Param As String) As Object + If Param = "selectedEnvironment" Then + Return SettingsTools.selectedEnvironment + ElseIf Param = "env()" Then + Return SettingsTools.env() + ElseIf Param = "ConstConnString" Then + Return SettingsTools.ConstConnString + ElseIf Param = "CnnTimeout" Then + Return SettingsTools.CnnTimeout + ElseIf Param = "CmdTimeout" Then + Return SettingsTools.CmdTimeout + ElseIf Param = "preventRefreshFlag" Then + Return Functions.preventRefreshFlag + Else + Return fetchSetting(Param, "parameter " + Param + " neither supported by getExecutionParam nor found with fetchSetting(Param)") + End If + End Function + + ''' marks a row in a DBMapper for deletion, used as a ExcelCommand to have a keyboard shortcut + + Public Sub deleteRow() + Dim targetName As String = getDBModifNameFromRange(ExcelDnaUtil.Application.Selection) + If Left(targetName, 8) = "DBMapper" Then DirectCast(DBModifDefColl("DBMapper").Item(targetName), DBMapper).insertCUDMarks(ExcelDnaUtil.Application.Selection, deleteFlag:=True) + End Sub + + ''' inserts a row in a DBMapper, used as a ExcelCommand to have a keyboard shortcut + + Public Sub insertRow() + Dim targetName As String = getDBModifNameFromRange(ExcelDnaUtil.Application.Selection) + If Left(targetName, 8) = "DBMapper" Then + ' get the target range for the DBMapper to get the ListObject + Dim insertTarget As Excel.Range = DirectCast(DBModifDefColl("DBMapper").Item(targetName), DBMapper).getTargetRange + ' calculate insert row from selection and top row of insert target + Dim insertRow As Integer = ExcelDnaUtil.Application.Selection.Row - insertTarget.Row + ' just add a row to the ListObject, the rest (shifting down existing CUD Marks and adding "i") is being taken care of the Application_SheetChange event procedure and the insertCUDMarks method + insertTarget.ListObject.ListRows.Add(insertRow) + End If + End Sub +End Module + + +''' Dummy DBModif Class for executeRefresh during externally callable executeDBModif procedure +Public Class DBModifDummy : Inherits DBModif + Public Sub New() + MyBase.New(Nothing) + End Sub + + Public Sub executeRefresh(srcExtent) + doDBRefresh(srcExtent:=srcExtent) + End Sub +End Class \ No newline at end of file diff --git a/source/DBaddin.vbproj b/source/DBaddin.vbproj index 136396ed..7c8d90bc 100644 --- a/source/DBaddin.vbproj +++ b/source/DBaddin.vbproj @@ -124,6 +124,7 @@ Form + DBSheetCreateForm.vb diff --git a/source/Functions.vb b/source/Functions.vb index e390a900..7f9203c8 100644 --- a/source/Functions.vb +++ b/source/Functions.vb @@ -13,6 +13,7 @@ Public Class ContainedStatusMsg Public formulaRange As Excel.Range End Class + ''' Contains the public callable DB functions and helper functions Public Module Functions ' Global objects/variables for DBFuncs @@ -437,7 +438,7 @@ Public Module Functions Dim connType As String = "" Dim bgQuery As Boolean - DBModifs.preventChangeWhileFetching = True + DBModifHelper.preventChangeWhileFetching = True Try Dim thePivotCache As Excel.PivotCache = Nothing Dim theQueryTable As Excel.QueryTable = Nothing @@ -537,14 +538,14 @@ Public Module Functions errMsg = ex.Message + " in query: " + Query GoTo err End Try - DBModifs.preventChangeWhileFetching = False + DBModifHelper.preventChangeWhileFetching = False setCalcModeBack(calcMode) Exit Sub err: setCalcModeBack(calcMode) LogWarn(errMsg + " caller: " + callID) If StatusCollection.ContainsKey(callID) Then StatusCollection(callID).statusMsg = errMsg - DBModifs.preventChangeWhileFetching = False + DBModifHelper.preventChangeWhileFetching = False ' trigger recalculation to return error message to calling function Try : caller.Formula += " " : Catch ex As Exception : End Try End Sub @@ -659,7 +660,7 @@ err: ''' for logging purpose Private Sub finishAction(calcMode As Excel.XlCalculation, callID As String, Optional additionalLogInfo As String = "") LogInfo("callID: " + callID + If(additionalLogInfo <> "", ", additionalInfo: " + additionalLogInfo, "")) - DBModifs.preventChangeWhileFetching = False + DBModifHelper.preventChangeWhileFetching = False ' To return cursor to normal Try : ExcelDnaUtil.Application.Cursor = Excel.XlMousePointer.xlDefault : Catch ex As Exception : End Try Try : ExcelDnaUtil.Application.StatusBar = False : Catch ex As Exception : End Try @@ -857,7 +858,7 @@ err: If targetSH Is formulaSH And formulaRange.Column = startCol + oldCols Then additionalFormulaColumns = formulaRange.Columns.Count End If - DBModifs.preventChangeWhileFetching = True + DBModifHelper.preventChangeWhileFetching = True ' used for resizing potential DBMapper under DBListfetch TargetRange Dim oldTotalTargetRange As Excel.Range = Nothing Try : oldTotalTargetRange = targetSH.Range(targetSH.Cells(startRow, startCol), targetSH.Cells(startRow + oldRows - 1, startCol + oldCols + additionalFormulaColumns - 1)) : Catch ex As Exception : End Try @@ -1316,7 +1317,7 @@ err: LogWarn(errMsg + ", caller: " + callID) GoTo err End Try - DBModifs.preventChangeWhileFetching = True + DBModifHelper.preventChangeWhileFetching = True If Not recordsetHasRows Then StatusCollection(callID).statusMsg = "Warning: No Data returned in query: " + Query Dim totalFieldsDisplayed As Long = 0 ' needed to calculate displayedRows diff --git a/source/Globals.vb b/source/Globals.vb index 02343228..f1079441 100644 --- a/source/Globals.vb +++ b/source/Globals.vb @@ -337,7 +337,7 @@ Last: LogWarn("ExcelDnaUtil.Application.Calculation = Error, " + Wb.Path + "\" + Wb.Name + " (hidden workbooks produce calculation errors...)") Exit Sub End If - DBModifs.preventChangeWhileFetching = True + DBModifHelper.preventChangeWhileFetching = True Dim calcMode As Long = ExcelDnaUtil.Application.Calculation Dim calcModeSet As Boolean = False Try @@ -375,13 +375,13 @@ Last: ' check for formula and store it Try : colFormula = listcol.DataBodyRange.Cells(1, 1).Formula : Catch ex As Exception : End Try If Left(colFormula, 1) = "=" Then - DBModifs.preventChangeWhileFetching = True + DBModifHelper.preventChangeWhileFetching = True ' delete whole column listcol.DataBodyRange.Clear() ' re-insert the formula, this repairs the auto-filling functionality listcol.DataBodyRange.Formula = colFormula DBTargetListObject.QueryTable.PreserveColumnInfo = True ' if there is a lookup formula, always set this as it is required to fill it in automatically - DBModifs.preventChangeWhileFetching = False + DBModifHelper.preventChangeWhileFetching = False End If Next End If @@ -405,7 +405,7 @@ Last: End Try ' after all db function cells have been "dirtied" set calculation mode to automatic again (if it was automatic) If calcModeSet Then ExcelDnaUtil.Application.Calculation = calcMode - DBModifs.preventChangeWhileFetching = False + DBModifHelper.preventChangeWhileFetching = False End Sub ''' "OnTime" event function to "escape" current (main) thread: event procedure to re-fetch DB functions results after triggering a recalculation inside Application.WorkbookBeforeSave @@ -470,13 +470,19 @@ Last: Dim altConnString = fetchSetting("AltConnString" + env(), "") ' for standard connection strings only OLEDB drivers seem to work with pivot tables... If altConnString = "" Then altConnString = "OLEDB;" + ConstConnString - Dim ExcelVersionForPivot As Excel.XlPivotTableVersionList = fetchSettingInt("ExcelVersionForPivot", "8") - Try - ' don't use TargetCell.Parent.Parent.PivotCaches().Add(Excel.XlPivotTableSourceType.xlExternal) as we can't set the Version there... - pivotcache = ExcelDnaUtil.Application.ActiveWorkbook.PivotCaches.Create(SourceType:=Excel.XlPivotTableSourceType.xlExternal, Version:=ExcelVersionForPivot) - Catch ex As Exception - UserMsg("Exception creating pivot cache: " + ex.Message + ", if the reason was 'wrong parameter', change setting ExcelVersionForPivot to a lower/correct value (see help)", "Create Pivot Table") - End Try + Dim ExcelVersionForPivot As Integer = -1 : Dim versionTooHigh As Boolean = False + Do + ExcelVersionForPivot += 1 + Try + ' don't use TargetCell.Parent.Parent.PivotCaches().Add(Excel.XlPivotTableSourceType.xlExternal) as we can't set the Version there... + Dim dummy As Excel.PivotCache = ExcelDnaUtil.Application.ActiveWorkbook.PivotCaches.Create(SourceType:=Excel.XlPivotTableSourceType.xlExternal, Version:=ExcelVersionForPivot) + Catch ex As Exception + versionTooHigh = True + End Try + Loop Until versionTooHigh + ExcelVersionForPivot -= 1 + pivotcache = ExcelDnaUtil.Application.ActiveWorkbook.PivotCaches.Create(SourceType:=Excel.XlPivotTableSourceType.xlExternal, Version:=ExcelVersionForPivot) + 'LogInfo("created pivot cache with version: " + CStr(ExcelVersionForPivot)) Try pivotcache.Connection = altConnString pivotcache.MaintainConnection = False @@ -702,4 +708,16 @@ Last: End If End Function + ''' check for multiple excel instances + Public Sub checkHiddenExcelInstance() + Try + If Diagnostics.Process.GetProcessesByName("Excel").Length > 1 Then + For Each procinstance As Diagnostics.Process In Diagnostics.Process.GetProcessesByName("Excel") + If procinstance.MainWindowTitle = "" Then + UserMsg("Another hidden excel instance detected (PID: " + procinstance.Id + "), this may cause problems with querying DB Data") + End If + Next + End If + Catch ex As Exception : End Try + End Sub End Module \ No newline at end of file diff --git a/source/MenuHandler.vb b/source/MenuHandler.vb index 4f5ddc39..d33e3c51 100644 --- a/source/MenuHandler.vb +++ b/source/MenuHandler.vb @@ -1,9 +1,10 @@ Imports ExcelDna.Integration -Imports System.Runtime.InteropServices Imports Microsoft.Office.Interop Imports System.Configuration Imports System.Collections.Specialized Imports System.Collections.Generic +Imports System.Runtime.InteropServices + ''' handles all Menu related aspects (context menu for building/refreshing, "DBAddin"/"Load Config" tree menu for retrieving stored configuration files, etc.) @@ -741,7 +742,7 @@ Public Class MenuHandler UserMsg("Exception when trying to get the active workbook for DB Modifier activation: " + ex.Message + ", this might be due to errors in the VBA Macros (missing references)") End Try ' reset non-interactive messages (used for VBA invocations) and hadError for interactive invocations - nonInteractiveErrMsgs = "" : DBModifs.hadError = False + nonInteractiveErrMsgs = "" : DBModifHelper.hadError = False Dim nodeName As String = Right(control.Id, Len(control.Id) - 1) If Not ExcelDnaUtil.Application.CommandBars.GetEnabledMso("FileNewDefault") Then UserMsg("Cannot execute DB Modifier while cell editing active !", "DB Modifier execution", MsgBoxStyle.Exclamation) diff --git a/source/My Project/AssemblyInfo.vb b/source/My Project/AssemblyInfo.vb index 1bbde39c..37455f7c 100644 --- a/source/My Project/AssemblyInfo.vb +++ b/source/My Project/AssemblyInfo.vb @@ -31,6 +31,6 @@ Imports System.Runtime.InteropServices ' You can specify all the values or you can default the Build and Revision Numbers ' by using the '*' as shown below: - - + + diff --git a/source/Resources/Settings.txt b/source/Resources/Settings.txt index ab9cb076..196f208b 100644 --- a/source/Resources/Settings.txt +++ b/source/Resources/Settings.txt @@ -1,6 +1,6 @@ -AdHocSQLTransferType AdHocSQLcmdDB + AdHocSQLStringsIndex AdHocSQLcmdEnv + AdHocSQLStringsIndex +AdHocSQLTransferType AltConnString + env AvoidUpdateLinks_Refresh AvoidUpdateListObjects_Refresh @@ -17,10 +17,10 @@ ConfigSelect ConfigSelect + ConfigSelectPreference ConfigSelectPreference ConfigStoreFolder + env +connIDPrefixDBtype ConnStringReplace + env ConnStringSearch + env ConstConnString + env -connIDPrefixDBtype dbGetAll + env dbGetAllFieldName + env DBidentifierCCS + env @@ -36,28 +36,25 @@ DefaultEnvironment disableSettingsDisplay DMLStatementsAllowed DontChangeEnvironment -ExcelVersionForPivot -LocalHelp lastDBsheetAssignPath lastDBsheetCreatePath legacyFunctionMsg +LocalHelp localUpdateFolder localUpdateMessage -maxCellCount -maxCellCountIgnore maxNumberMassChange maxRowCountCUD maxTriesForRevisionFind -ownerQualifier + env openingQuote + env +ownerQualifier + env pivotTableCmdTextToSet + env repairLegacyFunctionsAutoOpen -shortCutRefreshData -shortCutJumpButton shortCutDeleteRow shortCutInsertRow +shortCutJumpButton +shortCutRefreshData specialConfigStoreFolders specialNonNullableChar + env tblPlaceHolder + env updatesDownloadFolder -updatesMajorVersion +updatesMajorVersion \ No newline at end of file diff --git a/source/Resources/SettingsDBModif.txt b/source/Resources/SettingsDBModif.txt index 222e1c67..5b517529 100644 --- a/source/Resources/SettingsDBModif.txt +++ b/source/Resources/SettingsDBModif.txt @@ -21,18 +21,4 @@ paramRangesStr preventColResize primKeysStr seqStep -tableName - - - - - - - - - - - - - - +tableName \ No newline at end of file diff --git a/source/SettingsTools.vb b/source/SettingsTools.vb index 1725d97b..a6c69123 100644 --- a/source/SettingsTools.vb +++ b/source/SettingsTools.vb @@ -17,7 +17,7 @@ Public Module SettingsTools Public CmdTimeout As Integer ''' default formatting style used in DBDate Public DefaultDBDateFormatting As Integer - ''' The path where the User specific settings (overrides of standard/global settings) can be found (hardcoded to path of xll) + ''' The path where the User specific settings (overrides of standard/global settings) can be found (hard-coded to path of xll) Private UserSettingsPath As String ''' exception proof fetching of integer settings @@ -190,7 +190,7 @@ Public Module SettingsTools LogWarn("no active workbook available !") Exit Sub End If - DBModifs.preventChangeWhileFetching = True ' WorksheetFunction.CountIf triggers Change event with target in argument 1, so make sure this doesn't trigger anything inside DBAddin) + DBModifHelper.preventChangeWhileFetching = True ' WorksheetFunction.CountIf triggers Change event with target in argument 1, so make sure this doesn't trigger anything inside DBAddin) Try ' count nonempty cells in workbook for time estimate... Dim cellcount As Long = 0 @@ -236,7 +236,7 @@ Public Module SettingsTools Catch ex As Exception UserMsg("Exception occurred: " + ex.Message, "Legacy DBAddin functions") End Try - DBModifs.preventChangeWhileFetching = False + DBModifHelper.preventChangeWhileFetching = False End Sub ''' maintenance procedure to check/purge names used for db-functions from workbook, or unhide DB names @@ -252,7 +252,7 @@ Public Module SettingsTools UserMsg("Exception when trying to get the active workbook names for purging names: " + ex.Message + ", this might be either due to errors in the VBA-IDE (missing references) or due to opening this workbook from an MS-Office hyperlink, starting up Excel (timing issue).") Exit Sub End Try - Dim NamesWithErrors As List(Of Excel.Name) = New List(Of Excel.Name) + Dim NamesWithErrors As New List(Of Excel.Name) If IsNothing(actWbNames) Then Exit Sub ' with Ctrl unhide all DB names and show Name Manager... If My.Computer.Keyboard.CtrlKeyDown And Not My.Computer.Keyboard.ShiftKeyDown Then @@ -341,7 +341,7 @@ Public Module SettingsTools If InStr(DBname.RefersTo, "OFFSET(") > 0 Then collectedErrors += "Offset formula that '" + DBname.Name + "' refers to, did not return a valid range" + vbCrLf ElseIf InStr(DBname.RefersTo, "#REF!") > 0 Then - ' RefersToRange thows exception, but do nothing as already collected above ... + ' RefersToRange throws exception, but do nothing as already collected above ... Else collectedErrors += DBname.Name + "' checkRange = DBname.RefersToRange resulted in unexpected Exception " + ex.Message + vbCrLf End If @@ -390,7 +390,7 @@ Public Module SettingsTools Sub fixOrphanedDBFunctions(actWB As Excel.Workbook) Dim xlcalcmode As Long = ExcelDnaUtil.Application.Calculation - DBModifs.preventChangeWhileFetching = True ' WorksheetFunction.CountIf triggers Change event with target in argument 1, so make sure this doesn't trigger anything inside DBAddin) + DBModifHelper.preventChangeWhileFetching = True ' WorksheetFunction.CountIf triggers Change event with target in argument 1, so make sure this doesn't trigger anything inside DBAddin) Try ' count nonempty cells in workbook for time estimate... Dim cellcount As Long = 0 @@ -433,7 +433,7 @@ Public Module SettingsTools Catch ex As Exception UserMsg("Exception occurred: " + ex.Message, "Orphaned DBAddin functions fix") End Try - DBModifs.preventChangeWhileFetching = False + DBModifHelper.preventChangeWhileFetching = False End Sub End Module \ No newline at end of file diff --git a/source/collectSettings.vbs b/source/collectSettings.vbs index 85929877..7c4096e5 100644 --- a/source/collectSettings.vbs +++ b/source/collectSettings.vbs @@ -4,38 +4,40 @@ Set fso = CreateObject("Scripting.FileSystemObject") Dim obj_datadict Set obj_datadict = CreateObject("Scripting.Dictionary") For Each inFile In fso.GetFolder(".").Files - If UCase(fso.GetExtensionName(inFile.Name)) = "VB" Then - Set ifile = fso.OpenTextFile(inFile.path, 1) - theText = ifile.readAll() - Set regEx = New RegExp - regEx.Pattern = "fetchSetting\(""(.*?)," - regEx.Global = True - regEx.IgnoreCase = True - Set myMatches = regEx.Execute(theText) - For Each myMatch in myMatches - For Each mySubMatch in myMatch.SubMatches - setting = Replace(mySubMatch, """", "") - setting = Replace(setting, "Globals.", "") - setting = Replace(setting, "()", "") - setting = Replace(setting, ".ToString", "") - setting = Replace(setting, "DBenv", "env") - setting = Replace(setting, "myDBConnHelper.", "") - setting = Replace(setting, "ConfigName + i", "ConfigName + env") - if not obj_datadict.exists(setting) then - if setting = "ConfigSelect + fetchSetting(ConfigSelectPreference" then - obj_datadict.add "ConfigSelect + ConfigSelectPreference", "ConfigSelect + ConfigSelectPreference" - setting = Replace(setting, "ConfigSelect + fetchSetting(", "") + If UCase(fso.GetExtensionName(inFile.Name)) = "VB" Then + wscript.Echo "... searching for settings in " + inFile.Name + Set ifile = fso.OpenTextFile(inFile.path, 1) + theText = ifile.readAll() + Set regEx = New RegExp + regEx.Pattern = "fetchSetting.*?\(""(.*?)," + regEx.Global = True + regEx.IgnoreCase = True + Set myMatches = regEx.Execute(theText) + For Each myMatch in myMatches + For Each mySubMatch in myMatch.SubMatches + wscript.Echo "found " + mySubMatch + setting = Replace(mySubMatch, """", "") + setting = Replace(setting, "Globals.", "") + setting = Replace(setting, "()", "") + setting = Replace(setting, ".ToString", "") + setting = Replace(setting, "DBenv", "env") + setting = Replace(setting, "myDBConnHelper.", "") + setting = Replace(setting, "ConfigName + i", "ConfigName + env") + if not obj_datadict.exists(setting) then + if setting = "ConfigSelect + fetchSetting(ConfigSelectPreference" then + obj_datadict.add "ConfigSelect + ConfigSelectPreference", "ConfigSelect + ConfigSelectPreference" + setting = Replace(setting, "ConfigSelect + fetchSetting(", "") + end if + obj_datadict.add setting, setting end if - obj_datadict.add setting, setting - end if - next - Next - ifile.Close - Set ifile = Nothing - End if + next + Next + ifile.Close + Set ifile = Nothing + End if Next sortedArray = SortDictToArray(obj_datadict) -Set ofile = fso.CreateTextFile("Settings.txt", True) +Set ofile = fso.CreateTextFile("Resources\Settings.txt", True) For i=0 to Ubound(sortedArray)-1 ofile.writeline(sortedArray(i)) Next @@ -43,16 +45,17 @@ ofile.Close Set ofile = Nothing Set fso = Nothing +' case insensitive sorting of passed setting->setting dictionary, returns array (dictionary not needed anymore) Function SortDictToArray(ByVal dict) - arrKeys = dict.keys - For i=0 To UBound(arrKeys)-1 - For j=i+1 To UBound(arrKeys) - If(arrKeys(i) >= arrKeys(j)) Then - temp = arrKeys(i) - arrKeys(i) = arrKeys(j) - arrKeys(j) = temp - End If - Next - Next - SortDictToArray = arrKeys + arrKeys = dict.keys + For i=0 To UBound(arrKeys)-1 + For j=i+1 To UBound(arrKeys) + If(lcase(arrKeys(i)) >= lcase(arrKeys(j))) Then + temp = arrKeys(i) + arrKeys(i) = arrKeys(j) + arrKeys(j) = temp + End If + Next + Next + SortDictToArray = arrKeys End Function