Archive for July, 2008

Contents of this Site

July 28, 2008 at 01:57 · Filed under VBA Examples

Updated July 27, 2008

  1. Tips on VBA
  2. Create Sheet “Table of Contents”
  3. Add Minimize Button to Userform
  4. Search Folders and Subfolders for files
  5. Explore CommandBar control FaceIds Provided by Microsoft
  6. Create Access Database via DAO
  7. Get FileName with Path from User
  8. Filed under: VBA Examples — selvavpasupathy @ 12:24 am
  9. Connection & Query for data in Excel Spreadsheet
  10. Use of vbScript in Database Applications
  11. Write or Append a Text File
  12. Fill a UserForm Combo Box List from a Database
  13. Read CSV Using VBA techniques
  14. Auto-Generate a File Name
  15. Rename a File
  16. Move a File
  17. Verify that a File Exists
  18. Multiple Cell Concatenation
  19. Get FileNames from a Folder/Directory
  20. Get Cell or Range from User
  21. Resources
  22. Web Forms manipulated by Visual Basic
  23. Write / Read to a Text File
  24. Rename Files using Codes (VBA)
  25. Ken’s Knowledge Base submissions
  26. Process all Files in a folder
  27. Get Input Elements Name & Type from HTML Form
  28. Secure Login
  29. Get elements from HTML form
  30. Handle WebForm via VB
  31. Login to Rediffmail
  32. Hyperlink Elements in HTML
  33. Creating MenuRow for Sheets using an Excel VBA
  34. Export a Text File with Comma and Quote Delimiters
  35. VBA Code Library
  36. Search for a ’string’ in Excel Workbook
  37. Add Sheet Navigation CommandBar to an Excel file or Application


Leave a Comment

Tips on VBA

July 27, 2008 at 22:28 · Filed under VBA, VBA Code Library, VBA Examples

Some basic to intermediate VBA tips from www.automateexcel.com
- Selva V Pasupathy, HSBC Global Resourcing, Hyderabad, India

Comments (1)

Create Sheet “Table of Contents”

July 27, 2008 at 22:19 · Filed under VBA Examples

Copy the following code in a code Module…
-Selva V Pasupathy, HSBC Global Resourcing, Hyderabad, India

Option Explicit
Function wsExists(wksName As String) As Boolean
  On Error Resume Next
  wsExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
Sub TableOfContents()
'Create a Table of Contents for Active WorkBook
'written by royUK
Visit for more Resources @ http://socko.wordpress.com
More Resources http://selvavinaygam.googlepages.com
28 July 2008
  Dim wSht As Worksheet, wShtTOC As Worksheet
  Dim intRow As Long
  Dim msgResponse As String
  With Application
    .ScreenUpdating = False
    If wsExists("Table of Contents") Then
      msgResponse = MsgBox("TOC exists. Do you wish to recreate it?", vbInformation + vbYesNo, _
                 "J & R Excel Solutions")
      Select Case msgResponse
      Case vbNo
        Exit Sub
      Case vbYes
        .DisplayAlerts = False
        Sheets("Table of Contents").Delete
        Set wShtTOC = ActiveWorkbook.Worksheets.Add(before:=ActiveWorkbook.Sheets(1))
        With wShtTOC
          .Name = "Table of Contents"
          .Range("A1") = "Table of Contents"
          .Range("A1").Font.Size = 14
        End With
        intRow = 3
        For Each wSht In ActiveWorkbook.Worksheets
          If wSht.Name  wShtTOC.Name Then
            wShtTOC.Hyperlinks.Add anchor:=wShtTOC.Cells(intRow, 1), Address:="", _
                         SubAddress:=wSht.Name & "!A1", _
                         TextToDisplay:=wSht.Name
            intRow = intRow + 1
          End If
        Next wSht
      End Select
    Else
      With Application
        .ScreenUpdating = False
        Set wShtTOC = ActiveWorkbook.Worksheets.Add(before:=ActiveWorkbook.Sheets(1))
        wShtTOC.Name = "Table of Contents"
        wShtTOC.Range("A1") = "Table of Contents"
        wShtTOC.Range("A1").Font.Size = 14
        intRow = 3
        For Each wSht In ActiveWorkbook.Worksheets
          If wSht.Name  wShtTOC.Name Then
            wShtTOC.Hyperlinks.Add anchor:=wShtTOC.Cells(intRow, 1), Address:="", _
                         SubAddress:=wSht.Name & "!A1", _
                         TextToDisplay:=wSht.Name
            intRow = intRow + 1
          End If
        Next
      End With
    End If
    .ScreenUpdating = True
    .DisplayAlerts = True
  End With
End Sub

Comments (1)

Add Minimize Button to Userform

July 27, 2008 at 22:06 · Filed under VBA Examples

by Selva V Pasupathy

The following lines of codes will help add a minimize button on a userform which will be handy in many situations.

First copy the following 3 lines of codes to userform code window.

Private Sub UserForm_Initialize()
    Call FormatUserForm(Me.Caption)
End Sub

Copy the following code in a module. 

Option Explicit
Private Declare Function _
      FindWindowA Lib "USER32" _
      (ByVal lpClassName As String, _
      ByVal lpWindowName As String) As Long
Private Declare Function _
      GetWindowLongA Lib "USER32" _
      (ByVal hWnd As Long, _
      ByVal nIndex As Long) As Long
Private Declare Function _
      SetWindowLongA Lib "USER32" _
      (ByVal hWnd As Long, _
      ByVal nIndex As Long, _
      ByVal dwNewLong As Long) As Long
Sub FormatUserForm(UserFormCaption As String)
Dim hWnd As Long
Dim exLong As Long
    hWnd = FindWindowA(vbNullString, UserFormCaption)
    exLong = GetWindowLongA(hWnd, -16)
    If (exLong And &H20000) = 0 Then
        SetWindowLongA hWnd, -16, exLong Or &H20000
        Else
    End If
End Sub
Sub ShowForm()
    UserForm1.Show
End Sub


For some more resources visit

-Selva V Pasupathy
HSBC Global Resourcing
Hyderabad, India

Comments (1)

Search Folders and Subfolders for files

July 27, 2008 at 21:42 · Filed under VBA Examples

If you have ever had to look through a large directory for files, this routine searches the directory and subfolders and displays them in a new worksheet. The files can be opened by clicking on the listed hyperlink.
This routine searches a directory and sub folders for a selected file type. They are displayed in a new worksheet.
Source: http://www.vbaexpress.com/
Code by : austenr

Option Explicit
Sub SrchForFiles()
 Dim i As Long, z As Long, Rw As Long
 Dim ws As Worksheet
 Dim y As Variant
 Dim fLdr As String, Fil As String, FPath As String
 y = Application.InputBox _
   ("Please Enter File Extension", "Info Request")
 If y = False And Not TypeName(y) = _
      "String" Then Exit Sub
 Application.ScreenUpdating = False
 With Application.FileDialog _
      (msoFileDialogFolderPicker)
  .Show
  fLdr = .SelectedItems(1)
 End With
 With Application.FileSearch
  .NewSearch
  .LookIn = fLdr
  .SearchSubFolders = True
  .Filename = y
  Set ws = ThisWorkbook.Worksheets.Add(Sheets(1))
  On Error GoTo 1
2:    ws.Name = "FileSearch Results"
  On Error GoTo 0
  If .Execute() > 0 Then
   For i = 1 To .FoundFiles.Count
    Fil = .FoundFiles(i)
    FPath = Left(Fil, Len(Fil) - Len(Split(Fil, "\") _
        (UBound(Split(Fil, "\")))) - 1)
    If Left$(Fil, 1) = Left$(fLdr, 1) Then
     If CBool(Len(Dir(Fil))) Then
      z = z + 1
      ws.Cells(z + 1, 1).Resize(, 4) = _
      Array(Dir(Fil), _
      FileLen(Fil) / 1000, _
      FileDateTime(Fil), _
      FPath)
      ws.Hyperlinks.Add Anchor:=ws.Cells(z + 1, 1), _
      Address:=.FoundFiles(i)
     End If
    End If
   Next i
  End If
 End With
 ActiveWindow.DisplayHeadings = False
 With ws
  Rw = .Cells.Rows.Count
  With .[A1:D1]
   .Value = _
     [{"Full Name","Kilobytes","Last Modified", "Path"}]
   .Font.Underline = xlUnderlineStyleSingle
   .EntireColumn.AutoFit
   .HorizontalAlignment = xlCenter
  End With
  .[E1:IV1 ].EntireColumn.Hidden = True
  On Error Resume Next
  Range(Cells(Rw, "A").End(3)(2), _
     Cells(Rw, "A")).EntireRow.Hidden = True
  Range(.[A2 ], Cells(Rw, "C")).Sort [A2 ], _
     xlAscending, Header:=xlNo
 End With
 Application.ScreenUpdating = True
 Exit Sub
1:  Application.DisplayAlerts = False
 Worksheets("FileSearch Results").Delete
 Application.DisplayAlerts = True
 GoTo 2
End Sub

Comments (1)

Explore CommandBar control FaceIds Provided by Microsoft

July 27, 2008 at 21:09 · Filed under VBA Examples 

Copy the code below in a module,
name it as FaceIdExplorerModule,
and then save the file as faceid.xla

Option Explicit
Private StartFaceId As Integer
Private Const SAppName = "FaceId Explorer"
Private Const SPreferencesSection = "Preferences"
Private Const SVisibilityKey = "Visible"
Private Const SRowIndexKey = "RowIndex"
Private Const SPositionKey = "Position"
Private Const STopKey = "Top"
Private Const SLeftKey = "Left"
Private Const SWidthKey = "Width"
Private Const SHeightKey = "Height"
Private Const SStartFaceIdKey = "StartFaceId"
Private Const SFaceIdCommandBarName = "FaceId Explorer"
Private Const BUTTON_ABOUT = 1
Private Const BUTTON_PREVIOUS = 2
Private Const BUTTON_NEXT = 3
Private Const BUTTON_FACEID = 4
Private Const FIRST_FACEID = 1
Sub FaceId_AddinInstall()
    AddinInitialize
End Sub
Sub FaceId_AddinUninstall()
    AddinShutdown
End Sub
Sub Auto_Open()
    AddinInitialize
End Sub
Sub Auto_Close()
    AddinShutdown
End Sub
Sub AddinInitialize()
    StartFaceId = FIRST_FACEID
    CreateToolBar
    SetPreviousButtonState
    AssignFaceId
End Sub
Sub AddinShutdown()
    Dim Toolbar As CommandBar
    On Error Resume Next
    Set Toolbar = CommandBars(SFaceIdCommandBarName)
    If Not (Toolbar Is Nothing) Then
        With Toolbar
            SaveSetting SAppName, SPreferencesSection, _
                SVisibilityKey, IIf(.Visible, "1", "0")
            SaveSetting SAppName, SPreferencesSection, _
                SRowIndexKey, Trim(Str(.RowIndex))
            SaveSetting SAppName, SPreferencesSection, _
                SPositionKey, Trim(Str(.Position))
            SaveSetting SAppName, SPreferencesSection, _
                STopKey, Trim(Str(.Top))
            SaveSetting SAppName, SPreferencesSection, _
                SLeftKey, Trim(Str(.Left))
            SaveSetting SAppName, SPreferencesSection, _
                SWidthKey, Trim(Str(.Width))
            SaveSetting SAppName, SPreferencesSection, _
                SHeightKey, Trim(Str(.Height))
            SaveSetting SAppName, SPreferencesSection, _
                SStartFaceIdKey, Trim(Str(StartFaceId))
            .Delete
        End With
    End If
End Sub
Sub CreateToolBar()
    Dim Toolbar As CommandBar
    Dim Button As CommandBarButton
    Dim i As Integer
    Dim Begin As Boolean
    Dim TotalWidth As Integer
    Dim WidthStr As String
    Dim HostAppStr As String
    On Error Resume Next
    If Application.Name = "Microsoft PowerPoint" Then
        HostAppStr = "FaceId.ppa!FaceIdExplorerModule."
    ElseIf Application.Name = "Microsoft Excel" Then
        HostAppStr = "FaceId.xla!FaceIdExplorerModule."
    End If
    CommandBars(SFaceIdCommandBarName).Delete
    Set Toolbar = CommandBars.Add(Name:=SFaceIdCommandBarName, Temporary:=True)
    With Toolbar
        .RowIndex = Val(GetSetting(SAppName, SPreferencesSection, _
            SRowIndexKey, "-1"))
        .Position = Val(GetSetting(SAppName, SPreferencesSection, _
            SPositionKey, Str(msoBarFloating)))
        .Top = Val(GetSetting(SAppName, SPreferencesSection, _
            STopKey, "100"))
        .Left = Val(GetSetting(SAppName, SPreferencesSection, _
            SLeftKey, "100"))
        WidthStr = GetSetting(SAppName, SPreferencesSection, _
            SWidthKey, "")
        .Height = Val(GetSetting(SAppName, SPreferencesSection, _
            SHeightKey, "100"))
        StartFaceId = Val(GetSetting(SAppName, SPreferencesSection, _
            SStartFaceIdKey, "1"))
        If StartFaceId < FIRST_FACEID Then
            StartFaceId = FIRST_FACEID
        End If
        .Protection = msoBarNoCustomize
    End With
    Set Button = Toolbar.Controls.Add(Type:=msoControlButton)
    With Button
        .Caption = " About... "
        .Style = msoButtonCaption
        .Tag = BUTTON_ABOUT
        .BeginGroup = True
        .TooltipText = "Show information about the author"
        .OnAction = HostAppStr + "AboutFaceIdExplorer"
    End With
    Set Button = Toolbar.Controls.Add(Type:=msoControlButton)
    With Button
        .Caption = " « Previous "
        .Style = msoButtonCaption
        .Tag = BUTTON_PREVIOUS
        .Enabled = False
        .BeginGroup = True
        .TooltipText = "Previous 100 FaceIds"
        .OnAction = HostAppStr + "PreviousButtonClick"
    End With
    Set Button = Toolbar.Controls.Add(Type:=msoControlButton)
    With Button
        .Caption = " Next » "
        .Style = msoButtonCaption
        .Tag = BUTTON_NEXT
        .TooltipText = "Next 100 FaceIds"
        .OnAction = HostAppStr + "NextButtonClick"
    End With
    Begin = True
    TotalWidth = 0
    For i = 1 To 100
        Set Button = Toolbar.Controls.Add(Type:=msoControlButton)
        With Button
            TotalWidth = TotalWidth + .Width + 2
            .Tag = BUTTON_FACEID
            .BeginGroup = Begin
            If Begin Then
                Begin = False
            End If
        End With
    Next
    With Toolbar
        .Visible = False
        If Not (WidthStr = "") Then
            .Width = Val(WidthStr)
        Else
            .Width = TotalWidth / 10
        End If
        .Visible = Val(GetSetting(SAppName, SPreferencesSection, _
            SVisibilityKey, "1"))
    End With
End Sub
Sub AssignFaceId()
    Dim Toolbar As CommandBar
    Dim Button As CommandBarButton
    Dim i As Integer
    On Error Resume Next
    Set Toolbar = CommandBars(SFaceIdCommandBarName)
    i = StartFaceId
    For Each Button In Toolbar.Controls
        With Button
            If .Tag = BUTTON_FACEID Then
                .FaceId = i
                .TooltipText = "FaceId: " + Str(i)
                i = i + 1
            End If
        End With
    Next
End Sub
Sub SetPreviousButtonState()
    Dim Toolbar As CommandBar
    Dim Button As CommandBarButton
    On Error Resume Next
    Set Toolbar = CommandBars(SFaceIdCommandBarName)
    For Each Button In Toolbar.Controls
        With Button
            If .Tag = BUTTON_PREVIOUS Then
                If StartFaceId = FIRST_FACEID Then
                    .Enabled = False
                Else
                    .Enabled = True
                End If
                Exit For
            End If
        End With
    Next
End Sub
Sub PreviousButtonClick()
    StartFaceId = StartFaceId - 100
    If StartFaceId < FIRST_FACEID Then
        StartFaceId = FIRST_FACEID
    End If
    SetPreviousButtonState
    AssignFaceId
End Sub
Sub NextButtonClick()
    StartFaceId = StartFaceId + 100
    SetPreviousButtonState
    AssignFaceId
End Sub

Leave a Comment

Create Access Database via DAO

July 26, 2008 at 14:20 · Filed under VBA Examples ·Tagged , , , ,

by Selva V Pasupathy

Option Explicit
Private myMdbPath As String
Private myMDB As Database
Private myTableDef As TableDef
Private myIndex As DAO.Index

Sub Create_MDB()
    myMdbPath = ThisWorkbook.Path & "\" & _
                                myMDBName & ".mdb"
    If Dir(myMdbPath)  "" Then Kill myMdbPath

    Set myMDB = CreateDatabase(myMdbPath, dbLangGeneral)

    Set myTableDef = myMDB.CreateTableDef(MyTable)

    With myTableDef
        .Fields.Append .CreateField("ID", dbLong, 4)
        .Fields.Append .CreateField("ACCT", dbText, 14)
   .Fields.Append .CreateField("CII", dbText, 14)
   .Fields.Append .CreateField("STATUS", dbText)
   .Fields.Append .CreateField("DECISION", dbText)
   .Fields.Append .CreateField("RACF", dbText)
   .Fields.Append .CreateField("CONTRACTDATE", dbDate)
   .Fields.Append .CreateField("RECEIPTDATE", dbDate)
   .Fields.Append .CreateField("FOLLOWUPDATE", dbDate)
   .Fields.Append .CreateField("FOLLOWUP_N1", dbText)
   .Fields.Append .CreateField("FOLLOWUP_N2", dbText)
   .Fields.Append .CreateField("DECLIFE", dbText)
   .Fields.Append .CreateField("DECDIS", dbText)
   .Fields.Append .CreateField("REASON", dbText)
   .Fields.Append .CreateField("FIRSTNAME", dbText)
   .Fields.Append .CreateField("LASTNAME", dbText)
   .Fields.Append .CreateField("ADDLINE1", dbText)
   .Fields.Append .CreateField("ADDLINE2", dbText)
   .Fields.Append .CreateField("CITY", dbText)
   .Fields.Append .CreateField("ST", dbText, 2)
   .Fields.Append .CreateField("ZIP", dbText, 5)

   myTableDef("ID").Attributes = dbAutoIncrField

   Set myIndex = .CreateIndex("ACCT")
   myIndex.Fields.Append myIndex.CreateField("ID", dbLong)

        myIndex.Primary = True
        .Indexes.Append myIndex
    End With

    ' Save Table info
    myMDB.TableDefs.Append myTableDef
    myMDB.Close
End Sub

Private Function myMDBName()
myMDBName = Application.InputBox("Give " &amp: _
     the name of the " & _
     "Access file you want to be saved. ")
End Function
Private Function MyTable()
    MyTable = Application.InputBox("Give " & _
     the name of the " & _
     "Table you want in MDB file. ")
End Function

For more on Resources, Downloads, &
Tutorials visit following pages
http://selvavinaygam.googlepages.com
http://socko.350.com

For Feedback and/or comments, please mail me at
s o c k o (at) r e d i f f m a i l (dot) c o m

Leave a Comment

Older Posts »