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