MS Access Queries to SQL Server Converter
5.00/5 (3 votes)
Tool to migrate MS Access Queries to SQL Server
Introduction
To use this application, select Access file, Select a view and click SQL. Click Save All to save all Access queries as SQL files to a folder.
The result SQL will be created using CTE (Common Table Expressions) in case the Access query is using other Access queries. For example:
With a as (
select col1 + col2 as col3
From table1
)
Select col3
From a
In case Access query is using Access table, the table will be scripted as a CTE with UNION ALL clause. For example:
With a as (
select 1 as col1, 2 as col2 UNION ALL
select 1 as col1, 2 as col2
)
Select col1, col2
From a
Using the Code
The tool uses PoorMansTSqlFormatter to make SQL look prettier. To use it, make sure that the “Format SQL” option is checked. I used ILMerge (included in the download) to add PoorMansTSqlFormatterLib35.dll to the AccessToSql2.exe so that I can use it without an installation package.
C:\ILMerge.exe AccessToSql.exe PoorMansTSqlFormatterLib35.dll /out:AccessToSql2.exe
Here is the VB.NET code:
Imports System.Text.RegularExpressions
Public Class Form1
Dim dicViews As New Hashtable
Dim dicTables As New Hashtable
Private Sub btnOpenFile_Click(sender As Object, e As EventArgs) Handles btnOpenFile.Click
If txtFilePath.Text = "" Then
OpenFileDialog1.InitialDirectory = ""
Else
Dim oFileInfo As New IO.FileInfo(txtFilePath.Text)
OpenFileDialog1.InitialDirectory = oFileInfo.DirectoryName
OpenFileDialog1.FileName = oFileInfo.Name
End If
OpenFileDialog1.Filter = "Access Files|*.mdb;*.accdb"
OpenFileDialog1.ShowDialog()
txtFilePath.Text = OpenFileDialog1.FileName
LoadViews()
End Sub
Private Function GetConnection() As Data.OleDb.OleDbConnection
Dim cn As New Data.OleDb.OleDbConnection
Dim sError As String = ""
If System.IO.Path.GetExtension(txtFilePath.Text).ToLower() = _
".mdb" And Environment.Is64BitProcess = False Then
Try
cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;_
Data Source=" & txtFilePath.Text & ";"
cn.Open()
Return cn
Catch ex As Exception
sError = ex.Message
End Try
End If
Try
cn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
txtFilePath.Text & ";"
cn.Open()
Return cn
Catch ex As Exception
'The 'Microsoft.ACE.OLEDB.12.0' provider is not registered on the local machine.
If ex.Message.IndexOf("Microsoft.ACE.OLEDB") <> -1 Then
If MsgBox("Error: " & ex.Message & " _
Install Microsoft Access Database Engine 2016 Redistributable?", _
MsgBoxStyle.YesNo) = vbYes Then
Process.Start("https://www.microsoft.com/en-us/download/_
details.aspx?id=54920&WT.mc_id=rss_alldownloads_all")
End If
Me.Close()
Else
MsgBox("Error: " & ex.Message)
End If
End Try
Return Nothing
End Function
Private cnOleDb As Data.OleDb.OleDbConnection = Nothing
Private Sub LoadViews()
If IO.File.Exists(txtFilePath.Text) = False Then
Exit Sub
End If
dicViews = New Hashtable
cnOleDb = GetConnection()
If cnOleDb Is Nothing Then
Exit Sub
End If
Dim oStopwatch As Stopwatch = Stopwatch.StartNew()
Dim oTable As DataTable = cnOleDb.GetOleDbSchemaTable_
(Data.OleDb.OleDbSchemaGuid.Views, Nothing)
oStopwatch.Stop()
If oStopwatch.Elapsed.TotalSeconds() > 10 Then
MsgBox("It took " & oStopwatch.Elapsed.TotalSeconds() _
& " seconds to cnOleDb.GetOleDbSchemaTable_
(Data.OleDb.OleDbSchemaGuid.Views, Nothing)")
End If
For i As Long = 0 To oTable.Rows.Count - 1
Dim sName As String = oTable.Rows(i)("TABLE_NAME") & ""
Dim sSql As String = oTable.Rows(i)("VIEW_DEFINITION") & ""
dicViews(sName) = sSql
Next
oStopwatch.Restart()
oTable = cnOleDb.GetOleDbSchemaTable(Data.OleDb.OleDbSchemaGuid.Procedures, Nothing)
If oStopwatch.Elapsed.TotalSeconds() > 10 Then
MsgBox("It took " & oStopwatch.Elapsed.TotalSeconds() _
& " seconds to cnOleDb.GetOleDbSchemaTable_
(Data.OleDb.OleDbSchemaGuid.Procedures, Nothing)")
End If
For i As Long = 0 To oTable.Rows.Count - 1
Dim sName As String = oTable.Rows(i)("PROCEDURE_NAME") & ""
Dim sSql As String = oTable.Rows(i)("PROCEDURE_DEFINITION") & ""
If sName.Substring(0, 4) <> "~sq_" _
AndAlso dicViews.ContainsKey(sName) = False Then
dicViews(sName) = sSql
End If
Next
Dim oList As New SortedList
For Each oEntry As DictionaryEntry In dicViews
oList.Add(oEntry.Key, oEntry.Value)
Next
cmViews.Items.Clear()
For Each oEntry As DictionaryEntry In oList
cmViews.Items.Add(oEntry.Key)
Next
dicTables = New Hashtable
oTable = cnOleDb.GetOleDbSchemaTable(Data.OleDb.OleDbSchemaGuid.Tables, Nothing)
For i As Long = 0 To oTable.Rows.Count - 1
Dim sType As String = oTable.Rows(i)("TABLE_TYPE") & ""
Dim sName As String = oTable.Rows(i)("TABLE_NAME") & ""
If sType = "TABLE" Then
dicTables(sName) = ""
End If
Next
End Sub
Private Sub btnGo_Click(sender As Object, e As EventArgs) Handles btnGo.Click
Dim sViewName As String = cmViews.Text
If sViewName = "" Then
Dim oAppSetting As New AppSetting
cmViews.SelectedItem = oAppSetting.GetValue("View")
sViewName = cmViews.Text
End If
If sViewName = "" Then
MsgBox("Please select a view")
Else
txtSQL.Text = ShowView(sViewName, True)
End If
End Sub
Private Function PadTempTableNames(ByVal sSql As String, _
dicDepTables As Hashtable, dicDepViews As Hashtable) As String
If chkCTE.Checked Then
Return sSql
End If
For Each oEntry As Collections.DictionaryEntry In dicDepTables
Dim sTable As String = oEntry.Key
sSql = ReplaceTempTable(sSql, sTable)
Next
For Each oEntry As Collections.DictionaryEntry In dicDepViews
Dim sTable As String = oEntry.Key
sSql = ReplaceTempTable(sSql, sTable)
Next
Return sSql
End Function
Private Function PadTempTableNames(ByVal sSql As String, _
dicDepTables As System.Windows.Forms.ListBox.ObjectCollection, _
dicDepViews As System.Windows.Forms.ListBox.ObjectCollection) As String
If chkCTE.Checked Then
Return sSql
End If
For Each sDisplayTable As String In dicDepTables
Dim sTable As String = ""
If sDisplayTable.IndexOf(" - [") <> -1 Then
sTable = System.Text.RegularExpressions.Regex.Split(sDisplayTable, " - [")(0)
Else
sTable = sDisplayTable
End If
sSql = ReplaceTempTable(sSql, sTable)
Next
For Each sTable As String In dicDepViews
sSql = ReplaceTempTable(sSql, sTable)
Next
Return sSql
End Function
Private Function ReplaceTempTable(ByVal sSql As String, ByVal sTable As String) As String
Return Replace(sSql, "[" & sTable & "]", "[#" & sTable & "]")
End Function
Private Function GetTableCount(ByVal sTable As String) As Integer
If cnOleDb Is Nothing Then
Return 0
End If
Try
Dim iRet As Integer = 0
Dim sSql As String = "select count(*) from [" & sTable & "]"
Dim cmd As New OleDb.OleDbCommand(sSql, cnOleDb)
Dim dr As OleDb.OleDbDataReader = cmd.ExecuteReader()
If dr.Read Then
iRet = dr.GetValue(0)
End If
dr.Close()
Return iRet
Catch ex As Exception
End Try
Return -1
End Function
Private Function ShowView_
(ByVal sViewName As String, ByVal bUpdateList As Boolean) As String
If dicViews.ContainsKey(sViewName) = False Then
Return ""
End If
Dim dicDepTables As New Hashtable
Dim dicDepViews As New Hashtable
Dim sVewSql As String = dicViews(sViewName)
GetDepViews(sVewSql, dicDepTables, dicDepViews, 1)
Dim bShowWith As Boolean = False
Dim sSql As String = ""
If bUpdateList Then
lbDepTables.Items.Clear()
End If
For Each oEntry As Collections.DictionaryEntry In dicDepTables
Dim sTable As String = oEntry.Key
If bUpdateList Then
Dim iRecordCount As Integer = GetTableCount(sTable)
Dim sDisplayTable As String = _
sTable & " - [" & Format(iRecordCount, "#,#") & "]"
If txtRowLimit.Text <> "" AndAlso IsNumeric(txtRowLimit.Text) Then
Dim iMaxRecCount As Integer = txtRowLimit.Text
If iMaxRecCount < iRecordCount Then
sDisplayTable = sTable & " - _
[" & Format(iRecordCount, "#,#") & " !!!]"
End If
End If
lbDepTables.Items.Add(sDisplayTable)
End If
Dim sTableSql As String = GetTableSql(sTable)
If sTableSql <> "" Then
If chkCTE.Checked Then
If sSql <> "" Then
sSql += ", "
End If
sSql += " [" & sTable & "] AS (" & vbCrLf & sTableSql & ")" & vbCrLf
bShowWith = True
Else
sSql += "IF OBJECT_ID('tempdb..[#" & sTable & "]') _
is not null drop table [#" & sTable & "]" & vbCrLf
sSql += "select * into [#" & sTable & "] _
from (" & vbCrLf & sTableSql & vbCrLf & ") xx" & vbCrLf & vbCrLf
End If
End If
Next
If bUpdateList Then
lbDepViews.Items.Clear()
End If
Dim oSortedViews As ArrayList = GetSortedViews(dicDepViews)
For Each sDepViewName In oSortedViews
If bUpdateList Then
lbDepViews.Items.Add(sDepViewName)
End If
Dim sDepSql As String = dicViews(sDepViewName)
sDepSql = PadSql(sDepSql)
sDepSql = AddTabs(sDepSql)
If chkCTE.Checked Then
If sSql <> "" Then
sSql += ", "
End If
sSql += " [" & sDepViewName & "] AS (" & vbCrLf & sDepSql & ")" & vbCrLf
bShowWith = True
Else
sSql += "IF OBJECT_ID('tempdb..[#" & sDepViewName & "]') _
is not null drop table [#" & sDepViewName & "]" & vbCrLf
sSql += "select * into [#" & sDepViewName & "] _
from (" & vbCrLf & _
PadTempTableNames(sDepSql, dicDepTables, dicDepViews) _
& vbCrLf & ") xx" & vbCrLf
End If
Next
If chkCTE.Checked = False Then
Return sSql & PadTempTableNames(PadSql(sVewSql), dicDepTables, dicDepViews)
ElseIf bShowWith Then
Return "WITH " & sSql & PadSql(sVewSql)
Else
Return PadSql(sVewSql)
End If
End Function
Private Function ShowView2() As String
Dim sViewName As String = cmViews.Text
If dicViews.ContainsKey(sViewName) = False Then
Return ""
End If
Dim sVewSql As String = dicViews(sViewName)
Dim bShowWith As Boolean = False
Dim sSql As String = ""
For Each sDisplayTable As String In lbDepTables.Items
Dim sTable As String = ""
If sDisplayTable.IndexOf(" - [") <> -1 Then
sTable = System.Text.RegularExpressions.Regex.Split(sDisplayTable, " - [")(0)
Else
sTable = sDisplayTable
End If
Dim sTableSql As String = GetTableSql(sTable)
If sTableSql <> "" Then
If chkCTE.Checked Then
If sSql <> "" Then
sSql += ", "
End If
sSql += " [" & sTable & "] AS (" & vbCrLf & sTableSql & ")" & vbCrLf
bShowWith = True
Else
sSql += "IF OBJECT_ID('tempdb..[#" & sTable & "]') _
is not null drop table [#" & sTable & "]" & vbCrLf
sSql += "select * into [#" & sTable & "] _
from (" & vbCrLf & sTableSql & vbCrLf & ") xx" & vbCrLf
End If
End If
Next
For Each sDepViewName In lbDepViews.Items
Dim sDepSql As String = dicViews(sDepViewName)
sDepSql = PadSql(sDepSql)
sDepSql = AddTabs(sDepSql)
If chkCTE.Checked Then
If sSql <> "" Then
sSql += ", "
End If
sSql += " [" & sDepViewName & "] AS (" & vbCrLf & sDepSql & ")" & vbCrLf
bShowWith = True
Else
sSql += "IF OBJECT_ID('tempdb..[#" & sDepViewName & "]') _
is not null drop table [#" & sDepViewName & "]" & vbCrLf
sSql += "select * into [#" & sDepViewName & "] _
from (" & vbCrLf & PadTempTableNames_
(sDepSql, lbDepTables.Items, lbDepViews.Items) & vbCrLf & ") xx" & vbCrLf
End If
Next
If chkCTE.Checked = False Then
Return sSql & _
PadTempTableNames(PadSql(sVewSql), lbDepTables.Items, lbDepViews.Items)
ElseIf bShowWith Then
Return "WITH " & sSql & PadSql(sVewSql)
Else
Return sSql & PadSql(sVewSql)
End If
End Function
Private Function GetSortedViews(ByVal oHash As Hashtable) As ArrayList
'Sort list based on recursion level - views at the bottom are lsted first
Dim oTable As New Data.DataTable
oTable.Columns.Add(New Data.DataColumn("key"))
oTable.Columns.Add(New Data.DataColumn("level", System.Type.GetType("System.Int32")))
Dim oDepList As New Hashtable
For Each oEntry As Collections.DictionaryEntry In oHash
Dim sView As String = oEntry.Key
Dim oDataRow As DataRow = oTable.NewRow()
oDataRow("key") = sView
oDataRow("level") = oEntry.Value
oTable.Rows.Add(oDataRow)
Dim dicSubDepViews As New Hashtable
Dim sDepVewSql As String = dicViews(sView)
GetDepViews(sDepVewSql, Nothing, dicSubDepViews, 1)
If dicSubDepViews.ContainsKey(sView) Then
'Exclude youself from the dep list
dicSubDepViews.Remove(sView)
End If
oDepList(sView) = dicSubDepViews
Next
Dim oTempList As New Hashtable
Dim oDeleteList As New Hashtable
Dim oRet As New ArrayList()
Dim oDataView As DataView = New DataView(oTable)
oDataView.Sort = "level DESC"
For iRow As Long = 0 To oDataView.Count - 1
For Each oTempEntry As Collections.DictionaryEntry In oTempList
Dim sView As String = oTempEntry.Key
If oDeleteList.ContainsKey(sView) = False Then
Dim oViews As Hashtable = oDepList(sView)
If HashNotInList(oViews, oRet) = False Then
oRet.Add(sView)
oDeleteList(sView) = True
End If
End If
Next
Dim sDepViewName As String = oDataView(iRow)("key")
Dim dicSubDepViews As Hashtable = oDepList(sDepViewName)
If HashNotInList(dicSubDepViews, oRet) Then
'View has dependenies not listed above
oTempList(sDepViewName) = True
Else
oRet.Add(sDepViewName)
End If
Next
'Flush remaining items in temp list
For Each oTempEntry As Collections.DictionaryEntry In oTempList
Dim sView As String = oTempEntry.Key
If oDeleteList.ContainsKey(sView) = False Then
Dim oViews As Hashtable = oDepList(sView)
If HashNotInList(oViews, oRet) = False Then
oRet.Add(sView)
oDeleteList(sView) = True
End If
End If
Next
Return oRet
End Function
Private Function HashNotInList_
(ByRef oHash As Hashtable, ByRef oList As ArrayList) As Boolean
If oHash.Count = 0 Then
Return False
End If
For Each oEntry As Collections.DictionaryEntry In oHash
Dim sKey As String = oEntry.Key
Dim bKeyInList As Boolean = False
For j As Integer = 0 To oList.Count - 1
If oList(j) = sKey Then
bKeyInList = True
End If
Next
If bKeyInList = False Then
Return True
End If
Next
Return False
End Function
Private Function GetTableSql(ByVal sTableName As String) As String
If txtRowLimit.Text = "" Then
Return ""
End If
Dim iMaxRows As Integer = txtRowLimit.Text
If iMaxRows = 0 Then
Return ""
End If
Dim cn As Data.OleDb.OleDbConnection = GetConnection()
Dim iRow As Integer = 0
Dim oRet As New System.Text.StringBuilder()
Dim sSql As String = "select * from [" & sTableName & "]"
'sSql += " WHERE EMPLOYEE = 3237975"
Dim cmd As New Data.OleDb.OleDbCommand(sSql, cn)
Dim dr As Data.OleDb.OleDbDataReader
Try
dr = cmd.ExecuteReader()
Catch ex As Exception
Return "GetTableSql for " & sTableName & ". Error: " & Err.Description
End Try
Dim oSchemaRows As Data.DataRowCollection = dr.GetSchemaTable.Rows
While dr.Read()
iRow += 1
If iRow <= iMaxRows Then
Dim sRow As String = ""
For iCol As Integer = 0 To oSchemaRows.Count - 1
Dim sDataType As String = oSchemaRows(iCol).Item("DATATYPE").FullName
Dim sVal As String = ""
If sDataType = "System.Byte[]" Then
sVal = GetBinaryData(dr, iCol)
Else
sVal = dr.GetValue(iCol) & ""
End If
Dim sColumn As String = oSchemaRows(iCol).Item("ColumnName")
If sRow <> "" Then
sRow += ", "
End If
Select Case sDataType
Case "System.Short", "System.Integer", _
"System.Long", "System.Decimal", "System.Int32", "System.Int64"
If sVal = "" Then
sRow += "NULL"
Else
sRow += sVal
End If
Case Else
sRow += "'" & Replace(sVal, "'", "''") & "'"
End Select
sRow += " as [" & sColumn & "]"
Next
If iRow > 1 Then
oRet.Append(" union all" & vbCrLf)
End If
oRet.Append(vbTab & "select " & sRow)
End If
End While
dr.Close()
cn.Close()
If iRow > 1 Then
Return oRet.ToString() & vbCrLf
Else
Return ""
End If
End Function
Private Function GetBinaryData_
(ByRef dr As Data.OleDb.OleDbDataReader, ByVal iCol As Integer) As String
Dim iBufferSize As Integer = 1000
Dim oBuffer(iBufferSize - 1) As Byte
Dim iByteCount As Long 'The bytes returned from GetBytes.
Dim iStartIndex As Long = 0 'The starting position in the BLOB output
Dim oMemoryStream As IO.MemoryStream = Nothing
Dim oBinaryWriter As IO.BinaryWriter = Nothing
Dim sRet As String = ""
If IsDBNull(dr.GetValue(iCol)) = False Then
oMemoryStream = New IO.MemoryStream()
oBinaryWriter = New IO.BinaryWriter(oMemoryStream)
iByteCount = dr.GetBytes(iCol, iStartIndex, oBuffer, 0, iBufferSize)
'Continue reading and writing while there are bytes beyond the size of the buffer.
While (iByteCount = iBufferSize)
oBinaryWriter.Write(oBuffer)
iStartIndex += iBufferSize
iByteCount = dr.GetBytes(iCol, iStartIndex, oBuffer, 0, iBufferSize)
End While
If iByteCount > 2 Then
ReDim Preserve oBuffer(iByteCount - 2)
oBinaryWriter.Write(oBuffer)
End If
oBinaryWriter.Flush()
oMemoryStream.Position = 0
Dim oStreamReader As _
New IO.StreamReader(oMemoryStream, System.Text.Encoding.Unicode)
sRet = oStreamReader.ReadToEnd()
oStreamReader.Close()
oMemoryStream.Close()
End If
Return sRet
End Function
Private Function AddTabs(ByVal sSql As String) As String
Dim sRet As String = ""
Dim oSql As String() = Regex.Split(sSql, vbCrLf)
For i As Integer = 0 To oSql.Length - 1
sRet += vbTab & oSql(i)
If i < oSql.Length - 1 Then
sRet += vbCrLf
End If
Next
Return sRet
End Function
Private Function RegexReplace_
(ByRef sText As String, ByRef sPattern As String, ByRef sReplace As String) As String
Return Regex.Replace(sText, sPattern, sReplace, RegexOptions.IgnoreCase)
End Function
Private Function PadSql(ByVal sSql As String) As String
If chkReplace.Checked Then
sSql = Replace(sSql, "dbo_", "")
sSql = Replace(sSql, "DBO_", "")
sSql = Replace(sSql, """", "'")
sSql = Replace(sSql, "#", "'")
sSql = Replace(sSql, ";", "")
sSql = RegexReplace(sSql, "\bVal\(", "Convert(decimal,")
sSql = RegexReplace(sSql, "\bMid\(", "substring(")
sSql = RegexReplace(sSql, "\bLast\(", "Max(") 'LAST_VALUE - SQL Server 2016
'IsNull([Original_Salary]) = - 1 => [Original_Salary] IS NULL
Dim oDepViews As Hashtable = GetDepViews(sSql)
For Each oEntry As Collections.DictionaryEntry In oDepViews
Dim sView As String = oEntry.Key
sSql = Replace(sSql, "[" & sView & "]!", "[" & sView & "].")
Next
'IIf( -> case when
Dim oRegEx As New Regex("IIf\(([^,]*),([^,]*),([^,]*)\)", RegexOptions.IgnoreCase)
Dim oMatches As MatchCollection = oRegEx.Matches(sSql)
For Each oMatch As Match In oMatches
If oMatch.Groups.Count > 2 Then
Dim sFind As String = oMatch.Groups(0).Value
Dim a As String = oMatch.Groups(1).Value
Dim b As String = oMatch.Groups(2).Value
Dim c As String = oMatch.Groups(3).Value
Dim sReplace As String = "case when " & a & " _
then " & b & " else " & c & " end "
sSql = Replace(sSql, sFind, sReplace)
End If
Next
'IsNull([Original_Salary])=-1
oRegEx = New Regex("IsNull\(([^,]*)\)=-1", RegexOptions.IgnoreCase)
oMatches = oRegEx.Matches(sSql)
For Each oMatch As Match In oMatches
If oMatch.Groups.Count > 1 Then
Dim sFind As String = oMatch.Groups(0).Value
Dim a As String = oMatch.Groups(1).Value
Dim sReplace As String = a & " is null"
sSql = Replace(sSql, sFind, sReplace)
End If
Next
For Each oEntry As DictionaryEntry In dicTables
Dim sName As String = oEntry.Key
If sName.Substring(0, 4).ToLower() = "dbo_" Then
sName = sName.Substring(4)
sSql = Replace(sSql, "[" & sName & "]!", "[" & sName & "].")
sSql = Replace(sSql, sName & "!", sName & ".")
End If
Next
For Each oEntry As DictionaryEntry In dicViews
Dim sName As String = oEntry.Key
sSql = Replace(sSql, "[" & sName & "]!", "[" & sName & "].")
sSql = Replace(sSql, sName & "!", sName & ".")
Next
End If
sSql = ParseSql(sSql)
Return sSql
End Function
Private Function ParseSql(ByVal sql As String)
If chkFormatSql.Checked = False Then
Return sql
End If
Dim _tokenizer As New PoorMansTSqlFormatterLib.Tokenizers.TSqlStandardTokenizer()
Dim _parser = New PoorMansTSqlFormatterLib.Parsers.TSqlStandardParser()
Dim _treeFormatter As New PoorMansTSqlFormatterLib.Formatters.TSqlStandardFormatter()
Dim tokenized As PoorMansTSqlFormatterLib.TokenList = _tokenizer.TokenizeSQL(sql)
Dim parsed As PoorMansTSqlFormatterLib.ParseStructure.Node = _
_parser.ParseSQL(tokenized)
Dim sRet As String = _treeFormatter.FormatSQLTree(parsed)
If sRet.IndexOf("--WARNING! ERRORS ENCOUNTERED DURING SQL PARSING!") <> -1 Then
Return sql
End If
Return sRet
End Function
Private Sub GetDepViews(ByVal sSql As String, _
ByRef dicDepTables As Hashtable, ByRef dicDepViews As Hashtable, ByRef iLevel As Integer)
If iLevel > 1000 Then
'prevent infinate recursive loops
Exit Sub
End If
If Not dicDepTables Is Nothing Then
For Each oEntry As DictionaryEntry In dicTables
Dim sName As String = oEntry.Key
If sName.Substring(0, 4).ToLower() <> "dbo_" Then
Dim oRegEx As New Regex("\b" & sName & "\b", RegexOptions.IgnoreCase)
If sSql.ToLower().IndexOf("[" & sName.ToLower() & "]") <> -1 _
OrElse oRegEx.IsMatch(sSql) Then
If sSql.ToLower().IndexOf("into [" & sName.ToLower() & "]") = -1 Then
dicDepTables(sName) = True
End If
End If
End If
Next
End If
For Each oEntry As DictionaryEntry In dicViews
Dim sName As String = oEntry.Key
Dim oRegEx As New Regex("\b" & sName & "\b", RegexOptions.IgnoreCase)
If sSql.ToLower().IndexOf("[" & sName.ToLower() & "]") <> -1 _
OrElse oRegEx.IsMatch(sSql) Then
If dicDepViews.ContainsKey(sName) = False Then
dicDepViews.Add(sName, iLevel)
GetDepViews(oEntry.Value, dicDepTables, dicDepViews, iLevel + 1)
End If
End If
Next
End Sub
Private Function GetDepViews(ByVal sSql As String) As Hashtable
Dim oRet As New Hashtable
For Each oEntry As DictionaryEntry In dicViews
Dim sName As String = oEntry.Key
Dim oRegEx As New Regex("\b" & sName & "\b", RegexOptions.IgnoreCase)
If sSql.ToLower().IndexOf("[" & sName.ToLower() & "]") <> -1 _
OrElse oRegEx.IsMatch(sSql) Then
If oRet.ContainsKey(sName) = False Then
oRet.Add(sName, True)
End If
End If
Next
Return oRet
End Function
Private Sub txtFilePath_LostFocus(sender As Object, e As EventArgs) _
Handles txtFilePath.LostFocus
If txtFilePath.Text <> "" Then
LoadViews()
End If
End Sub
Private Sub Form1_FormClosing(sender As Object, e As FormClosingEventArgs) _
Handles Me.FormClosing
Dim oAppSetting As New AppSetting
oAppSetting.SetValue("FilePath", txtFilePath.Text)
oAppSetting.SetValue("RowLimit", txtRowLimit.Text)
oAppSetting.SetValue("View", cmViews.SelectedItem)
oAppSetting.SetValue("FormatSql", IIf(chkFormatSql.Checked, "1", "0"))
oAppSetting.SetValue("Replace", IIf(chkReplace.Checked, "1", "0"))
oAppSetting.SetValue("CTE", IIf(chkCTE.Checked, "1", "0"))
oAppSetting.SaveData()
If (Not cnOleDb Is Nothing) AndAlso cnOleDb.State = ConnectionState.Open Then
cnOleDb.Close()
End If
End Sub
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles Me.Load
Dim oAppSetting As New AppSetting
txtFilePath.Text = oAppSetting.GetValue("FilePath")
txtRowLimit.Text = oAppSetting.GetValue("RowLimit", "1000")
chkFormatSql.Checked = oAppSetting.GetValue("FormatSql", "1") = "1"
chkReplace.Checked = oAppSetting.GetValue("Replace", "1") = "1"
chkCTE.Checked = oAppSetting.GetValue("CTE", "1") = "1"
LoadViews()
cmViews.SelectedItem = oAppSetting.GetValue("View")
End Sub
Private Sub btnSelectAll_Click(sender As Object, e As EventArgs) Handles btnSelectAll.Click
If txtSQL.Text = "" Then
Exit Sub
End If
txtSQL.SelectAll()
txtSQL.Focus()
Clipboard.Clear()
Clipboard.SetText(txtSQL.Text)
End Sub
Private Sub btnSaveAll_Click(sender As Object, e As EventArgs) Handles btnSaveAll.Click
Dim sAssPath As String = System.Reflection.Assembly.GetExecutingAssembly().Location
Dim sPath As String = System.IO.Path.GetDirectoryName(sAssPath)
Dim sFolderPath As String = System.IO.Path.Combine(sPath, "SQL")
If IO.Directory.Exists(sFolderPath) Then
For i As Integer = 1 To 1000
If IO.Directory.Exists(sFolderPath & i) = False Then
sFolderPath = sFolderPath & i
Exit For
End If
Next
End If
If IO.Directory.Exists(sFolderPath) = False Then
IO.Directory.CreateDirectory(sFolderPath)
End If
ProgressBar1.Visible = True
ProgressBar1.Minimum = 1
ProgressBar1.Maximum = dicViews.Count
Dim iCount As Integer = 0
For Each oEntry As DictionaryEntry In dicViews
Dim sViewName As String = oEntry.Key
Dim sSql As String = ShowView(sViewName, False)
Dim sFilePath As String = System.IO.Path.Combine(sFolderPath, sViewName & ".sql")
Dim oFile As New IO.StreamWriter(sFilePath, True)
oFile.Write(sSql)
oFile.Close()
iCount += 1
ProgressBar1.Value = iCount
System.Windows.Forms.Application.DoEvents()
Next
ProgressBar1.Visible = False
Process.Start("explorer.exe", String.Format("/n, /e, {0}", sFolderPath & "\"))
End Sub
Private Sub btnUp_Click(sender As Object, e As EventArgs) Handles btnUp.Click
Dim i As Integer = lbDepViews.SelectedIndex
If i = -1 OrElse lbDepViews.Items.Count < 2 OrElse i = 0 Then
Exit Sub
End If
Dim a As String = lbDepViews.Items(i - 1)
Dim b As String = lbDepViews.Items(i)
lbDepViews.Items(i - 1) = b
lbDepViews.Items(i) = a
lbDepViews.SelectedIndex += -1
txtSQL.Text = ShowView2()
End Sub
Private Sub btnDown_Click(sender As Object, e As EventArgs) Handles btnDown.Click
Dim i As Integer = lbDepViews.SelectedIndex
If i = -1 OrElse lbDepViews.Items.Count < 2 _
OrElse i = lbDepViews.Items.Count - 1 Then
Exit Sub
End If
Dim a As String = lbDepViews.Items(i)
Dim b As String = lbDepViews.Items(i + 1)
lbDepViews.Items(i) = b
lbDepViews.Items(i + 1) = a
lbDepViews.SelectedIndex += 1
txtSQL.Text = ShowView2()
End Sub
Private Sub txtFilePath_TextChanged(sender As Object, e As EventArgs) _
Handles txtFilePath.TextChanged
End Sub
End Class
Here is the VBS script (AccessView.vbs) that creates a CSV file to show all MS Access linked tables and queries.
if WScript.Arguments.Count = 0 then
MsgBox "Please drag and drop MS Acccess file"
wscript.Quit
End if
sFile = WScript.Arguments(0)
If Not (lcase(right(sFile,4)) = ".mdb" or lcase(right(sFile,6)) = ".accdb") Then
MsgBox "Please drag and drop MS Acccess file not: " & sFile
wscript.Quit
End If
Set fso = CreateObject("Scripting.FileSystemObject")
sLogFile = sFile & ".csv"
If fso.FileExists(sLogFile) Then
On Error resume next
fso.DeleteFile sLogFile, True
If Err.Number <> 0 Then
sLogFile = sFile & "_" & Replace(Replace(Replace(Now(),_
"/","-"),":","-")," ","_") & ".csv"
Err.Clear
On Error goto 0
End If
End If
Set oLog = fso.CreateTextFile(sLogFile, True)
oLog.WriteLine "sep=" & vbTab
Dim oApp: Set oApp = createObject("Access.Application")
oApp.visible = False
'oApp.UserControl = true
oApp.OpenCurrentDataBase(sFile)
Dim oDatabase: Set oDatabase = oApp.CurrentDb
Set oNewLinks = CreateObject("Scripting.Dictionary")
Const dbAttachedODBC = 536870912
Dim t 'As TableDef
For Each t In oDatabase.TableDefs
If (t.Attributes And dbAttachedODBC) And t.SourceTableName <> "" _
Then 'If the table source is other than a base table
oLog.WriteLine "Table" & vbTab & t.Name & _
vbTab & t.SourceTableName & vbTab & t.Connect
End If
Next
Dim q 'As QueryDef
For Each q In oDatabase.QueryDefs
If q.Connect <> "" Then 'q.Type 112
oLog.WriteLine "Query" & vbTab & q.Name & vbTab & """" & _
Replace(q.SQL,"""","'") & """" & vbTab & q.Connect
End If
Next
oApp.Quit
Set oApp = Nothing
oLog.Close
Set oExcel = CreateObject("Excel.Application")
oExcel.visible = True
Set workbook = oExcel.Workbooks.Open(sLogFile)
MsgBox "Created " & sLogFile
Here is the VBS script (AccessUpdate.vbs) that will update a MS Access to point all linked tables and queries to another SQL Server location
sConnect = "ODBC;DRIVER=SQL Server;Server=NewServer1;_
Database=NewDb1;Uid=User1;Pwd=Password123;"
if WScript.Arguments.Count = 0 then
MsgBox "Please drag and drop MS Acccess file"
wscript.Quit
End if
sFile = WScript.Arguments(0)
If Not (lcase(right(sFile,4)) = ".mdb" or lcase(right(sFile,6)) = ".accdb") Then
MsgBox "Please drag and drop MS Acccess file not: " & sFile
wscript.Quit
End If
Dim oApp: Set oApp = createObject("Access.Application")
oApp.visible = False
oApp.UserControl = true
oApp.OpenCurrentDataBase(sFile)
Dim oDatabase: Set oDatabase = oApp.CurrentDb
oApp.DoCmd.NavigateTo "acNavigationCategoryObjectType"
'oApp.DoCmd.RunCommand 2 'acCmdWindowHide
oApp.DoCmd.SelectObject 0, , True 'cTable = 0
Set oTables = CreateObject("Scripting.Dictionary")
Set oNewLinks = CreateObject("Scripting.Dictionary")
Const dbAttachedODBC = 536870912
Const dbAttachSavePWD = 131072
Dim t 'As TableDef
For Each t In oDatabase.TableDefs
If (t.Attributes And dbAttachedODBC) And t.SourceTableName <> "" _
Then 'If the table source is other than a base table
sTableConnect = sConnect
If lcase(right(t.SourceTableName,5)) = "_view" Then
sTableConnect = Replace(sConnect,";Database=OldDb1",";Database=NewDb1")
End If
If Right(t.Name,7) <> "_delete" And t.Connect <> sTableConnect Then
bNewLink = False
If InStr(1, t.SourceTableName, "new_schema1.") = 0 Then
oTables(Replace(t.SourceTableName, "dbo.", "")) = True
End If
sSourceTableName = Replace(t.SourceTableName, "dbo.", "new_schema1.")
If sSourceTableName <> t.SourceTableName Then
sName = t.Name
t.Name = sName & "_delete"
Set n = oDatabase.CreateTableDef()
n.Name = sName
n.Connect = sTableConnect
n.Attributes = (n.Attributes Or dbAttachSavePWD)
n.SourceTableName = sSourceTableName
oNewLinks.Add oNewLinks.Count, n
bNewLink = True
End If
If bNewLink = False Then
t.Connect = sTableConnect
On Error Resume Next
t.RefreshLink
If Err.Number <> 0 Then
MsgBox "t.RefreshLink - Name: " & t.Name & ", Error: " & Err.Description
Err.Clear
On Error GoTo 0
End If
End If
End If
End If
Next
For i = 0 To oNewLinks.Count - 1
bSuccess = True
On Error Resume Next
Set t = oNewLinks.Item(i)
oDatabase.TableDefs.Append t
If Err.Number <> 0 Then
MsgBox "t.RefreshLink - Name: " & t.Name & ", Error: " & Err.Description
bSuccess = False
Err.Clear
End If
On Error GoTo 0
If bSuccess Then
oDatabase.TableDefs.Delete t.Name & "_delete"
End If
Next
Dim q 'As QueryDef
For Each q In oDatabase.QueryDefs
If q.Connect <> "" Then 'q.Type 112
q.Connect = sConnect
If InStr(1, q.SQL, "ls_apps.") = 0 Then
q.SQL = Replace(q.SQL, "dbo.", "new_schema1.")
For Each sTable in oTables.Keys
If sTable <> "" Then
q.SQL = Replace(q.SQL, vbCrLf & "FROM " & sTable, _
vbCrLf & "FROM new_schema1." & sTable)
End If
Next
End If
End If
Next
MsgBox "Updated " & sFile
History
- 28th December, 2020: Initial version