Working with word using VBA in Excel

Sub Createwordapp()

Dim wdapp As Object

Dim wddoc As Object

'**** Creating word application object ********

Set wdapp = CreateObject("Word.application")

'**** Adding new document to word document *******
wdapp.documents.Add

'**** Making word application visible ********

wdapp.Visible = True

'**** Adding Text to document ************

With wdapp.Selection
.typetext Text:="This is my document"
.typeparagraph
.typetext Text:="Thank You"
.typeparagraph
End With


' **** Prompting and saving word document *********

wdapp.activedocument.SaveAs Application.GetSaveAsFilename(InitialFileName:="Doc1", filefilter:="word document (*.doc),*.doc")

'**** Closing word document *******

wdapp.activedocument.Close

'**** closing word application *******

wdapp.Quit

End Sub

Convert Numbers into words

Function Inwords(ByVal Nvalue As Double)

On error goto lb1

Dim intDecimal As String
Dim intTens As String
Dim inthundred As String
Dim intthousand As String
Dim intLakh As String
Dim intcrore As String

Dim strValue As String

strValue = Format(Nvalue, "#0.00")
intDecimal = Right(strValue, 2)


'******* Converting Crore place into words **************


If Nvalue >= 10000000 Then

If Len(strValue) >= 12 Then

intcrore = Left(Right(strValue, 12), 2)

ElseIf Len(strValue) >= 11 Then

intcrore = Left(Right(strValue, 11), 1)

End If

If CInt(intcrore) > 19 Then

intcrore = completetens(Left(intcrore, 1) * 10) & " " & Tens(Right(intcrore, 1)) & " Crore "

ElseIf CInt(intcrore) <> 0 Then

intcrore = Tens(intcrore) & " Crore "

Else

intcrore = ""

End If

End If



'******* Converting Lakh place into words **************


If Nvalue >= 100000 Then

If Len(strValue) >= 10 Then

intLakh = Left(Right(strValue, 10), 2)

ElseIf Len(strValue) >= 9 Then

intLakh = Left(Right(strValue, 9), 1)

End If

If CInt(intLakh) > 19 Then

intLakh = completetens(Left(intLakh, 1) * 10) & " " & Tens(Right(intLakh, 1)) & " Lac "

ElseIf CInt(intLakh) <> 0 Then

intLakh = Tens(intLakh) & " Lac "

Else

intLakh = ""

End If

End If


'******* Converting Thousand place into words **************

If Nvalue >= 1000 Then

If Len(strValue) >= 8 Then

intthousand = Left(Right(strValue, 8), 2)

ElseIf Len(strValue) >= 7 Then

intthousand = Left(Right(strValue, 7), 1)

End If

If CInt(intthousand) > 19 Then

intthousand = completetens(Left(intthousand, 1) * 10) & " " & Tens(Right(intthousand, 1)) & " Thousand "

ElseIf CInt(intthousand) <> 0 Then

intthousand = Tens(intthousand) & " Thousand "

Else

intthousand = ""

End If

End If


'******* Converting Hundred place into words **************

If Nvalue >= 100 Then

If CInt(Left(Right(strValue, 6), 1)) <> 0 Then inthundred = Tens(Left(Right(strValue, 6), 1)) & " Hundred "

Else
inthundred = ""

End If


'******* Converting Ones and Tens places into words **************

intTens = Left(Right(strValue, 5), 2)
If Nvalue >= 1 And CInt(intTens) <> 0 Then



If CInt(intTens) > 19 Then

intTens = completetens(Left(intTens, 1) * 10) & " " & Tens(Right(intTens, 1)) & " "
Else
intTens = Tens(intTens) & " "

End If

Else
intTens = ""

End If



'******* Converting Decimals places into words **************

If CInt(intDecimal) <> 0 Then

If CInt(intDecimal) > 19 Then

intDecimal = completetens(Left(intDecimal, 1) * 10) & " " & Tens(Right(intDecimal, 1)) & " Paise "
Else
intDecimal = Tens(intDecimal) & " Paise "

End If
Else
intDecimal = ""

End If



If intDecimal <> "" Then

mystring = intcrore & intLakh & intthousand & inthundred & intTens & "and " & intDecimal & "Only"
Else
mystring = intcrore & intLakh & intthousand & inthundred & intTens & "Only"
End If
inwords = Trim(mystring)

exit function
lb1:
inwords =""

End Function



Function Tens(IntValue)

Select Case IntValue

Case 1
Tens = "One"
Case 2
Tens = "Two"
Case 3
Tens = "Three"
Case 4
Tens = "Four"
Case 5
Tens = "Five"
Case 6
Tens = "Six"
Case 7
Tens = "Seven"
Case 8
Tens = "Eight"
Case 9
Tens = "Nine"
Case 10
Tens = "Ten"
Case 11
Tens = "Eleven"
Case 12
Tens = "Twelve"
Case 13
Tens = "Thirteen"
Case 14
Tens = "Fourteen"
Case 15
Tens = "Fifteen"
Case 16
Tens = "Sixteen"
Case 17
Tens = "Seventeen"
Case 18
Tens = "Eighteen"
Case 19
Tens = "Nineteen"
End Select

End Function

Function completetens(IntValue)

Select Case IntValue
Case 20
completetens = "Twenty"
Case 30
completetens = "Thirty"
Case 40
completetens = "Fourty"
Case 50
completetens = "Fifty"
Case 60
completetens = "Sixty"
Case 70
completetens = "Seventy"
Case 80
completetens = "Eighty"
Case 90
completetens = "Ninety"
End Select

End Function

Click here to download addin

Create custom command bar in access using VBA

Sub CreateCommandBar()
Dim myCB As CommandBar
Dim myCPup1 As CommandBarPopup
Dim myCP1Btn1 As CommandBarButton


' Delete the commandbar if it exists already
On Error Resume Next
Application.CommandBars("Training Manager").Delete

' Create a new Command Bar
Set myCB = CommandBars.Add(Name:="Training Manager", Position:=msoBarTop)

'************* Menu 1 Details *****************************

If encrpt(GetSetting(appname:="Profile", Section:="class", Key:="Utype", Default:=encrpt("Dummy"))) <> "ADMIN" Then GoTo lb2

' Add popup menu 1 to this bar
Set myCPup1 = myCB.Controls.Add(Type:=msoControlPopup)
myCPup1.Caption = "T&rainings"

' Add button 1 to popup menu 1
Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Create Training"
.Style = msoButtonAutomatic
.FaceId = 137
.OnAction = "=showCreatTrainings()"

End With

' Add button 2 to popup menu 1
Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Edit Trainings"
.Style = msoButtonIconAndCaption
.FaceId = 162
.OnAction = "=showEditTrainings()"
End With

' Add button 2 to popup menu 1
Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "Add/Edit &Other Info"
.Style = msoButtonIconAndCaption
.FaceId = 162
.OnAction = "=showOtherinfo()"
End With

'************* Menu 2 Details *****************************

Set myCPup1 = myCB.Controls.Add(Type:=msoControlPopup)
myCPup1.Caption = "A&ssociate(s)"

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&New Associate"
.Style = msoButtonAutomatic
.FaceId = 326
.OnAction = "=CreateAssociate()"

End With

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Edit Associate(s) Info"
.Style = msoButtonAutomatic
.FaceId = 327
.OnAction = "=editAssociate()"

End With


Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Assign Trainings"
.Style = msoButtonAutomatic
.FaceId = 855
.OnAction = "=AssignAssociate()"

End With

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Training Nomination"
.Style = msoButtonAutomatic
.FaceId = 29
.OnAction = "=SendNominations()"

End With

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Generate Password"
.Style = msoButtonAutomatic
.FaceId = 29
.OnAction = "=RestPassword()"

End With


'************* Menu 3 Details *****************************

Set myCPup1 = myCB.Controls.Add(Type:=msoControlPopup)
myCPup1.Caption = "Re&ports"

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Group Status"
.Style = msoButtonAutomatic
.FaceId = 435
.OnAction = "=GroupReport()"

End With

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Nomination Report"
.Style = msoButtonAutomatic

.OnAction = "=NominationReport()"

End With

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "Sche&duled Trainins"
.Style = msoButtonAutomatic

.OnAction = "=SchecduledTrainings()"

End With

lb2:

'************* Menu 4 Details *****************************

Set myCPup1 = myCB.Controls.Add(Type:=msoControlPopup)
myCPup1.Caption = "&Events && others"

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "&Celebrations"
.Style = msoButtonAutomatic
.FaceId = 608
.OnAction = "=myevents()"

End With

Set myCP1Btn1 = myCPup1.Controls.Add(Type:=msoControlButton)
With myCP1Btn1
.Caption = "Change &Password"
.Style = msoButtonAutomatic
.FaceId = 505
.OnAction = "=ChangePassword()"

End With


myCB.Visible = True

End Sub

Function showCreatTrainings()
DoCmd.OpenTable TableName:="tbl_TrainingMaster", View:=acViewNormal, Datamode:=acAdd
End Function

Create 30 Days evaluation restriction for your tool. (Excel)

you can now secure/restrict the usage of your tool/macro by adding below code in excel.



Private Sub Workbook_Open()


Dim Sdate As Date

Dim edate As Date

Dim Rkey As String


Sdate = encrpt(GetSetting(appname:="App", Section:="class", key:="SD", Default:=encrpt("01/01/2000")))

edate = encrpt(GetSetting(appname:="App", Section:="class", key:="ED", Default:=encrpt("01/01/2000")))

Rkey = encrpt(GetSetting(appname:="App", Section:="Class", key:="Key", Default:="pxbac"))



If Sdate = "01/01/2000" And edate = "01/01/2000" And Rkey = "pxbac" Then



MsgBox "Its a Trial version"



SaveSetting appname:="App", Section:="class", key:="SD", Setting:=encrpt(Date)

SaveSetting appname:="App", Section:="class", key:="ED", Setting:=encrpt(Date + 30)

SaveSetting appname:="App", Section:="class", key:="Key", Setting:=encrpt("trial")





ElseIf Sdate <> "01/01/2000" And edate <> "01/01/2000" And Rkey = "trial" Then

MsgBox edate - Date & " Days Left."



ElseIf Sdate <> "01/01/2000" And edate <> "01/01/2000" And Rkey = "mingo" Then

MsgBox "Complete version"



End If



End Sub

-----------------------------------------------------------------------------------------------

Function encrpt(ecrptthis)


Dim stringchar, keychar, crptchar


For i = 1 To Len(ecrptthis)

stringchar = Asc(Mid(ecrptthis, i, 1))

keychar = Asc(Mid(keygen, i, 1))

crptchar = stringchar Xor keychar

strencrpt = strencrpt & Chr(crptchar)

Next

encrpt = strencrpt

End Function
 
-------------------------------------------------------------------------------------
 
Function keygen()


keygen = "adflsn4w#$^23%@^$FDSDTwqaer^ERQ#W#$^*%$%DE!3fqDTw6rt*^$#"

End Function

Like Operator (Usage in VB and VBA)

 Dim testCheck As Boolean


' The following statement returns True (does "F" satisfy "F"?)

testCheck = "F" Like "F"

' The following statement returns False for Option Compare Binary

' and True for Option Compare Text (does "F" satisfy "f"?)

testCheck = "F" Like "f"

' The following statement returns False (does "F" satisfy "FFF"?)

testCheck = "F" Like "FFF"

' The following statement returns True (does "aBBBa" have an "a" at the

' beginning, an "a" at the end, and any number of characters in

' between?)

testCheck = "aBBBa" Like "a*a"

' The following statement returns True (does "F" occur in the set of

' characters from "A" through "Z"?)

testCheck = "F" Like "[A-Z]"

' The following statement returns False (does "F" NOT occur in the

' set of characters from "A" through "Z"?)

testCheck = "F" Like "[!A-Z]"

' The following statement returns True (does "a2a" begin and end with

' an "a" and have any single-digit number in between?)

testCheck = "a2a" Like "a#a"

' The following statement returns True (does "aM5b" begin with an "a",

' followed by any character from the set "L" through "P", followed

' by any single-digit number, and end with any character NOT in

' the character set "c" through "e"?)

testCheck = "aM5b" Like "a[L-P]#[!c-e]"

' The following statement returns True (does "BAT123khg" begin with a

' "B", followed by any single character, followed by a "T", and end

' with zero or more characters of any type?)

testCheck = "BAT123khg" Like "B?T*"

' The following statement returns False (does "CAT123khg"?) begin with

' a "B", followed by any single character, followed by a "T", and

' end with zero or more characters of any type?)

testCheck = "CAT123khg" Like "B?T*"



For complete article follow the below link:

http://msdn.microsoft.com/en-us/library/swf8kaxw(VS.80).aspx

Open website with login and paswd using VBA

The program requires references to the following:

1 Microsoft Internet Controls
2. Microsoft HTML Object Library

The Internet control is used to browse the webpage and the HTML Objects are used to identify the username and password textboxes and submit the text using the control button.

Dim HTMLDoc As HTMLDocument
Dim oBrowser As InternetExplorer
Sub Login_2_Website()

Dim oHTML_Element As IHTMLElement
Dim sURL As String

On Error GoTo Err_Clear
sURL = "https://www.google.com/accounts/Login"
Set oBrowser = New InternetExplorer
oBrowser.Silent = True
oBrowser.timeout = 60
oBrowser.navigate sURL
oBrowser.Visible = True

Do
' Wait till the Browser is loaded
Loop Until oBrowser.readyState = READYSTATE_COMPLETE

Set HTMLDoc = oBrowser.Document

HTMLDoc.all.Email.Value = "sample@vbadud.com"
HTMLDoc.all.passwd.Value = "*****"

For Each oHTML_Element In HTMLDoc.getElementsByTagName("input")
If oHTML_Element.Type = "submit" Then oHTML_Element.Click: Exit For
Next

' oBrowser.Refresh ' Refresh If Needed
Err_Clear:
If Err <> 0 Then
Debug.Assert Err = 0
Err.Clear
Resume Next
End If
End Sub

Create Barchart using "REPT" function.

Here is the example of REPT function. To create BarChart

 

Units	Days	Share	Function
100	Sunday	|||||  5%	=REPT("|",100*A2/$A$9) &"  "& TEXT(A2/$A$9,"0%")
150	Monday	|||||||  8%	=REPT("|",100*A3/$A$9) &"  "& TEXT(A3/$A$9,"0%")
450	Tuesday	||||||||||||||||||||||  23%	=REPT("|",100*A4/$A$9) &"  "& TEXT(A4/$A$9,"0%")
300	Wednesday	|||||||||||||||  15%	=REPT("|",100*A5/$A$9) &"  "& TEXT(A5/$A$9,"0%")
300	Thursday	|||||||||||||||  15%	=REPT("|",100*A6/$A$9) &"  "& TEXT(A6/$A$9,"0%")
400	Friday	||||||||||||||||||||  20%	=REPT("|",100*A7/$A$9) &"  "& TEXT(A7/$A$9,"0%")
300	Saturday	|||||||||||||||  15%	=REPT("|",100*A8/$A$9) &"  "& TEXT(A8/$A$9,"0%")
2000	Total

 

http://www.vbatalent.blogspot.com

---

Now, send attachments up to 25MB with Yahoo! India Mail. Learn how.

Remove workbook password.

'****************************************************************************
' Main procedure
' Open the workbook which you wants to remove password and run the procedure
'****************************************************************************
Sub PasswordBreaker1()

Dim wkb As Excel.Workbook
Set wkb = ActiveWorkbook

Dim i As Integer, j As Integer, k As Integer
Dim l As Integer, m As Integer, n As Integer
Dim i1 As Integer, i2 As Integer, i3 As Integer
Dim i4 As Integer, i5 As Integer, i6 As Integer
On Error Resume Next
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126

ActiveWorkbook.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)

Application.StatusBar = Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)

If Not IsProtected(wkb) Then
MsgBox "One usable password is " & Chr(i) & Chr(j) & _
Chr(k) & Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)

Application.StatusBar = False

Exit Sub

End If
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next

End Sub

 

Function IsProtected(objXL As Object) As Boolean
Dim wksht As Excel.Worksheet
Dim cell As Excel.Range
Select Case TypeName(objXL)
 
  Case "Workbook"
    If objXL.ProtectStructure Then
      IsProtected = True
      Exit Function
    Else
        IsProtected = False
      Exit Function
    End If
End Select
End Function

---

Add whatever you love to the Yahoo! India homepage. Try now!

Append data from Multiple workbooks without opening the workbooks

Sub Main

Call AppendData

End Sub

 

 

Function GetFolder(ByVal DefaultPath As String)

On Error Resume Next

Set fd = Application.FileDialog(msoFileDialogFolderPicker)
jmp1:

With fd
.InitialFileName = DefaultPath & "\"
.Show
End With

GetFolder = fd.SelectedItems(1)
If GetFolder = Empty Then GoTo errHandler
Exit Function
errHandler:
MsgBox "Please select a folder."
GoTo jmp1

End Function

 

 

Sub AppendData()

Dim folderpath As String
Dim cnt As DAO.Database
Dim rst As DAO.Recordset

Sheets(1).Select
Range("A2").Select

folderpath = GetFolder("C:")

With Application.FileSearch
.NewSearch
.LookIn = folderpath
.SearchSubFolders = False
.Filename = "*.xls"
.Execute
   
    For i = 1 To .FoundFiles.Count
   
        Set cnt = DBEngine.OpenDatabase(.FoundFiles(i), False, False, "Excel 8.0")
        Set rst = cnt.OpenRecordset("Sheet1$")

        ActiveCell.CopyFromRecordset rst
        Cells(Range("E1").End(xlDown).Row + 1, 1).Select

        rst.Close
        cnt.Close
       
    Next
   
   
End With

End Sub

 

For worksheet example check this url http://groups.google.co.in/group/myvbagroup?hl=en

 

---

See the Web's breaking stories, chosen by people like you. Check out Yahoo! Buzz.

Conditional Ranking in Excel

Here is the example of Conditional Ranking

 

	A	B	C	D	E
1	Date	Time	IN /Out	Ranking as per Dates	Done
2	2/1/2009	8:50	IN	1	=SUMPRODUCT(($A$2:$A$13=A2)*(B2>$B$2:$B$13))+1
3	2/1/2009	13:10	OUT	2	=SUMPRODUCT(($A$2:$A$13=A3)*(B3>$B$2:$B$13))+1
4	2/1/2009	14:00	IN	3	=SUMPRODUCT(($A$2:$A$13=A4)*(B4>$B$2:$B$13))+1
5	2/2/2009	8:50	IN	1	=SUMPRODUCT(($A$2:$A$13=A5)*(B5>$B$2:$B$13))+1
6	2/2/2009	13:10	OUT	2	=SUMPRODUCT(($A$2:$A$13=A6)*(B6>$B$2:$B$13))+1
7	2/1/2009	23:00	OUT	4	=SUMPRODUCT(($A$2:$A$13=A7)*(B7>$B$2:$B$13))+1
8	2/2/2009	23:00	OUT	4	=SUMPRODUCT(($A$2:$A$13=A8)*(B8>$B$2:$B$13))+1
9	2/3/2009	8:50	IN	1	=SUMPRODUCT(($A$2:$A$13=A9)*(B9>$B$2:$B$13))+1
10	2/3/2009	13:10	OUT	2	=SUMPRODUCT(($A$2:$A$13=A10)*(B10>$B$2:$B$13))+1
11	2/2/2009	14:00	IN	3	=SUMPRODUCT(($A$2:$A$13=A11)*(B11>$B$2:$B$13))+1
12	2/3/2009	23:00	OUT	3	=SUMPRODUCT(($A$2:$A$13=A12)*(B12>$B$2:$B$13))+1
13	2/1/2009	23:50	IN	5	=SUMPRODUCT(($A$2:$A$13=A13)*(B13>$B$2:$B$13))+1

---

See the Web's breaking stories, chosen by people like you. Check out Yahoo! Buzz.

How to create Dynamic validation list in excel

Example:

 

Let say I have two sheets in a workbook

 

1) Lists

2) Answer

 

Sheet Lists :  has two list as follows

 

 

Sheet "Answer" is as follows

 

 

1) Create Names as follows ( Insert > Names > Define)

 

Name	Sheet Name	Formula
Type	List	=OFFSET(List!$A$2,0,0,COUNTA(List!$A:$A)-1,1)
List1	List	=List!$B:$B
List2		=OFFSET(List!$C$1,MATCH(Answer!$A33,List1,0)-1,0,COUNTIF(List1,Answer!$A33),1)

 

 

2) Go to Sheet "Answer" select column A and select Data>Validation from Menu.

3) Select List from Allow drop down.

4) and write  =type in Source textbox press OK.

5) Select the column B and Select Data>Validation from Menu.

6) Select List from Allow drop down.

7) and write  =List2 in Source textbox press OK

 

 

Send mail without using mail clients (Outlook) through VBA

Sub Sendmail()

Set imsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
 
 
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
    .Item("http://schemas.Microsoft.Com/cdo/configuration/smtpusessl") = True
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Range("B4").Value
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = mailid
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = pswd
    .Update
End With
 
strBody = " Attached you will  find your MMO notifications from <our company name here> on ship date: " & Format(Date, "mm/dd/yyyy")
 
With imsg
    Set .Configuration = iConf
    .To = mailid
    .CC = ""
    .BCC = ""
    .From = mailid
    .Subject = "Manual Markout Notification - " & Format(Date, "mm/dd/yyyy")
    .TextBody = strBody
    .AddAttachment (ThisWorkbook.Path & "/" & Replace(Replace(shtData.Range("AC2").Value, ".", ""), "/", "") & " " & Format(Date, "mm-dd-yyyy") & ".mhtml")
    .Send
End With
Set Flds = Nothing
Set imsg = Nothing

Exit Sub

Set Flds = Nothing
Set imsg = Nothing

End Sub

---

Looking for local information? Find it on Yahoo! Local