Call ShowProgress("Task 4", 10)  

Public g_objConnection As ADODB.Connection
Public Const gc_strDBPath As String = "C:\Test.mdb"
 
Function blnConnectDatabase(strPath As String, strDBPass As String) As Boolean
'    If blnFileExists(strPath) = False Then
'        GoTo ErrH
'        Exit Function
'    End If
    Set g_objConnection = New ADODB.Connection
    On Error GoTo ErrH
    g_objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
        strPath & ";Jet OLEDB:Database Password=" & strDBPass & ";"
    On Error GoTo 0
    blnConnectDatabas

Sub Test()
    Call TransposeBack(Sheet1.Range("A3:D10"), Sheet1.Range("I1"))
End Sub
 
Sub TransposeBack(rngData As Range, rngTarget As Range)
    Dim rngHeader       As Range
    Dim rngId           As Range
    Dim rngCell         As Range
    Dim rngDest         As Range
    Dim lngRept         As Long
 
    Set rngDest = rngTarget.Offset(1)
 
    With rngData
        Set rngHeader = Intersect(.Rows(1), .Rows(1).O

Sub DeleteMultipleSheets()
    Application.DisplayAlerts = False
    With ThisWorkbook.Worksheets(Array("Sheet2", "Sheet3"))
        .Delete
    End With
    Application.DisplayAlerts = True
End Sub

sub DeleteAllCharts()
Sheet1.ChartObjects.delete
End Sub

sub DeleteAllShapes()
Sheet1.Shapes.SelectAll
Selection.Delete
End Sub

Sub CreateChartFromArray()
    Dim objCht As ChartObject
    With Sheet1
        Set objCht = .ChartObjects.Add(10, 20, 500, 200)
        objCht.Chart.ChartWizard .Cells(1)
        objCht.Chart.SeriesCollection(1).Values = Array(56, 61, 45, 15, 30, 10)
        objCht.Chart.SeriesCollection(1).XValues = Array("A", "B", "C", "D", "E", "F")
    End With
    Set objCht = Nothing
End Sub

Sub ZoomRange(rngZoom As Range)
    Application.Goto rngZoom
    ActiveWindow.Zoom = True
End Sub
 
Sub Test()
    Call ZoomRange(Sheet1.Range("A1:L23"))
End Sub

Public Function blnEmailValid(ByVal strEmailAdd As String) As Boolean
    With CreateObject("VBScript.RegExp")
        .IgnoreCase = True
        .Global = True
        .Pattern = "^([a-zA-Z0-9_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]{2,3})$"
        blnEmailValid = .Test(strEmailAdd)
    End With
End Function
 
Sub Test()
    MsgBox blnEmailValid("abc@EE.com")
End Sub

Sub RemoveDups(rngDups As Range, Optional rngTarget As Range)
    If rngTarget Is Nothing Then
        rngDups.RemoveDuplicates Columns:=1, Header:=xlNo
    Else
        rngDups.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngTarget, Unique:=True
    End If
End Sub
 
Sub Test()
    Call RemoveDups(ActiveSheet.Range("A1:A10"), ActiveSheet.Range("D1"))
End Sub

Sub CreateEventProcedure(wks As Worksheet, strEvtProc As String)
    With ActiveWorkbook.VBProject.VBComponents(wks.CodeName).CodeModule
        'Add the blank procedure
        .CreateEventProc strEvtProc, "Worksheet"
    End With
End Sub
 
Sub TestProc()
    Call CreateEventProcedure(ThisWorkbook.Worksheets("Sheet2"), "Activate")
    MsgBox "Goto Sheet2 module in the code window. The activate procedure skeleton is added.", vbInformation, "Excel Experts"
End Sub

Declare Sub mciSendStringA Lib "winmm.dll" (ByVal lpstrCommand As String, _
    ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, _
    ByVal hwndCallback As Long)
 
Sub CDTrayOpen()
    mciSendStringA "Set CDAudio Door Open", 0&, 0, 0
End Sub
 
Sub CDTrayClose()
    mciSendStringA "Set CDAudio Door Closed", 0&, 0, 0
End Sub

Function ProtectedVBProject(ByVal wb As Workbook) As Boolean
    Dim intVBComp As Integer
    intVBComp = -1
    On Error Resume Next
    intVBComp = wb.VBProject.VBComponents.Count
    If Err.Number = 1004 Then
        MsgBox "Add reference to the Microsoft Visual Basic Extensibility Library", vbCritical, "Excel Experts"
    End If
    On Error GoTo 0
    If intVBComp = -

Sub ShowInstalledFonts()
    Const StartRow As Integer = 4
    Dim cbcFontName As CommandBarControl, cbrFontCmd As CommandBar, strFormula As String
    Dim strFontName As String, i As Long, lngFontCount As Long, intFontSize As Integer
 
    intFontSize = 10
 
    If intFontSize = 0 Then Exit Sub
    If intFontSize < 8 Then intFontSize = 8
    If intFontSize > 30 Then intFontSize = 30
 
    Set cbcFontName = Application.CommandBars("Formatting").FindControl(ID:=1728)