MS Access: Drop Table Function if Exists

I had to check whether a specific table is already available before creating it through Access VBA script. This is very frequent. This code helped me.

Public Function ifTableExists(tablename As String) As Boolean

ifTableExists = False
If DCount("[Name]", "MSysObjects", "[Name] = '" & tablename & "'") = 1 Then
ifTableExists = True
Else
ifTableExists = False
End If

End Function

After creating above UserDefined Function it can be used as

If ifTableExists("MyTable") Then db.Execute "DROP Table MyTable"

MS Access: Capture SystemID and Username - VBA

I had a task of calling SQL Server Stored Procedure from Access VBA. Multiple users should be able to call it. Also I had to track who is Executing the Stored procedure from Access. This code can capture SystemID and Username. These two entities can be passed as parameters to the SQL Server Stored Procedure.

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
(ByVal IpBuffer As String, nSize As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" _
(ByVal lpBuffer As String, nSize As Long) As Long

Function ThisUserName() As String
Dim LngBufLen As Long
Dim strUser As String

strUser = String$(15, " ")
LngBufLen = 15

If GetUserName(strUser, LngBufLen) = 1 Then
ThisUserName = Left(strUser, LngBufLen - 1)
Else
ThisUserName = "Unknown"
End If
End Function

Function ThisComputerID() As String
Dim LngBufLen As Long
Dim strUser As String

strUser = String$(15, " ")
LngBufLen = 15

If GetComputerName(strUser, LngBufLen) = 1 Then
ThisComputerID = Left(strUser, LngBufLen)
Else
ThisComputerID = 0
End If
End Function

Paste the above code in MS Access module as shown in below screenshot.

You can call the SQL Server Stored Procedure in this way

Dim Usrname As String
Dim UserSysNo As String
Call ThisUserName
Usrname = ThisUserName

Call ThisComputerID
UserSysNo = ThisComputerID

    Set cnn = New ADODB.Connection
    cnn.CommandTimeout = 0
    cnn.ConnectionString = "Provider=SQLOLEDB;Data Source=192.168.0.222;Initial Catalog=yourdatabase;User ID=yourid;Password=yourpassword"
    cnn.Open
    Set rs = New ADODB.Recordset
    Set rs = cnn.Execute("EXEC YOUR_SP " & Usrname & " , " & "'" & UserSysNo & "'")
    Set rs = Nothing
    cnn.Close

MS Access: Hide columns with Access VBA or VB Script

I needed to hide specified columns in an access table by clicking a button in the form through VBA code. I could do with the below code.

Public Sub SetColumnHidden()

    Dim dbs As DAO.Database
    Dim fld As DAO.Field
    Dim prp As DAO.Property
    Const conErrPropertyNotFound = 3270

    ' Turn off error trapping.
    On Error Resume Next

    Set dbs = CurrentDb
   
    ' Set field property.
    Set fld = dbs.TableDefs!Products.Fields!ProductID
    fld.Properties("ColumnHidden") = True
   
    ' Error may have occurred when value was set.
    If Err.Number <> 0 Then
        If Err.Number <> conErrPropertyNotFound Then
            On Error GoTo 0
            MsgBox "Couldn't set property 'ColumnHidden' " & _
                   "on field '" & fld.Name & "'", vbCritical
        Else
            On Error GoTo 0
            Set prp = fld.CreateProperty("ColumnHidden", dbLong, True)
            fld.Properties.Append prp
        End If
    End If
   
    Set prp = Nothing
    Set fld = Nothing
    Set dbs = Nothing
   
End Sub

Source: Microsoft
http://msdn.microsoft.com/en-us/library/office/aa224064(v=office.11).aspx
http://msdn.microsoft.com/en-us/library/office/ff194134(v=office.14).aspx

MS Excel: Highlight similar duplicates with similar colors

I had 10 independent SQL tables with no relationships.Each table contained around 20-30 columns each. I needed to establish relation between the tables. So quickly I pasted the columns in to an excel sheet and ran this macro to highlight duplicates, meaning same column availability in all columns.

Sub Highlight_Duplicates()
    Dim ws As Worksheet
    Dim cell As Range
    Dim myrng As Range
    Dim clr As Long
    Dim lastCell As Range

    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set myrng = ws.Range("A2:K" & Range("A" & ws.Rows.Count).End(xlUp).Row)
    With myrng
        Set lastCell = .Cells(.Cells.Count)
    End With
    myrng.Interior.ColorIndex = xlNone
    clr = 3

    For Each cell In myrng
        If Application.WorksheetFunction.CountIf(myrng, cell) > 1 Then
            ' addresses will match for first instance of value in range
            If myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Address = cell.Address Then
                ' set the color for this value (will be used throughout the range)
                cell.Interior.ColorIndex = clr
                clr = clr + 1
            Else
                ' if not the first instance, set color to match the first instance
                cell.Interior.ColorIndex = myrng.Find(what:=cell, lookat:=xlWhole, MatchCase:=False, after:=lastCell).Interior.ColorIndex
            End If
        End If
    Next
End Sub

Below is the depicted sample executed macro excel sheet. Ignore first row as they are just headers. The macro executes from second row.

MS Access: Extract Special characters only to a new column

I stuck up with a peculiar access task to extract only special characters available in the given string. Usually we always remove junk characters and normalize the data eliminating special chars. But here I needed to extract junk and put them in to the adjacent column.I achieved it by developing this below code.

Public Sub ExtrctspecialCharsOnly()
Dim n As Integer
Dim tbl As TableDef, fld As Field
Set db = CurrentDb
Dim str(7) As String

Dim i As Integer
db.Execute "UPDATE Table1 SET SpecialChars= len([InputString])"
db.Execute "UPDATE Table1 SET SpecialChars= '0' WHERE (((SpecialChars) Is Null))"
n = DMax("CInt([SpecialChars])", "Table1")
db.Execute "UPDATE Table1 SET SpecialChars= ''"
db.Execute "UPDATE Table1 SET InputString = trim([InputString])"
For i = 1 To n
db.Execute "UPDATE Table1 SET SpecialChars= [SpecialChars]+Mid([InputString]," & i & ",1) WHERE ((Mid([InputString]," & i & ",1) Not Like '*[^a-z]*') and Mid([InputString]," & i & ",1) Not Like '*[^0-9]*')"
Next i

End Sub

MS Access: Drop table if exists in MS Access

I had a scenario to check existance of a specified table in access. If the specified table is available, it should get deleted(drop) or else just go on performing with the rest of the code. This operation should be done when we close the form. So I used Sub Form_Unload and developed the code.

Private Sub Form_Unload(Cancel As Integer)

Dim tbl As TableDef
Dim db As Database
Set db = CurrentDb

For Each tbl In db.TableDefs
If tbl.Name = "FirstTbl" Then
db.Execute "DROP TABLE FirstTbl"
End If
If tbl.Name = "SecondTbl" Then
db.Execute "DROP TABLE SecondTbl"
End If
Next tbl

End Sub

This is one more method using User defined function

Public Function ifTableExists(tablename As String) As Boolean

ifTableExists = False
If DCount("[Name]", "MSysObjects", "[Name] = '" & tablename & "'") = 1 Then
ifTableExists = True
Else
ifTableExists = False
End If

End Function

After creating above UserDefined Function it can be used as

If ifTableExists("MyTable") Then db.Execute "DROP Table MyTable"

Capture counts in a column MS Access

I had a scenario of capturing counts in several columns and display it in a message box while running a VBA form. So I developed a VBA code using inbuilt function DCount.

Private Sub Check_Counts()

Set db = CurrentDb()
m = DCount("Address", "Table1")
MsgBox "Counts in Address Column is " & m & vbCrLf + "Completed"

End Sub

Field Exists check in MS Access VBA

We had a scenario of checking whether the column/field is available in Access table or not. If the specified column is available, then it is fine and go ahead and perform necessary operations. If specified field is not available need to add column. So we had to develop a function to check the specified field is available or not.

Private Sub check()

Set db = CurrentDb

If ifFieldExists("ID", "Table1") Then
MsgBox "ID field available"
Else
MsgBox "ID field is not available"
End If

End Sub
________________________________________________________________________________

Public Function ifFieldExists(fldname As String, tableName As String) As Boolean
Dim rs As Recordset, db As Database 'Sub DAO Vars
On Error GoTo fs

'This checks if a Table is there and reports True or False.

Set db = CurrentDb()

'If Table is there open it
Set rs = db.OpenRecordset("Select " & fldname & " from " & tableName & ";")

ifFieldExists = True
rs.Close
db.Close

Exit Function

fs:
'If table is not there close out and set function to false
Set rs = Nothing
db.Close
Set db = Nothing

     ifFieldExists = False
  Exit Function
End Function

MS Access: Create Autonumber ID field through VBA script

The below script will create autonumber field with name 'ID' after execution.

STEPS:

1. Create a new form and add a button to it.
2. Right click on the button, click Build Event and paste below script. Save the form and close.
3. Open the form and click on the button to create Auto number column.

Private Sub Command1_Click()

Dim DB As Database
Set DB = CurrentDb


Dim tdf As DAO.TableDef
  Dim fld As DAO.Field
  Dim idx As DAO.Index
 
  Set DB = CurrentDb
  Set tdf = DB.TableDefs("Mytable")
 
  With tdf
    ' Append AutoNumberField
    Set fld = .CreateField("ID", dbLong)
    fld.Attributes = .Attributes Or dbAutoIncrField
    .Fields.Append fld
    .Fields.Refresh
   
    ' Set RecordID as PK
    Set idx = .CreateIndex("PK_Table1")
    idx.Fields.Append idx.CreateField("ID")
    idx.Primary = True
    .Indexes.Append idx
   
  End With
 
  Application.RefreshDatabaseWindow

  MsgBox "Autonumber ID column created"
 
End Sub