Run a VB6.0 Executable from Excel/Word

Run an Executable from Excel VBA / Word VBA

If you need to use some grid for showing data / use the feautres in Visual Basic 6.0 that arenot available in VBA, you can create the application in VB6.0 or anyother program and show the User Interface in VBA code


Sub Run_VB6App_FromWord()

--- Some VBA Code here

sCmd = "C:\Program Files\MyFile.exe"
vntResult = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(sCmd, 1))
GetExitCodeProcess vntResult, lngExitCode

' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------

Do
GetExitCodeProcess vntResult, lngExitCode
DoEvents
Loop While lngExitCode = STILL_ACTIVE

--- some more VBA Code

End Sub


The above program will show the MyFile executable till the user clicks OK/Cancel. Once the application is closed the control will return to the calling VBA program

This used WinAPI Functions

Public Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

Now it depends on how you use the external application. The most often used scenario will be to store the output from the called application (External App) to Registry or Database

VBA Read Text Files (With Leading & Trailing Spaces)

Read Data frm Text Files (VBA)


Reading Text Files using VBA is one of the major development activity of programmers. There are multiple ways to read a file

1. Input # Statement
2. Input Function
3. Get Function
4. File System Object Functions


Input # Statement

Dim MyString, MyNumber
Open "c:\test.txt" For Input As #1 ' Open file for input.
Do While Not EOF(1) ' Loop until end of file.
Input #1, MyString, MyNumber ' Read data into two variables.
Debug.Print MyString, MyNumber ' Print data to the Immediate window.
Loop
Close #1 ' Close file.

However, the bug here is Input # does not take the leading or trailing spaces with it. That is, ' My Name is ' becomes 'My Name is'. This will not be the correct one as we need to get the spaces also

Then Input function comes handy

Dim MyChar
Open "c:\test.txt" For Input As #1    ' Open file.
Do While Not EOF(1)    ' Loop until end of file.
  MyChar = Input(1, #1)    ' Get one character.
  Debug.Print MyChar    ' Print to the Immediate window.
Loop
Close #1    ' Close file.

However, the bug here will be the input that one needs - the number of characters to be extracted.

The obvious option is File system object


Sub Read_text_File()

Dim oFSO As New FileSystemObject
Dim oFS


Set oFS = oFSO.OpenTextFile("c:\textfile.TXT")

Do Until oFS.AtEndOfStream
sText = oFS.ReadLine
Loop


End Sub

This will read line-by line. all you need to add the Microsoft Scripting Runtime in the reference

Happy reading files:)

Extract Procedure Names from all Modules - VBA

Count No of Programs in a Workbook

Workbooks have Macros, If you need to know if the Workbook contains macros and then the following proc will get you the macros in the workbook

Sub Extract_Program()

Dim VBP As VBProject
Dim VBModule As CodeModule
Dim VBProc As VBComponent
Dim sLastProcName As String
Dim arProcName() As String
Dim iProcCount As Integer

Set VBP = ThisWorkbook.VBProject

For Each VBM In VBP.VBComponents

Set VBModule = VBM.CodeModule

i = 1
Do Until i >= VBModule.CountOfLines

procname = VBModule.ProcOfLine(i, vbext_pk_Proc)
i = i + 1
If LenB(procname) <> 0 Then
If procname <> sLastProcName Then
iProcCount = iProcCount + 1
ReDim Preserve arProcName(iProcCount)
arProcName(iProcCount) = procname
sLastProcName = procname
End If
End If
Loop
Next

' List all procedures
For i = 1 To UBound(arProcName)
MsgBox arProcName(i)
Next i
End Sub

ColorIndex - Coloring Excel Sheet Cells

Highlight Color in Excel Cells

Colorindex is used to color the background of Excel Cells

Cells(1, 2).Interior.ColorIndex = 30

etc

Here is the entire list of colors you can use:






RSS Feeds Submission Directory

Excel VBA - Delete Empty Rows

Delete Rows without Values

Here is a primitive simple function to delete rows that does not contain any value (I have taken Cols 1 to 10) for consideration.

Sub Delete_UnWanted_Rows()

For Each SHT In Sheets
SHT.Activate
iMax = SHT.Cells.SpecialCells(xlCellTypeLastCell).Row
For i2 = 2 To iMax
For i1 = 1 To 10
If LenB(SHT.Cells(i2, i1)) <> 0 Then
GoTo TakeNextRow
End If
Next i1
SHT.Rows(i2).EntireRow.Delete
TakeNextRow:
Application.StatusBar = SHT.Name & " " & i2
Next i2
TakeNextSht:

Next SHT
Application.StatusBar = False
End Sub

You can do the same with Special Cells - LastCell also

Setting Default & Cancel Buttons in VBA/Visual Basic

VB/ VBA Setting Default & Cancel Buttons through code

Private Sub Form_Load()

'Sets cmdOK as the button control that is clicked when the user presses the Enter key.
cmdOK.Default = True

'Sets cmdCancel as the button control that is clicked when the user presses the ESC key.
cmdCancel.Cancel = True

End Sub

For doing the same in VB.Net Refer : http://dotnetdud.blogspot.com/2007/06/vbnet-setting-default-cancel-buttons.html

Assigning Shortcut Keys - Excel Macros

Shortcut Key Assignment for Subroutines


It is always nice to have keyboard shortcuts for executing functions/subroutines rather than having to click the menu and its command

One way will to link the macro to a command button and assign the shortcut for the button. The other one is to assign the shortcut to the function using Application.OnKey

OnKey method executes a specified procedure when a particular key or key combination is pressed

Application.OnKey "%b", "ToWord"

is used to trigger the "ToWord" subroutine whenever Alt+b is pressed . Percentage symbol is used to substitute Alt key

Use the Caret (^) to symbol for Ctrl key and plus (+) for Shiftkey

Application.OnKey "^b", "ToWord"

Is for Ctrl + b

Other keys are :

Key	Code
BACKSPACE	{BACKSPACE} or {BS}
BREAK	{BREAK}
CAPS LOCK	{CAPSLOCK}
CLEAR	{CLEAR}
DELETE or DEL	{DELETE} or {DEL}
DOWN ARROW	{DOWN}
END	{END}
ENTER (numeric keypad)	{ENTER}
ENTER	~ (tilde)
ESC	{ESCAPE} or {ESC}
HELP	{HELP}
HOME	{HOME}
INS	{INSERT}
LEFT ARROW	{LEFT}
NUM LOCK	{NUMLOCK}
PAGE DOWN	{PGDN}
PAGE UP	{PGUP}
RETURN	{RETURN}
RIGHT ARROW	{RIGHT}
SCROLL LOCK	{SCROLLLOCK}
TAB	{TAB}
UP ARROW	{UP}
F1 through F15	{F1} through {F15}

To deassign/release the shortcut leave the Procedure empty

Application.OnKey "%b", ""


Disable Save (Ctrl S)

Application.OnKey "^s", ""

Using Function Keys in Visual Basic Forms

Function keys as Shortcut Keys in VB
Function keys are a boon for assigning shortcuts. They have more advantage than the regular Alt + or Ctrl + combination.

Function keys can be assigned to command buttons using simple tricks as explained below. For that we need to instuct the VB to handle them in the Keydown event by setting the Keypreview = True




Then you can have the necessary shortcut keys on the form



In the Form_KeyDown event redirect to necessary functions/procs based on the key

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

Select Case KeyCode

Case vbKeyF2

Call Proc_Fund_Transfer

Case vbKeyF3

Call Proc_Credit_Card


End Select

End Sub

Save copy of the workbook

Sub Saving_A_Copy_Of_Workbook()

'Saves a copy of the workbook to a file but doesn't modify the open workbook in memory

Dim bAchievedTarget As Boolean

If bAchievedTarget = True Then
ActiveWorkbook.SaveCopyAs "c:\Completed\FinalCopy.xls"
End If

' This function can be used to take the copy of the file while working on it. The current file remains the same however

End Sub

See also :

Excel VBA - 1004 -- The file could not be accessed

Save and Reopen all Workbooks (Excel VBA)

Save copy of the workbook

SaveAs Dialog - Controlled Save

Save RTF document as word

Print Multiple Sheets using VBA

'VBA to Select Multiple Sheets
Sub Print_Selected_Sheets()

' Remove Multiple Selections
ActiveWorkbook.Sheets(1).Select

' Select Multiple Sheets - Optional False is to extend the current selection to include any previously selected objects and the specified object
ActiveWorkbook.Sheets(1).Select False
ActiveWorkbook.Sheets(2).Select False
ActiveWorkbook.Sheets(4).Select False

' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------


ActiveWindow.SelectedSheets.PrintOut Copies:=1

' Remove Multiple Selections
ActiveWorkbook.Sheets(1).Select

End Sub

VBA Dir Function to Get Sub Directories

Get Sub Directories using VBA Dir Function

The below function is used to get the immediate sub-directories for a given directory. If you want to dig deep into the directory structure then you need to iterate the sub-directories as well

Sub Get_All_SubDirectories()

Dim arSubDir() As String
Dim sSubDir As String

sSubDir = GetSubDir("d:\trash\")

' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------

If LenB(sSubDir) <> 0 Then
arSubDir = Split(sSubDir, ";")
For i1 = 0 To UBound(arSubDir)
Debug.Print arSubDir(i1)
Next i1
End If

End Sub


Function GetSubDir(ByVal sPath As String, Optional ByVal sPattern As Variant) As Variant

Dim sDir As String
Dim sDirLocationForText As String

On Error GoTo Err_Clk

If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"

If IsMissing(sPattern) Then
sDir = Dir$(sPath, vbDirectory)
Else
sDir = Dir$(sPath & sPattern, vbDirectory)
End If
' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------

Do Until LenB(sDir) = 0

' -----------------------------------------------------
' This will be the location for the sub directory
' -----------------------------------------------------
If sDir <> "." And sDir <> ".." Then
sDirLocationForText = sDirLocationForText & ";" & sPath & sDir
End If
sDir = Dir$

Loop

If Left$(sDirLocationForText, 1) = ";" Then sDirLocationForText = Right(sDirLocationForText, Len(sDirLocationForText) - 1)
GetSubDir = sDirLocationForText

Err_Clk:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Function

Insert Procedure to a Module Using VBComponents

Insert Procedure to a Module Using VBComponents

Sub Insert_PRocedure_To_BasModule()

' This program will need reference to Microsoft Visual Basic for Extensibility Library

Dim VBP As VBProject
Dim VBC As VBComponent
Dim VBMod As CodeModule

' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------
Workbooks.Add
Set VBP = ActiveWorkbook.VBProject

Set VBC = VBP.VBComponents.Add(vbext_ct_StdModule)
VBC.Name = "MyMacro"

Set VBMod = VBC.CodeModule

VBMod.InsertLines 3, "Sub NewProc()" & Chr(13) & _
" Msgbox ""Welcome to VB Component Programming"" " & Chr(13) & _
"End Sub"

End Sub

Dynamic Insertion of Procedure Bas Module, Dynamic Creation of Function / Procedure in BAS/Class Module, Automatic Creation of Function / Procedure in BAS/Class Module, Create New Module using VBA, VBA Create Module, VBA Attach Module to Workbook

Delete Module on the Fly using VBA

VBA Delete Bas Module / Class Modules


Sub Delete_BasModule_To_WorkBook()

' This program will need reference to Microsoft Visual Basic for Extensibility Library

Dim VBP As VBProject
Dim VBC As VBComponent
Dim VBMod As CodeModule

' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------
Set VBP = ActiveWorkbook.VBProject

Set VBC = VBP.VBComponents("MyMacro")

' Delete the module
ActiveWorkbook.VBProject.VBComponents.Remove VBC

End Sub

Dynamic Deletion of Bas Module, Dynamic Deletion of Bas Module, Automatic Deletion of Bas Module, Delete Module using VBA, VBA Delete Module, VBA Detach Module to Workbook

Insert User Form on the Fly

Automatic Creation of User Form


Sub Insert_Form_To_WorkBook()

' This program will need reference to Microsoft Visual Basic for Extensibility Library

Dim VBP As VBProject
Dim VBC As VBComponent
Dim VBMod As CodeModule

' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------
Workbooks.Add
Set VBP = ActiveWorkbook.VBProject

Set VBC = VBP.VBComponents.Add(vbext_ct_MSForm)
VBC.Name = "frmMyForm"

End Sub


Dynamic Insertion of User Form, Dynamic Creation of User Form, Automatic Creation of User Form, Dynamically Create New User Form using VBA, VBA Create Module, VBA Attach Module to Workbook

Insert Class Module on the Fly

Dynamic Insertion of Class Module


Sub Insert_Class_Module_To_WorkBook()

' This program will need reference to Microsoft Visual Basic for Extensibility Library

Dim VBP As VBProject
Dim VBC As VBComponent
Dim VBMod As CodeModule

' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------
Workbooks.Add
Set VBP = ActiveWorkbook.VBProject

Set VBC = VBP.VBComponents.Add(vbext_ct_ClassModule)
VBC.Name = "clsMyClass"

End Sub


Dynamic Insertion of Class Module, Dynamic Creation of Class Module, Automatic Creation of Class Module, Create New Module using VBA, VBA Create Module, VBA Attach Module to Workbook

Insert Module on the Fly

Dynamic Insertion of Bas Module using VBComponents

Many a times we need to create Workbook through program and add some code to the workbook. If the both workbook and code are standard and do not change, we could use some template. On the other hand, if your requirement has constantly changing workbook and a relatively unstable code you can't use templates.

You need to rely on the VBComponent programming to dynamically create the Module in the Workbook

Sub Insert_BasModule_To_WorkBook()

' This program will need reference to Microsoft Visual Basic for Extensibility Library

Dim VBP As VBProject
Dim VBC As VBComponent
Dim VBMod As CodeModule

' -----------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
' -----------------------------------------------------------
Workbooks.Add
Set VBP = ActiveWorkbook.VBProject

Set VBC = VBP.VBComponents.Add(vbext_ct_StdModule)
VBC.Name = "MyMacro"

End Sub

Dynamic Insertion of Bas Module, Dynamic Creation of Bas Module, Automatic Creation of Bas Module, Create New Module using VBA, VBA Create Module, VBA Attach Module to Workbook

Match Excel Column against a Standard Range

Replace Values of a Column when it Matches

If you want to match the names in column2 against the standard names in column 1 & replace by the standard names the following should help:

Sub Replace_TExt()


For i = 1 To ActiveSheet.Range("B:B").Cells.SpecialCells(xlCellTypeLastCell).Row

If Trim(ActiveSheet.Range("B" & i)) <> "" Then

ActiveSheet.Range("A:A").Replace What:=ActiveSheet.Range("B" & i), Replacement:=ActiveSheet.Range("B" & i).Value, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:= _
False, ReplaceFormat:=False

End If

Next i
End Sub

Dynamic Copy of Matching Excel Data

Copy specific data in cells from Master Sheet to Current Sheet

Most often we would have the entire data in Excel and would require data corresponding to the cell value taken from the master sheet and populated in the current one dynamically.

In the following example the master sheet is named as "DB" and contains all records with the primary key being the first column.

Function Snippet_For_Copy(sSearchString)

If Trim(sSearchString) = "" Then Exit Function

With Sheets("DB").Columns("A:A")
Set rFindCell = .Find(sSearchString, LookIn:=xlValues, LookAt:=xlWhole)
If Not rFindCell Is Nothing Then
Sheets("DB").Rows(rFindCell.Row).EntireRow.Copy _
Destination:=Range("A" & ActiveCell.Row)
End If
End With

End Function

If the user enters a data in the first column of the current sheet, the above function will check the data in the DB sheet and transfer entire row if a match is found

You can trigger the function using Worksheet_SelectionChange event

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If IsNumeric(Target) = False Then Exit Sub
If Trim(Target) = "" Then Exit Sub

Application.EnableEvents = False

Snippet_For_Copy Target.Value

Application.EnableEvents = True
End Sub

Add ToolTipText in CommandBar Controls

Display ToolTipText in CommandBar Controls

Sub Show_ToolTipText_In_Controls()


Dim oCB As CommandBar
Dim oCtl As CommandBarControl

On Error Resume Next

' Delete Existing Command Bar
CommandBars("MyProject").Delete

'Create New Command Bar
Set oCB = CommandBars.Add
oCB.Name = "MyProject"
oCB.AdaptiveMenu = True


Set oCtl = oCB.Controls.Add(Type:=msoControlButton)
oCtl.Caption = "Show Message Box"
oCtl.TooltipText = "This is a sample"
oCtl.OnAction = "Display_Msg_Box"
oCtl.SetFocus

' Show the Command Bar
oCB.Visible = True

' Place the CommandBar at the bottom of the screen
oCB.Position = msoBarBottom

End Sub

Sub Display_Msg_Box()

MsgBox "You have clicked me!!!"

End Sub

Add Combo Box to the command Bar

Add Combo Box to the command Bar

Sub Show_Combo_CommandBar()


Dim oCB As CommandBar
Dim oCtl As CommandBarComboBox

On Error Resume Next

'Delete Control From CommandBar
CommandBars("Sample Command Bar").Delete

Set oCB = CommandBars.Add
oCB.Name = "Sample Command Bar"
oCB.AdaptiveMenu = True

'Add Control to CommandBar
Set oCtl = oCB.Controls.Add(Type:=msoControlComboBox)
oCtl.Caption = "ComboSamp"

'Link Macro to CommandBar,
oCtl.OnAction = "Change_Header_Background"

'Add list Item to Combo Box Control
oCtl.AddItem "NoColor"
oCtl.AddItem "Blue"
oCtl.AddItem "Yellow"


' Show the Command Bar
oCB.Visible = True

' Place the CommandBar at the bottom of the screen
oCB.Position = msoBarBottom

End Sub

Sub Change_Header_Background()

' Acts based on the value in the Combo Box

Dim oCB As CommandBar
Dim oCtl As CommandBarComboBox

On Error Resume Next


Set oCB = CommandBars("Sample Command Bar")

Set oCtl = oCB.Controls("ComboSamp")

If oCtl.ListIndex <> -1 Then

Select Case oCtl.ListIndex

Case 1

ActiveSheet.Rows(1).Interior.ColorIndex = 0

Case 2

ActiveSheet.Rows(1).Interior.ColorIndex = 5

Case 3

ActiveSheet.Rows(1).Interior.ColorIndex = 36

Case Else

' Do nothing

End Select

End If


' Show the Command Bar
oCB.Visible = True

' Place the CommandBar at the bottom of the screen
oCB.Position = msoBarBottom


End Sub

Visual Basic Get Screen Area

Windows API Get Screen Area

Declare Function GetSystemMetrics Lib "user32" _
(ByVal nIndex As Long) As Long
Const SM_CXSCREEN As Long = 0
Const SM_CYSCREEN As Long = 1


Here is the VBA function using GetSystemMetrics to get the screen area

Sub Get_Screen_Metrics()

' Windows API Function to Get Screen Area

lx = GetSystemMetrics(SM_CXSCREEN)
ly = GetSystemMetrics(SM_CYSCREEN)

'--------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
'--------------------------------------------------------

MsgBox "The Screen Area is " & lx & " x " & ly & " pixels"

' Visual Basic Get Screen Area, Visual Basic Get Screen Height, Visual Basic Get Screen Width ,Windows API Get Screen Area, Windows API Get Screen Height, Windows API Get Screen Width
End Sub

Retrieve the file properties - VBA

Sub Get_WorkBook_Properties()

Dim oWB As Workbook

' Here is the program to retrieve the file properties.

Set oWB = ActiveWorkbook

'--------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
'--------------------------------------------------------

'Get the Title property
sTitle = oWB.BuiltinDocumentProperties("Title").Value

'Get the Subject property
sSubject = oWB.BuiltinDocumentProperties("Subject").Value

'Get the Author property
sAuthor = oWB.BuiltinDocumentProperties("Author").Value

'Get the Keywords property
sKeywords = oWB.BuiltinDocumentProperties("Keywords").Value

'Get the Comments property
sComments = oWB.BuiltinDocumentProperties("Comments").Value

'Get the Template property
sTemplate = oWB.BuiltinDocumentProperties("Template").Value

'Get the Last author property
sLastauthor = oWB.BuiltinDocumentProperties("Last author").Value

'Get the Revision number property
sRevisionnumber = oWB.BuiltinDocumentProperties("Revision number").Value

'Get the Application name property
sApplicationName = oWB.BuiltinDocumentProperties("Application name").Value

'Get the Last print date property
sLastprintdate = oWB.BuiltinDocumentProperties("Last print date").Value

'Get the Creation date property
sCreationdate = oWB.BuiltinDocumentProperties("Creation date").Value

'Get the Last save time property
sLastsavetime = oWB.BuiltinDocumentProperties("Last save time").Value

'Get the Total editing time property
sTotaleditingtime = oWB.BuiltinDocumentProperties("Total editing time").Value

'Get the Number of pages property
sNumberofpages = oWB.BuiltinDocumentProperties("Number of pages").Value

'Get the Number of words property
sNumberofwords = oWB.BuiltinDocumentProperties("Number of words").Value

'Get the Number of characters property
sNumberofcharacters = oWB.BuiltinDocumentProperties("Number of characters").Value

'Get the Security property
sSecurity = oWB.BuiltinDocumentProperties("Security").Value

'Get the Category property
sCategory = oWB.BuiltinDocumentProperties("Category").Value

'Get the Format property
sFormat = oWB.BuiltinDocumentProperties("Format").Value

'Get the Manager property
sManager = oWB.BuiltinDocumentProperties("Manager").Value

'Get the Company property
sCompany = oWB.BuiltinDocumentProperties("Company").Value

'Get the Number of bytes property
sNumberofbytes = oWB.BuiltinDocumentProperties("Number of bytes").Value

'Get the Number of lines property
sNumberoflines = oWB.BuiltinDocumentProperties("Number of lines").Value

'Get the Number of paragraphs property
sNumberofparagraphs = oWB.BuiltinDocumentProperties("Number of paragraphs").Value

'Get the Number of slides property
sNumberofslides = oWB.BuiltinDocumentProperties("Number of slides").Value

'Get the Number of notes property
sNumberofnotes = oWB.BuiltinDocumentProperties("Number of notes").Value

'Get the Number of hidden Slides property
sNumberofhiddenSlides = oWB.BuiltinDocumentProperties("Number of hidden Slides").Value

'Get the Number of multimedia clips property
sNumberofmultimediaclips = oWB.BuiltinDocumentProperties("Number of multimedia clips").Value

'Get the Hyperlink base property
sHyperlinkbase = oWB.BuiltinDocumentProperties("Hyperlink base").Value

'Get the Number of characters (with spaces) property
sNumberofcharacters = oWB.BuiltinDocumentProperties("Number of characters (with spaces)").Value

'keywords: VBA Update File Properties, Macro to Update File Properties

End Sub

Drag & DRop Files to Text Box

Show File Name in Text Box using Drag & Drop

Private Sub TextBox1_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i1 As Integer '* Files Counter

On Error GoTo Err_Trap

If Data.GetFormat(vbCFFiles) = True Then
i1 = Data.Files.Count
If i1 = 1 Then
If InStr(1, LCase$(Data.Files(i1)), ".xls") Then
txtExcel.Text = Data.Files(i1)
End If
End If
End If

' ------------------------------------------
' Error Handling
' ------------------------------------------
Err_Trap:
If Err <> 0 Then
Debug.Assert Err = 0
Err.Clear
End If
End Sub

This will be used to show the file name in the Text Box if a file is dragged and dropped into it

Automaticaly Resize Text Boxes

Resizing Text Boxes

Sub Initialize_TextBox()

' To automatically resize the text box set the AutoSize to True. This will resize the text box as the user types text

TextBox1.AutoSize = True

' The sizing can be limited by providing the maximum length using MaxLength property

TextBox1.MaxLength = 20

' You can inform the user of resing with the Tooltip.

TextBox1.ControlTipText = "Maximum Length is 20"

End Sub

ControlTipText is the VBA variant for Visual Basic ToolTipText

Primitive File Handling Functions

Copying Files/ Deleting Files / Moving Files

Sub Moving_Files()

Dim oFS As FileSystemObject

' Copying Files
FileCopy "c:\temp\IamAStar.xls", "c:\temp\backup\IamAStar.xls"

' Deleting Files
Kill "c:\temp\IamAStar.xls"

' Using File System Object - You need to Include Microsoft Scripting Runtime in you references
Set oFS = New FileSystemObject

' Moving Files
oFS.MoveFile "c:\temp\D8C7I12.xls", "c:\temp\backup\D8C7I12.xls"

End Sub

Check Workbook Attributes

Get File Attributes - GetAttr

Sub Check_Workbook_Attributes()

Dim oXL As Excel.Application
Dim oWB As Workbook

Set oXL = Excel.Application

oXL.DisplayAlerts = False

' Check if the Workbook is Read-Only. If it is then close the workbbok

Set oWB = oXL.Workbooks.Open(Filename:="c:\MyBook.xls", ReadOnly:=False)

If oWB.ReadOnly = True Then
MsgBox "The Workbook is Read-Only!!", vbInformation
oWB.Close False
End If

oXL.DisplayAlerts = True

' Using the GetAttr Function, WE can check if the file is read-only
If (GetAttr("c:\MyBook.xls") And vbReadOnly) Then
MsgBox "The Workbook is Read-Only!!", vbInformation
End If

End Sub

The GetAttr function will work if the file has read-only attributes. If the file is locked and hence it is available as read only this will not be useful

Validate Dates

Validate Date between Ranges

Sub Feed_Check_Date_Function()

' Date is within the Valid Range
Check_Date "2007-05-01", "2007-05-10", "2007-05-01"

' Date is NOT within the Valid Range
Check_Date "2007-05-01", "2007-05-10", "2007-05-21"


End Sub

Function Check_Date(ByVal StartDate As Date, ByVal EndDate As Date, ByVal DateTobeChecked As Date)

If DateDiff("d", StartDate, DateTobeChecked) <> 0 Then
MsgBox "Enter a correct date!!!"
End If

End Function

Run Macro on Image Click

Tag Macro to an Image

Sub Run_Macro_On_ImageClick()

Dim sht As Worksheet
Dim shp As Shape

' Use OnAction Property to set the macro that needs to be run when the image is clicked

Set sht = ActiveSheet

Set shp = sht.Shapes(1)

shp.OnAction = "Macro1"

End Sub

Changing File Attributes

SetAttr Function - Modifying File Atrributes

Sub Changing_File_Attributes()

' Using the SetAttr Function, We can set the file as read-only or hidden etc

' Make the file Read-Only
SetAttr "c:\temp\Sample.txt", vbReadOnly

' Make the file Hidden
SetAttr "c:\temp\Sample.txt", vbHidden

' Please note that if you change one attribute, the existing attribute is overwritten. For making a file as both readonly and hidden use both attributes in the function
SetAttr "c:\temp\Sample.txt", vbHidden + vbReadOnly

' Remove all atributes - convert a read-only file to read-write file, unhide the file etc
SetAttr "c:\temp\Sample.txt", vbNormal

End Sub

Choose the Right Value

VBA - Choose Function

Sub Easy_To_Choose()

Dim iGroupCode As Integer
Dim sGroupName As String

iGroupCode = 1

If iGroupCode = 1 Then
sGroupName = "Blue"
ElseIf iGroupCode = 2 Then
sGroupName = "Green"
ElseIf iGroupCode = 3 Then
sGroupName = "Yellow"
ElseIf iGroupCode = 3 Then
sGroupName = "Red"
End If


Select Case iGroupCode
Case 1
sGroupName = "Blue"
Case 2
sGroupName = "Green"
Case 3
sGroupName = "Yellow"
Case 3
sGroupName = "Red"
End Select


' Choose Function does the same as that of Select Case or the If constructs
' But the Choose function returns a Null if index is less than 1 or greater than the number of choices listed.
iGroupCode = 2
sGroupName = Choose(iGroupCode, "Blue", "Green", "Yellow", "Red")

End Sub

You can store the values in the array and can pass that to the choose function

Flip Shapes

Rotate Images - Flip Images

Sub Flip_Shapes()

Dim sht As Worksheet
Dim shp As Shape

' Flip the Image - Turn the Image Upside Down

Set sht = ActiveSheet

Set shp = sht.Shapes(1)

shp.Flip msoFlipVertical

End Sub

Environmental Variables using VBA

Get OS Name / Get Windows Directory

Sub Environ_Vars()

' Get Environmental Variables using VBA

' Get the LOGON SERVER
sLOGONSERVER = Environ("LOGONSERVER")

' No of processors using VBA
sNUMBER_OF_PROCESSORS = Environ("NUMBER_OF_PROCESSORS")

' Get the Operating System using VBA
sOS = Environ("OS")

' Get the USER DOMAIN using VBA
sUSERDOMAIN = Environ("USERDOMAIN")

' Get the Windows Directory using VBA
swindir = Environ("windir")

End Sub

Format Images

Format Images - Change Size of Images

Sub Format_Image_In_Excel()

Dim sht As Worksheet
Dim shp As Shape

' Reduce the Height and Width of the Image by Half

For Each sht In Sheets

For Each shp In sht.Shapes

shp.Height = shp.Height / 2
shp.Width = shp.Width / 2
Next

Next sht

End Sub

Compare Files by Date

Function to Find the Latest File


Sub Exec_Get_Latest_File()

File1 = "c:\temp\Sample.txt"
File2 = "c:\temp\Sample1.txt"

MsgBox "The LatestFile is " & Get_Latest_File(File1, File2)

End Sub

Function Get_Latest_File(ByVal sFile1 As String, ByVal sFile2 As String) As String


Dim DateFile1 As Date
Dim DateFile2 As Date

DateFile1 = FileDateTime(sFile1)
DateFile2 = FileDateTime(sFile2)

If DateDiff("s", DateFile1, DateFile2) = 0 Then
Get_Latest_File = "Both Files are Modified at the same time"
ElseIf DateDiff("s", DateFile1, DateFile2) <>
Get_Latest_File = sFile1
Else
Get_Latest_File = sFile2
End If

End Function

Find Image Range - Excel

Format Images - Range of Image

Sub Find_Image_Range_In_Excel()

Dim sht As Worksheet
Dim shp As Shape

For Each sht In Sheets

For Each shp In sht.Shapes
MsgBox "Shape Extends from ( " _
& shp.TopLeftCell.Row & "," & shp.TopLeftCell.Column & ") to (" _
& shp.BottomRightCell.Row & "," & shp.BottomRightCell.Column & ")"
Next

Next sht

End Sub

Get the File Size

File Size - VBA Function

Sub Get_File_Size()

File1 = "c:\temp\Sample.txt"

MsgBox "The Size of the File is " & FileLen(File1) & " bytes"

End Sub

Removing Pictures from Spreadsheet

Delete Images from Spreadsheets

Sub Delete_Images_From_Excel()

Dim sht As Worksheet
Dim shp As Shape

For Each sht In Sheets

For Each shp In sht.Shapes
shp.Delete
Next

Next sht

End Sub

Filtering Array Elements

Filtering Array Elements

Most often there will be a neccesity to filter content from the Array. Filter Function comes as a blessing:

Sub Get_Filtered_Array()

Dim arOriginal(0 To 4) As String
Dim arFiltered() As String

arOriginal(0) = "Bob Woolmer"
arOriginal(1) = "Dean Jones"
arOriginal(2) = "Bob Richards"
arOriginal(3) = "Ravi Shastri"
arOriginal(4) = "Greg Chappel"

' Filtered Array will contain strings that contains Bob in it
arFiltered = Filter(arOriginal, "Bob")

' Filter - Returns a zero-based array containing subset of a string array based on a specified filter criteria.
End Sub

If no matches of Bob are found within arOriginal, Filter returns an empty array. An error occurs if arOriginal is Null or is not a one-dimensional array.

The array returned by the Filter function contains only enough elements to contain the number of matched items.

Visual Basic Command Line Arguments

Retrieve Command Line Arguments from a Microsoft Visual Basic or an executable program developed with Visual Basic from Command Line

Sub Command_Line_Call()

sCmdText = Trim$(Command$)

' You can give multiple parameters through command line with specific delimiters

arCmdData = Split(sCmdText, ",")
If arCmdData(0) = "PRG1" Then
Exec_PRG1 (arCmdData(1))
ElseIf arCmdData(0) = "PRG2" Then
Exec_PRG2 (arCmdData(1))
If arCmdData(0) = "PRG3" Then
Exec_PRG3 (arCmdData(1))
End If


End Sub

' Retrieve Command Line Arguments, Launch PRogram from command, Execute Visual Basic Program from Command Line

Get Computer Name

Get Computer Name / Get User Name

Environ$ can be used to retrieve information from an operating system environment variable

Sub Get_Environmental_Variable()

Dim sHostName As String
Dim sUserName As String

' Get Host Name / Get Computer Name

sHostName = Environ$("computername")

' Get Current User Name

sUserName = Environ$("username")


End Sub

In Dot Net it can be achieved by http://dotnetdud.blogspot.com/2007/06/get-computer-name-in-net.html

and

http://dotnetdud.blogspot.com/2007/06/aspnet-get-user-net-get-user.html

Improve Macro Performance

Increase Macro Speed

Sub Speed_Up_Performance()

Set_Performance_Options

' Use Early Binding Instead of late binding

' Do not use Variant if you can use Long, String data types

' If you want to loop through the documents/workbooks use For each
For Each Doc In Documents
' Do something
Next Doc

ReSet_Performance_Options

End Sub



Function Set_Performance_Options()

' If an updated cell value is necessary for the macro. Then either do not use this or used forced calculation using calculate method
Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False

End Function

Function ReSet_Performance_Options()

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Function

' ScreenUpdating, Calculation, Early Binding, late binding, Speedup VBA Performance, Optimize VBA Code, Visual Basic Code Optimization

Generic Function to Check if Application is Running

Check if Instance of Application is Running


' Change the sApp Variable to check the Application you needed



Sub Check_If_Application_Is_Open()

'Check if Instance of MS Word is Running in the machine

sApp = "Word.Application"
If IsAppRunning(sApp) = True Then
MsgBox "Application is Running"
Else
MsgBox "Application is NOT Running. Let me create my own"
' Create a new instance
Set oApp = CreateObject(, sApp)
End If


End Sub

' Generalized Function to Check if an Instance of Application is running in the machine
Function IsAppRunning(ByVal sAppName) As Boolean
Dim oApp As Object
On Error Resume Next
Set oApp = GetObject(, sAppName)
If Not oApp Is Nothing Then
Set oApp = Nothing
IsAppRunning = True
End If
End Function

' Generic Function to Check if Application is Running, Visual Basic GetObject, VBA GetObject, VB6 GetObject

VBA Function to Check File Existence

This Visual Basic Function can be used to check if a file exists under a specific directory

Sub Check_If_File_Exists()

' To Check if a file is present, give the file name and omit the second argument
sFile = "c:\Temp\Test.txt"
If File_Exists(sFile) = True Then
MsgBox sFile & " exist"
Else
MsgBox sFile & " does not exist"
End If

' To Check if a directory is present, give the directory name and make the second argument = True
sDir = "d:\VBADudExamples\Code"
If File_Exists(sDir, True) = True Then
MsgBox "Directory " & sDir & " exist"
Else
MsgBox "Directory " & sDir & " does not exist"
End If


End Sub
' Keywords : Check Directory Existence, VBA Dir Function, Visual Basic Dir Function, Dir$ Function Example, VB File Exists, VBA Check File Availability


Private Function File_Exists(ByVal sPathName As String, Optional Directory As Boolean) As Boolean

'Returns True if the passed sPathName exist
'Otherwise returns False
On Error Resume Next
If sPathName <> "" Then

If IsMissing(Directory) Or Directory = False Then

File_Exists = (Dir$(sPathName) <> "")
Else

File_Exists = (Dir$(sPathName, vbDirectory) <> "")
End If

End If
End Function

BlogRankings.com

All-Blogs.net directory

Visual Basic Function to Get Temporary Folder

Windows API Function to Get Temporary Folder

Private Declare Function GetTempPath Lib "kernel32" Alias _
"GetTempPathA" (ByVal nBufferLength As Long, ByVal _
lpBuffer As String) As Long

Const MAX_PATH = 260

' This function uses Windows API GetTempPath to get the temporary folder

Sub Get_Temporary_Folder()

sTempFolder = GetTmpPath

End Sub

' Keywords: Get Temporary Folder, Temporary Folder Visual Basic Code, VB Function Get Temp Folder, VBA Temporary Folder, VB6 Temporary Folder, GetTempPath, Windows API Functions


Private Function GetTmpPath()

Dim sFolder As String ' Name of the folder
Dim lRet As Long ' Return Value

sFolder = String(MAX_PATH, 0)
lRet = GetTempPath(MAX_PATH, sFolder)

If lRet <> 0 Then
GetTmpPath = Left(sFolder, InStr(sFolder, _
Chr(0)) - 1)
Else
GetTmpPath = vbNullString
End If

End Function

This function can be used to identify the Temporary folders for Windows XP kind of OS, where each login will have its own temp folder

VBA Email Automation / VBA Mail Automation

VBA Email Automation / VBA Mail Automation

Sub Send_Mail_From_Excel()


' This is an automatic mail program. It takes the mail Id's from activeworkbook and uses outlook object to send mail
' The format of the workbook should be as follows
' 1. Data Should start from Row 2 - Sheet 1
' 2. Salutation in Col 1 -e.g., Mr, Ms, Dr etc
' 3. Name in Col 2 -e.g., Sheetal
' 4. Email in Col 4 -e.g., sheetal@vbadud.com
' Program will loop through the entire sheet and send mails to all


Dim oXlWkBk As Excel.Workbook ' Excel Work Book Object

Dim oOLApp As Outlook.Application
Dim oOLMail As MailItem

Dim lRow As Long
Dim olMailItem

Dim sMailID As String
Dim sSalutation As String
Dim sName As String
Dim sDetails As String
Dim sSubject As String
On Error GoTo Err_Trap


Set oXlWkBk = ActiveWorkbook

If oXlWkBk.Sheets(1).Cells.SpecialCells(xlCellTypeLastCell).Row < oolapp =" New" lrow =" 2" oolmail =" oOLApp.CreateItem(olMailItem)" ssalutation =" oXlWkBk.Sheets(1).Cells(lRow," sname =" oXlWkBk.Sheets(1).Cells(lRow," sdetails = "Hi"> 0 And LenB(Trim$(sSalutation)) <> 0) Then
sDetails = sSalutation & " " & sName
ElseIf LenB(Trim$(sName)) <> 0 Then
sDetails = sName
Else
sDetails = "Hi"
End If
sDetails = sDetails & vbNewLine & vbNewLine

sMailID = Trim$(oXlWkBk.Sheets(1).Cells(lRow, 3).Value)

' --- Validate EMail ID
If InStr(1, sMailID, "@") = 0 Then
GoTo TakeNextRow
End If

' Create Mail
With oOLMail
.To = sMailID
.Subject = sSubject
.Body = sDetails & "This is a test mail from VBA Tips & Tricks (http://vbadud.blogspot.com/)"
End With

oOLMail.Send

TakeNextRow:
Next lRow

oXlWkBk.Close (False)

'--------------------------------------------------------
' Coded by Shasur for http://vbadud.blogspot.com
'--------------------------------------------------------


Destroy_Objects:
'Destroy Objects
If Not oOLApp Is Nothing Then Set oOLApp = Nothing


Err_Trap:
' Error Handling
If Err <> 0 Then
MsgBox Err.Description, vbInformation, "VBADUD AutoMail"
Err.Clear
GoTo Destroy_Objects
End If

'------------------------------------------------------------------------------------
' Disclaimer: VBA Tips & Tricks (http://vbadud.blogspot.com) publishes this content
' for the intention of sharing technical knowledge. Any misuse of this program (e.g., spamming)
' will not be our responsibility.
'------------------------------------------------------------------------------------


End Sub


'Keywords: 'Keywords: Automate Email, VBA Email, Send Email from Excel, VBA Mail automation, Mail Automation, Outlook VBA, Automate Outlook, Send Mail from Outlook, Link Excel with Outlook,Microsoft Outlook Mail Automation, Excel VBA Mail, MAPI, Send Multiple eMails





If you want to try the same using Lotus Notes refer http://vbadud.blogspot.com/2007/10/automate-lotus-notes-email-using-visual.html

SaveAs Dialog - Controlled Save

SaveAs Dialog - Controlled Save



Sub Save_File_Dialog()

Dim sFName

' Can be used as Excel SaveAs Dialog

'----------------------------
' Coded for http://vbadud.blogspot.com
'----------------------------


sFName = Application.GetSaveAsFilename
If sFName = False Then
MsgBox "Enter a File Name Please!!!"
End If

' Display Default FileName in the SaveAs Dialog/Save Dialog Box
sFName = Application.GetSaveAsFilename("VBADud_Example.xls")

' Force File Type during Save
sFName = Application.GetSaveAsFilename("VBADud_Example.xls", "Excel files (*.xls), *.xls")


End Sub

This method displays the standard Save As dialog box and gets a file name from the user without actually saving any files

This does not save the file...


See also :

Excel VBA - 1004 -- The file could not be accessed

Save and Reopen all Workbooks (Excel VBA)

Save copy of the workbook

SaveAs Dialog - Controlled Save

Save RTF document as word

Open Excel Files - Open Dialog - GetOpenFilename Method

Open Excel Files - Open Dialog - GetOpenFilename Method


The GetOpenFilename Method is a cousin to the CommonDialog. Some of the CommonDialog's tasks can he done with this method



GetOpenFilename Method (Displays the standard Open dialog box and gets a file name from the user without actually opening any files.)


Sub Open_Excel_File_Thru_VBA()

'----------------------------
' Coded for http://vbadud.blogspot.com
'----------------------------

Dim arTemp() As Variant

Dim lRet

On Error GoTo Err_Clr

'Default method Uses Open Dialog To Show the Files
lRet = Application.GetOpenFilename

'Select Only Excel Files - One File at A Time
lRet = Application.GetOpenFilename("Excel files (*.xls), *.xls")
If lRet = False Then
MsgBox "Select a File Please!!!"
End If

'Select Multiple Files - Get Multiple Files as Input
' An array can be used to get the multiple excel files selected by user
arTemp = Application.GetOpenFilename(FileFilter:="Excel files (*.xls), *.xls", MultiSelect:=True)
If UBound(arTemp) = 0 Then
MsgBox "Select a File Please!!!"
End If


Err_Clr:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Sub



Excel VBA, GetOpenFilename Method, Show Dialog, , Show Open Dialog Box

Browse a Folder / Select a Folder Thru Shell

Browse a Folder / Select a Folder Thru Shell

Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

'API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Here let us use the above shell functions to open the browse directory dialog

Sub Show_BrowseDirectory_Dialog()

' BrowseForFolder
' SHBrowseForFolder API Function Example

Dim dirInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer

' Set Default Root folder = Desktop
dirInfo.pidlRoot = 0&

dirInfo.lpszTitle = "Browse directory!"

' Type of directory
dirInfo.ulFlags = &H1

' Show the Browse Dialog
x = SHBrowseForFolder(dirInfo)

' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
MsgBox "You have selected :=" & Left(path, pos - 1)
Else
MsgBox "Browse a Directory..."
Show_BrowseDirectory_Dialog
End If

End Sub

SHBrowseForFolder Function displays a dialog box enabling the user to select a Shell folder

Add Controls To Tools Menu

Creating Custom Office Menus and Toolbars

Sub Call_Add_Control_To_ToolsMenu()

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------
Add_Control_To_ToolsMenu "Sample", "Donot_Fire_Events"

End Sub

you need to have a sub Donot_Fire_Events to test this

Function Add_Control_To_ToolsMenu(ByVal sControlName As String, ByVal sMacroName As String)

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

On Error GoTo DisplayErr

Dim ctlMenu As CommandBarControl
Dim ctlCommand As CommandBarControl

Set ctlMenu = Application.CommandBars.FindControl(ID:=30007)

If ctlMenu Is Nothing Then Exit Function

Set ctlCommand = ctlMenu.Controls.Add
ctlCommand.Caption = sControlName
ctlCommand.OnAction = sMacroName

DisplayErr:
If Err <> 0 Then
MsgBox Err.Description
Err.Clear
End If


Creating Custom Office Menus and Toolbars, Programming Microsoft Office Command Bars, CommandBars Property, Creating an Excel Add-in, Disable command bars and controls, Change the availability for the CommandBars using VBA, Delete/ hide a custom command bar

Add a new menu item to the Tools menu, Adding Menu Items, Add Command to Tools menu, Dynamic Addition of command to tools menu. Adding Command Button to Tools, Adding to Tools menu


End Function

Deleting Custom Office Menus and Toolbars

Deleting Custom Office Menus and Toolbars

Function delete_Control_from_ToolsMenu(ByVal sControlName As String)

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

On Error GoTo DisplayErr

Dim ctlMenu As CommandBarControl
Dim ctlCommand As CommandBarControl

Set ctlMenu = Application.CommandBars.FindControl(ID:=30007)

If ctlMenu Is Nothing Then Exit Function

Set ctlCommand = ctlMenu.Controls(sControlName)

If Not ctlCommand Is Nothing Then ctlCommand.Delete

DisplayErr:
If Err <> 0 Then
MsgBox Err.Description
Err.Clear
End If

End Function

Creating Custom Office Menus and Toolbars, Programming Microsoft Office Command Bars, CommandBars Property, Creating an Excel Add-in, Disable command bars and controls, Change the availability for the CommandBars using VBA, Delete/ hide a custom command bar

enable popup menu

Sub Enable_Right_Click()

You can use the following function to enable mouse click - Right Click

This will enable popup menu



' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

' This will enable mouse right click on worksheets

Application.CommandBars("Cell").Enabled = True

End Sub

Disable Right Click

You can use the following function to disable mouse click. Right Click

This will disable popup menu

Sub Disable_Right_Click()

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

' This will disable mouse right click on worksheets

Application.CommandBars("Cell").Enabled = False

End Sub


D

Add Control To PopupMenu

Add Control To PopupMenu

Use this function to add the control to the popup menu

Function Add_Control_To_PopupMenu(ByVal sControlName As String, ByVal sMacroName As String)

On Error GoTo DisplayErr

Dim ctlCB As CommandBar
Dim ctlMenu As CommandBarControl
Dim ctlCommand As CommandBarControl

Set ctlCB = Application.CommandBars("Cell")

If ctlCB Is Nothing Then Exit Function

Set ctlCommand = ctlCB.Controls.Add
ctlCommand.Caption = sControlName
ctlCommand.OnAction = sMacroName

DisplayErr:
If Err <> 0 Then
MsgBox Err.Description
Err.Clear
End If


'Creating Custom Office Menus and Toolbars, Programming Microsoft Office Command Bars, CommandBars Property, Creating an Excel Add-in, Disable command bars and controls, Change the availability for the CommandBars using VBA, Delete/ hide a custom command bar

End Function
Sub Call_Add_Control_To_PopupMenu()

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

Add_Control_To_PopupMenu "Sample", "Donot_Fire_Events"

End Sub

Add a new menu item to the Popup menu, Adding Menu Items, Add Command to Popup menu, , Dynamic Addition of command to Popup menu. Adding Command Button to Popup, Adding to Popup menu

Delete Control From PopupMenu

Delete Control From PopupMenu (Right Click Menu)

Function Delete_Control_From_PopupMenu(ByVal sControlName As String, ByVal sMacroName As String)

On Error GoTo DisplayErr

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

Dim ctlCB As CommandBar
Dim ctlCommand As CommandBarControl

Set ctlCB = Application.CommandBars("Cell")

If ctlCB Is Nothing Then Exit Function

Set ctlCommand = ctlCB.Controls(sControlName)

If Not ctlCommand Is Nothing Then ctlCommand.Delete

DisplayErr:
If Err <> 0 Then
MsgBox Err.Description
Err.Clear
Resume Next
End If


'Creating Custom Office Menus and Toolbars, Programming Microsoft Office Command Bars, CommandBars Property, Creating an Excel Add-in, Disable command bars and controls, Change the availability for the CommandBars using VBA, Delete/ hide a custom command bar

End Function
Sub Call_Delete_Control_From_PopupMenu()

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

Delete_Control_From_PopupMenu "Sample", "Donot_Fire_Events"

End Sub

Add a new menu item to the Tools menu, Adding Menu Items, Add Command to Tools menu, , Dynamic Addition of command to tools menu. Adding Command Button to Tools, Adding to Tools menu

Using VBA's IsError Function

' Using VBA's IsError Function
For Each c1 In ActiveSheet.UsedRange

If IsError(c1) Then
' Coded By Shasur

MsgBox "Error in " & c1.Address

End If
Next

End Sub

Excel Dialog Sheets

Here you have Kathy (and all programmers who need to work on the legacy Excel VBA code). Dialog sheets

Sub The_Good_Old_Dialog_Boxes()

ActiveDialog.Focus = "EditBox1"

Application.ThisWorkbook.DialogSheets("Dialog1").Buttons("cmdOK").Enabled = False

ActiveDialog.EditBoxes("EditBox1").Text = vbNullString

End Sub

Insert Dialog Sheet

' Ha ha .. If you haven't used dialog sheets before and wanted to have a feel on it, here we go

Sub Insert_Dialog_Sheet()

ActiveWorkbook.Sheets.Add Type:=xlDialogSheet

End Sub

You will find the sheet getting transformed to a Grid and a userform like control - the dialog sheet. The dialog sheets have been replaced by UserForms in Excel 97

Case in-sensitive comparison

Option Compare Text

If you do not worry about the case in comparisons, then use the Option Compare Text for string comparisons based on a case-insensitive text sort order determined by system's locale
Warning: This cannot be set for procedure level. When set, this will be for the entire module

Sub Option_Compare_Statement_Example()


Dim sStr1 As String ' String 1
Dim sStr2 As String ' String 2

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

sStr1 = "MixedCase"
sStr2 = "mixedcase"


If InStr(1, sStr1, sStr2) Then
MsgBox "Matching!!!"
End If

' ---------------------------------------------------------------
'
' ---------------------------------------------------------------

End Sub

Option Compare Text

If you do not worry about the case in comparisons, then use the Option Compare Text for string comparisons based on a case-insensitive text sort order determined by system's locale
Warning: This cannot be set for procedure level. When set, this will be for the entire module

Sub Option_Compare_Statement_Example()


Dim sStr1 As String ' String 1
Dim sStr2 As String ' String 2

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

sStr1 = "MixedCase"
sStr2 = "mixedcase"


If InStr(1, sStr1, sStr2) Then
MsgBox "Matching!!!"
End If

' ---------------------------------------------------------------
'
' ---------------------------------------------------------------

End Sub

Delete Temporary Files

Sub Delete_Temp_Files_Primitive()

Dim sFileType As String ' Declare the Type of File
Dim sTempDir As String ' Temporary Directory

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

On Error Resume Next

sFileType = "*.tmp"
sTempDir = "c:\windows\Temp\" ' There might be mutiple temp directories (one for each profile) in Windows XP. Modify the code accordingly

Kill sTempDir & sFileType

' ---------------------------------------------------------------
' Delete Temporary Files, Excel VBA, Kill Statement
' ---------------------------------------------------------------

End Sub

Aligning Text Output in Variables

Formatting Report - Formatting Text Files

Sub Aligning_Text_In_Variables()

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

' Aligment of Text in Reports is a pain.. that too if the report is a flat file

' Here are a couple of ways to align

Dim sCharBuff As String
Dim sName As String
Dim sAge As String
Dim sAdd As String
Dim sPrint As String

' Left Alignment
' Example
' Name :
' Age :
' Address :


sCharBuff = "123456789123456789" ' Just for length
sName = "Name"
sAge = "Age"
sAdd = "Address"

sPrint = sCharBuff
LSet sPrint = sName
Debug.Print sPrint & ":"

sPrint = sCharBuff
LSet sPrint = sAge
Debug.Print sPrint & ":"

sPrint = sCharBuff
LSet sPrint = sAdd
Debug.Print sPrint & ":"

' Right Alignment
' Example
' Name:
' Age:
' Address:


sCharBuff = "123456789123456789" ' Just for length
sName = "Name"
sAge = "Age"
sAdd = "Address"

sPrint = sCharBuff
RSet sPrint = sName
Debug.Print sPrint & ":"

sPrint = sCharBuff
RSet sPrint = sAge
Debug.Print sPrint & ":"

sPrint = sCharBuff
RSet sPrint = sAdd
Debug.Print sPrint & ":"


' ---------------------------------------------------------------
' Aligning Text Output in Variables
' ---------------------------------------------------------------


End Sub

Moving Log Files

Sub Naming_Files()

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------
' Programmers use log files to updated the status of the process
' Depending on the output the files are renamed or moved
' Here is a simple function to move and rename files


Name "d:\VBADudExamples\InProgress\Process.log" As "d:\VBADudExamples\Completed\Completed.log"


' ---------------------------------------------------------------
' Moving Log Files, Creating Log Files, Excel VBA, Name Statement
' ---------------------------------------------------------------


End Sub

Run-time Error 55!!! File already open

Run-time Error 55 File already open. This is one of the common error in file handling. It is difficult to avoid if you handle multiple files and use direct file numbers


Sub TextFile_Write_Error()

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------
'


' ------------------------
' Code with Errors
' ------------------------
Open "d:\VBADudExamples\TextFile1.txt" For Output As #1 ' Open file for output.

Print #1, "TextFile1"

Open "d:\VBADudExamples\TextFile2.txt" For Output As #1 ' Open file for output.

Close #1 ' Close file.

Close #1 ' Close file.

' ------------------------
' Workaround for the Errors
' ------------------------
' Use FreeFile to get a file number that is not used

iF1 = FreeFile ' Returns an Integer representing the next file number available for use by the Open statement.
Open "d:\VBADudExamples\TextFile1.txt" For Output As #iF1 ' Open file for output.

Print #iF1, "TextFile1"

iF2 = FreeFile
Open "d:\VBADudExamples\TextFile2.txt" For Output As #iF2 ' Open file for output.

Close #iF2 ' Close file.

Close #iF1 ' Close file.


' ------------------------------------------------
' Excel VBA, Run-time Error 55, File already open
' ------------------------------------------------


End Sub

Spacing in Text Files

Formatting Report , Formatting Text Files, Aligning Text File

For a Neatly Spaced Text File:

Sub EquiSpaced_TextFile()

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

Dim iMaxLength As Integer

iMaxLength = 20

Open "d:\VBADudExamples\TabbedFile.txt" For Output As #1 ' Open file for output.

Print #1, "Name "; Tab(iMaxLength); "Santhosh Prabhakaran"
Print #1, "Place "; Tab(iMaxLength); "Madras"
Print #1, "Designation "; Tab(iMaxLength); "Admin Manager"

Close #1 ' Close file.

' Excel VBA, Write to Text File, Neatly Spaced Text File


End Sub

Get Variable Type

To know the data type of the variable:

Function Get_Variable_Type(myVar)

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

If VarType(myVar) = vbNull Then
MsgBox "Null (no valid data) "
ElseIf VarType(myVar) = vbInteger Then
MsgBox "Integer "
ElseIf VarType(myVar) = vbLong Then
MsgBox "Long integer "
ElseIf VarType(myVar) = vbSingle Then
MsgBox "Single-precision floating-point number "
ElseIf VarType(myVar) = vbDouble Then
MsgBox "Double-precision floating-point number "
ElseIf VarType(myVar) = vbCurrency Then
MsgBox "Currency value "
ElseIf VarType(myVar) = vbDate Then
MsgBox "Date value "
ElseIf VarType(myVar) = vbString Then
MsgBox "String "
ElseIf VarType(myVar) = vbObject Then
MsgBox "Object "
ElseIf VarType(myVar) = vbError Then
MsgBox "Error value "
ElseIf VarType(myVar) = vbBoolean Then
MsgBox "Boolean value "
ElseIf VarType(myVar) = vbVariant Then
MsgBox "Variant (used only with arrays of variants) "
ElseIf VarType(myVar) = vbDataObject Then
MsgBox "A data access object "
ElseIf VarType(myVar) = vbDecimal Then
MsgBox "Decimal value "
ElseIf VarType(myVar) = vbByte Then
MsgBox "Byte value "
ElseIf VarType(myVar) = vbUserDefinedType Then
MsgBox "Variants that contain user-defined types "
ElseIf VarType(myVar) = vbArray Then
MsgBox "Array "
Else
MsgBox VarType(myVar)
End If

' Excel VBA, Visual Basic, Get Variable Type, VarType


End Function

Optional Parameter Example

Function Optional_Param_Example(Optional ByVal vOptionalText1 As Variant, Optional ByVal sOptionalText2 As String)

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

If IsMissing(vOptionalText1) Then
MsgBox "Optional Parameter 1 Missing.."
Else
MsgBox "Optional Parameter 1 Present.."
End If

IsMissing does not work on simple data types (such as Integer or Double) because, unlike Variants, they don't have a provision for a "missing" flag bit.
sOptionalText2 is not reported missing if it is not supplied

If IsMissing(sOptionalText2) Then
MsgBox "Optional Parameter 2 Missing.."
Else
MsgBox "Optional Parameter 2 Present.."
End If

' IsMissing Function, Optional Parameters, IsMissing Doesn't Work

End Function

Show Help From VB

If you have compiled help file (.chm) you can show it using the following

Function Call_Application_Help_MyApp(Optional ByVal vHelpText As Variant)

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

Application.Help "c:\Sample.chm"

' HTML Help, Using Help, Link Application Help with Program
End Function

Technorati Profile

Showing Excel Help

Showing Excel Help

Use this function to show the help; based on helpID

Function Call_Application_Help_Excel(Optional ByVal vHelpText As Variant)

' ---------------------------------------------------------------
' Written By Shanmuga Sundara Raman for http://vbadud.blogspot.com
' ---------------------------------------------------------------

If Val(Application.Version) = 10 Then
Application.Help "XLMAIN10.CHM", vHelpText
Else
Application.Help "XLMAIN9.CHM", vHelpText
End If

' Excel VBA, Using Help, Link Application Help with Program
End Function