rohan4069
08-04-2011, 11:48 PM
Hi all
i have made a userform which helps in writing a client letter to the team members. Everything is working fine until i open another word template. If there is another template opened then i get an error which says "the requested member of the collection does not exist". The code is below :
Option Explicit
Private Sub cmdCancel_Click()
Unload Me
ActiveDocument.Close SaveChanges:=False
End Sub
Private Sub cmdClear_Click()
optCRN.Value = True
txtRef.Value = Null
txtClientName.Value = Null
txtAddress1.Value = Null
txtAddress2.Value = Null
txtAddress3.Value = Null
txtAddress4.Value = Null
txtAddress5.Value = Null
txtSalutation.Value = Null
txtSubject.Value = Null
txtACNumber.Value = Null
txtName.Value = Null
txtDesig.Value = Null
chkDesig.Value = Null
txtSalutation.Value = Null
cboDesignation.Value = Null
txtMsgBody.Value = Null
txtEncl.Value = Null
txtInit.Value = Null
CheckBox2.Value = Null
End Sub
Sub NoSpace()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "([.]) "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = True
Do While .Execute = True
.Replacement.Text = "."
Selection.Find.Execute Replace:=wdReplaceAll
Loop
End With
End Sub
Sub TwoSpaces()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "([.])"
.Replacement.Text = "\1 "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Sub TwoPeriods()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ".."
.Replacement.Text = "."
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Sub TwoCommas()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ",,"
.Replacement.Text = ","
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Sub LetterContent()
With ActiveDocument
.Bookmarks("NameAddress1").Range.Text = txtClientName.Value
.Bookmarks("NameAddress2").Range.Text = txtAddress1.Value
.Bookmarks("NameAddress3").Range.Text = txtAddress2.Value
.Bookmarks("NameAddress4").Range.Text = txtAddress3.Value
.Bookmarks("NameAddress5").Range.Text = txtAddress4.Value
.Bookmarks("NameAddress6").Range.Text = txtAddress5.Value
.Content.Font.Name = "Arial"
.Content.Font.Size = 11
.Paragraphs.Format.Alignment = wdAlignParagraphJustify
'.PageSetup.PaperSize = wdPaperA4
'.PageSetup.TopMargin = 2.54
'.PageSetup.BottomMargin = 2.54
'.PageSetup.LeftMargin = 2.54
'.PageSetup.RightMargin = 2.54
End With
End Sub
Sub LetterContentOne()
With ActiveDocument
.Bookmarks("NameAddress2").Range.Text = txtClientName.Value
.Bookmarks("NameAddress3").Range.Text = txtAddress1.Value
.Bookmarks("NameAddress4").Range.Text = txtAddress2.Value
.Bookmarks("NameAddress5").Range.Text = txtAddress3.Value
.Bookmarks("NameAddress6").Range.Text = txtAddress4.Value
.Bookmarks("NameAddress7").Range.Text = txtAddress5.Value
.Content.Font.Name = "Arial"
.Content.Font.Size = 10.5
.Paragraphs.Format.Alignment = wdAlignParagraphJustify
'.PageSetup.PaperSize = wdPaperA4
'.PageSetup.TopMargin = 2.54
'.PageSetup.BottomMargin = 2.54
'.PageSetup.LeftMargin = 2.54
'.PageSetup.RightMargin = 2.54
End With
End Sub
Sub CheckSpell()
With ActiveDocument
.Range.CheckSpelling
.Range.CheckGrammar
End With
End Sub
Sub ChangeCase()
With ActiveDocument.Content.Find
.Text = ". "
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute = True
With .Parent
'Include the next character
.End = .End + 2
'Change to uppercase
.Case = wdUpperCase
'Make sure to move on to next ". "
.Start = .End
End With
Loop
End With
End Sub
Sub CountWords()
Dim rDcm As Range ' the documents main story range
Dim oSnt As Object ' a sentence
Dim oPrg As Paragraph ' a paragraph
Dim lSnt As Long ' a counter for sentences
Dim lPrg As Long ' a counter for paragraphs
Dim oWord As Range
Dim Cnt As Long
Set rDcm = ActiveDocument.Range
For Each oPrg In rDcm.Paragraphs
lPrg = lPrg + 1
lSnt = 0
For Each oSnt In oPrg.Range.Sentences
lSnt = lSnt + 1
Cnt = 0
For Each oWord In oSnt.Words
If Not InStr("., ?!" & Chr(11) & Chr(13), oWord) <> 0 Then
Cnt = Cnt + 1
End If
Next oWord
If Cnt > 30 Then
oSnt.Comments.Add oSnt, "Sentence has more than 30 words"
Debug.Print lPrg, lSnt
End If
Next
Next
End Sub
Private Sub cmdOK_Click()
Dim strNumber As String
Dim strAddress As String
Dim CurrentDate As Date
Dim Ttlpgs As Integer
If optCRN = True Then strNumber = "Customer Reference Number"
If optAcNum = True Then strNumber = "Account Number"
Application.ScreenUpdating = False
On Error GoTo ErrHandler
With ActiveDocument
.Bookmarks("OurRef1").Range.Text = txtInit.Value
.Bookmarks("OurRef").Range.Text = txtRef.Value
.Bookmarks("Salutation").Range.Text = txtSalutation.Value
.Bookmarks("MsgBody").Range.Text = txtMsgBody.Value
'.Bookmarks("Greeting").Range.Text = strGreeting
.Bookmarks("ACNumber").Range.Text = txtACNumber.Value
.Bookmarks("YourName").Range.Text = txtName.Value
.Bookmarks("Designation").Range.Text = cboDesignation.Value
.Bookmarks("ACorCRN").Range.Text = strNumber
.Bookmarks("Subject").Range.Text = txtSubject.Value
.Bookmarks("ACDesignation").Range.Text = txtDesig.Value
'.Bookmarks("Designation").Range.Text = cboDesig.Value
'.Bookmarks("Encl").Range.Text = cboEncl.Value
.Bookmarks("Enclosures").Range.Text = txtEncl.Value
.Bookmarks("Enclosures1").Range.Text = txtEncl1.Value
.Bookmarks("Enclosures2").Range.Text = txtEncl2.Value
.Bookmarks("Enclosures3").Range.Text = txtEncl3.Value
If Me.chkDesig.Value = True Then
.Bookmarks("Desig").Range.Text = "Designation: "
End If
If Me.chkEncl.Value = True Then
Call Enclosures
End If
End With
'If cboNumber.Value = "Account Number" Then
'txtDesig.Value = "Designation"
'With ActiveDocument
'.Bookmarks("Desig").Range.Text = txtDesig.Value
'.Bookmarks("ACDesignation").Range.Text = txtDesignation.Value
'End With
'End If
Ttlpgs = Selection.Information(wdNumberOfPagesInDocument)
If Ttlpgs >= 2 Then
Call LetterContentOne
Else
Call LetterContent
End If
Ttlpgs = Selection.Information(wdNumberOfPagesInDocument)
If Ttlpgs >= 2 Then
Call LetterContent
End If
'call different programs
Call TwoCommas
Call TwoPeriods
Call NoSpace
Call TwoSpaces
Call CountWords
Call CheckSpell
Call ChangeCase
Call RemoveComma
Call SelectGreeting
Call ChangePageSetup
Call RunSpellCheck
If ActiveDocument.Bookmarks.Exists("Subject") Then
ActiveDocument.Bookmarks("Subject").Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
End If
Application.ScreenUpdating = True
Unload Me
ErrHandler:
If Err <> 0 Then
' Display an error message.
MsgBox Err.Description
'Clear the error.
Err.Clear
Resume Next
End If
End Sub
Private Sub UserForm_Initialize()
txtID.Value = Environ("username")
Call GetExcelData
optCRN.Value = True
With cboDesignation
.AddItem "Associate - Customer Relations"
.AddItem "Senior Associate - Customer Relations"
End With
End Sub
Sub ChangeDocProperties()
On Error GoTo ErrHandler
ActiveDocument.BuiltInDocumentProperties("Title") = "My Title"
Exit Sub
ErrHandler:
If Err <> 0 Then
' Display an error message.
MsgBox Err.Description
'Clear the error.
Err.Clear
Resume Next
End If
End Sub
Sub RemoveComma()
Dim Rng As Range
Set Rng = ActiveDocument.Range(Start:=ActiveDocument.Bookmarks("NameAddress1").Range.Start, End:=ActiveDocument.Bookmarks("NameAddress7").Range.End)
With Selection.Find
.Text = ","
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Sub SelectGreeting()
Dim str As String
str = "Sirs"
If txtSalutation.Value = str Then
ActiveDocument.Bookmarks("Greeting").Range.Text = "faithfully"
Else
ActiveDocument.Bookmarks("Greeting").Range.Text = "sincerely"
End If
End Sub
Sub GetExcelData()
Dim objExcel As Excel.Application
Dim wbk As Excel.Workbook
Dim ws As Excel.Worksheet
Dim myRange As Object
Dim UserName As String
Dim Name As String
Dim rs As Variant
Dim nm As Variant
On Error GoTo ErrHandler
Set objExcel = CreateObject("Excel.Application")
Set wbk = objExcel.Workbooks.Open("L:\ISC_Customer Relations\Team Folder\Staff.xls")
Set ws = wbk.Worksheets("Staff")
UserName = Me.txtID.Value
Set myRange = ws.Range("A2:E500")
If UserName <> "" Then
rs = wbk.Application.WorksheetFunction.VLookup(UserName, myRange, 2, False)
Me.txtName.Value = rs
End If
wbk.Close
Exit Sub
ErrHandler:
If Err <> 0 Then
' Display an error message.
MsgBox Err.Description
'Clear the error.
Err.Clear
Resume Next
End If
End Sub
Sub ChangePageSetup()
With ActiveDocument.PageSetup
.PaperSize = wdPaperA4
.TopMargin = CentimetersToPoints(2.54)
.BottomMargin = CentimetersToPoints(2.54)
.LeftMargin = CentimetersToPoints(2.54)
.RightMargin = CentimetersToPoints(2.54)
.MirrorMargins = True
End With
End Sub
Sub RunSpellCheck()
ActiveDocument.Content.Select
Selection.WholeStory
Selection.LanguageID = wdEnglishUK
ActiveDocument.CheckSpelling
End Sub
Sub Enclosures()
With ActiveDocument
If Me.txtEncl1.Value <> "" Then
.Bookmarks("Encl").Range.Text = "Encls:"
Else
.Bookmarks("Encl").Range.Text = "Encl:"
End If
End With
End Sub
Any help will be appreciated.
i have made a userform which helps in writing a client letter to the team members. Everything is working fine until i open another word template. If there is another template opened then i get an error which says "the requested member of the collection does not exist". The code is below :
Option Explicit
Private Sub cmdCancel_Click()
Unload Me
ActiveDocument.Close SaveChanges:=False
End Sub
Private Sub cmdClear_Click()
optCRN.Value = True
txtRef.Value = Null
txtClientName.Value = Null
txtAddress1.Value = Null
txtAddress2.Value = Null
txtAddress3.Value = Null
txtAddress4.Value = Null
txtAddress5.Value = Null
txtSalutation.Value = Null
txtSubject.Value = Null
txtACNumber.Value = Null
txtName.Value = Null
txtDesig.Value = Null
chkDesig.Value = Null
txtSalutation.Value = Null
cboDesignation.Value = Null
txtMsgBody.Value = Null
txtEncl.Value = Null
txtInit.Value = Null
CheckBox2.Value = Null
End Sub
Sub NoSpace()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "([.]) "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = True
Do While .Execute = True
.Replacement.Text = "."
Selection.Find.Execute Replace:=wdReplaceAll
Loop
End With
End Sub
Sub TwoSpaces()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "([.])"
.Replacement.Text = "\1 "
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = True
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Sub TwoPeriods()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ".."
.Replacement.Text = "."
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Sub TwoCommas()
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ",,"
.Replacement.Text = ","
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Sub LetterContent()
With ActiveDocument
.Bookmarks("NameAddress1").Range.Text = txtClientName.Value
.Bookmarks("NameAddress2").Range.Text = txtAddress1.Value
.Bookmarks("NameAddress3").Range.Text = txtAddress2.Value
.Bookmarks("NameAddress4").Range.Text = txtAddress3.Value
.Bookmarks("NameAddress5").Range.Text = txtAddress4.Value
.Bookmarks("NameAddress6").Range.Text = txtAddress5.Value
.Content.Font.Name = "Arial"
.Content.Font.Size = 11
.Paragraphs.Format.Alignment = wdAlignParagraphJustify
'.PageSetup.PaperSize = wdPaperA4
'.PageSetup.TopMargin = 2.54
'.PageSetup.BottomMargin = 2.54
'.PageSetup.LeftMargin = 2.54
'.PageSetup.RightMargin = 2.54
End With
End Sub
Sub LetterContentOne()
With ActiveDocument
.Bookmarks("NameAddress2").Range.Text = txtClientName.Value
.Bookmarks("NameAddress3").Range.Text = txtAddress1.Value
.Bookmarks("NameAddress4").Range.Text = txtAddress2.Value
.Bookmarks("NameAddress5").Range.Text = txtAddress3.Value
.Bookmarks("NameAddress6").Range.Text = txtAddress4.Value
.Bookmarks("NameAddress7").Range.Text = txtAddress5.Value
.Content.Font.Name = "Arial"
.Content.Font.Size = 10.5
.Paragraphs.Format.Alignment = wdAlignParagraphJustify
'.PageSetup.PaperSize = wdPaperA4
'.PageSetup.TopMargin = 2.54
'.PageSetup.BottomMargin = 2.54
'.PageSetup.LeftMargin = 2.54
'.PageSetup.RightMargin = 2.54
End With
End Sub
Sub CheckSpell()
With ActiveDocument
.Range.CheckSpelling
.Range.CheckGrammar
End With
End Sub
Sub ChangeCase()
With ActiveDocument.Content.Find
.Text = ". "
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
Do While .Execute = True
With .Parent
'Include the next character
.End = .End + 2
'Change to uppercase
.Case = wdUpperCase
'Make sure to move on to next ". "
.Start = .End
End With
Loop
End With
End Sub
Sub CountWords()
Dim rDcm As Range ' the documents main story range
Dim oSnt As Object ' a sentence
Dim oPrg As Paragraph ' a paragraph
Dim lSnt As Long ' a counter for sentences
Dim lPrg As Long ' a counter for paragraphs
Dim oWord As Range
Dim Cnt As Long
Set rDcm = ActiveDocument.Range
For Each oPrg In rDcm.Paragraphs
lPrg = lPrg + 1
lSnt = 0
For Each oSnt In oPrg.Range.Sentences
lSnt = lSnt + 1
Cnt = 0
For Each oWord In oSnt.Words
If Not InStr("., ?!" & Chr(11) & Chr(13), oWord) <> 0 Then
Cnt = Cnt + 1
End If
Next oWord
If Cnt > 30 Then
oSnt.Comments.Add oSnt, "Sentence has more than 30 words"
Debug.Print lPrg, lSnt
End If
Next
Next
End Sub
Private Sub cmdOK_Click()
Dim strNumber As String
Dim strAddress As String
Dim CurrentDate As Date
Dim Ttlpgs As Integer
If optCRN = True Then strNumber = "Customer Reference Number"
If optAcNum = True Then strNumber = "Account Number"
Application.ScreenUpdating = False
On Error GoTo ErrHandler
With ActiveDocument
.Bookmarks("OurRef1").Range.Text = txtInit.Value
.Bookmarks("OurRef").Range.Text = txtRef.Value
.Bookmarks("Salutation").Range.Text = txtSalutation.Value
.Bookmarks("MsgBody").Range.Text = txtMsgBody.Value
'.Bookmarks("Greeting").Range.Text = strGreeting
.Bookmarks("ACNumber").Range.Text = txtACNumber.Value
.Bookmarks("YourName").Range.Text = txtName.Value
.Bookmarks("Designation").Range.Text = cboDesignation.Value
.Bookmarks("ACorCRN").Range.Text = strNumber
.Bookmarks("Subject").Range.Text = txtSubject.Value
.Bookmarks("ACDesignation").Range.Text = txtDesig.Value
'.Bookmarks("Designation").Range.Text = cboDesig.Value
'.Bookmarks("Encl").Range.Text = cboEncl.Value
.Bookmarks("Enclosures").Range.Text = txtEncl.Value
.Bookmarks("Enclosures1").Range.Text = txtEncl1.Value
.Bookmarks("Enclosures2").Range.Text = txtEncl2.Value
.Bookmarks("Enclosures3").Range.Text = txtEncl3.Value
If Me.chkDesig.Value = True Then
.Bookmarks("Desig").Range.Text = "Designation: "
End If
If Me.chkEncl.Value = True Then
Call Enclosures
End If
End With
'If cboNumber.Value = "Account Number" Then
'txtDesig.Value = "Designation"
'With ActiveDocument
'.Bookmarks("Desig").Range.Text = txtDesig.Value
'.Bookmarks("ACDesignation").Range.Text = txtDesignation.Value
'End With
'End If
Ttlpgs = Selection.Information(wdNumberOfPagesInDocument)
If Ttlpgs >= 2 Then
Call LetterContentOne
Else
Call LetterContent
End If
Ttlpgs = Selection.Information(wdNumberOfPagesInDocument)
If Ttlpgs >= 2 Then
Call LetterContent
End If
'call different programs
Call TwoCommas
Call TwoPeriods
Call NoSpace
Call TwoSpaces
Call CountWords
Call CheckSpell
Call ChangeCase
Call RemoveComma
Call SelectGreeting
Call ChangePageSetup
Call RunSpellCheck
If ActiveDocument.Bookmarks.Exists("Subject") Then
ActiveDocument.Bookmarks("Subject").Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
End If
Application.ScreenUpdating = True
Unload Me
ErrHandler:
If Err <> 0 Then
' Display an error message.
MsgBox Err.Description
'Clear the error.
Err.Clear
Resume Next
End If
End Sub
Private Sub UserForm_Initialize()
txtID.Value = Environ("username")
Call GetExcelData
optCRN.Value = True
With cboDesignation
.AddItem "Associate - Customer Relations"
.AddItem "Senior Associate - Customer Relations"
End With
End Sub
Sub ChangeDocProperties()
On Error GoTo ErrHandler
ActiveDocument.BuiltInDocumentProperties("Title") = "My Title"
Exit Sub
ErrHandler:
If Err <> 0 Then
' Display an error message.
MsgBox Err.Description
'Clear the error.
Err.Clear
Resume Next
End If
End Sub
Sub RemoveComma()
Dim Rng As Range
Set Rng = ActiveDocument.Range(Start:=ActiveDocument.Bookmarks("NameAddress1").Range.Start, End:=ActiveDocument.Bookmarks("NameAddress7").Range.End)
With Selection.Find
.Text = ","
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Sub SelectGreeting()
Dim str As String
str = "Sirs"
If txtSalutation.Value = str Then
ActiveDocument.Bookmarks("Greeting").Range.Text = "faithfully"
Else
ActiveDocument.Bookmarks("Greeting").Range.Text = "sincerely"
End If
End Sub
Sub GetExcelData()
Dim objExcel As Excel.Application
Dim wbk As Excel.Workbook
Dim ws As Excel.Worksheet
Dim myRange As Object
Dim UserName As String
Dim Name As String
Dim rs As Variant
Dim nm As Variant
On Error GoTo ErrHandler
Set objExcel = CreateObject("Excel.Application")
Set wbk = objExcel.Workbooks.Open("L:\ISC_Customer Relations\Team Folder\Staff.xls")
Set ws = wbk.Worksheets("Staff")
UserName = Me.txtID.Value
Set myRange = ws.Range("A2:E500")
If UserName <> "" Then
rs = wbk.Application.WorksheetFunction.VLookup(UserName, myRange, 2, False)
Me.txtName.Value = rs
End If
wbk.Close
Exit Sub
ErrHandler:
If Err <> 0 Then
' Display an error message.
MsgBox Err.Description
'Clear the error.
Err.Clear
Resume Next
End If
End Sub
Sub ChangePageSetup()
With ActiveDocument.PageSetup
.PaperSize = wdPaperA4
.TopMargin = CentimetersToPoints(2.54)
.BottomMargin = CentimetersToPoints(2.54)
.LeftMargin = CentimetersToPoints(2.54)
.RightMargin = CentimetersToPoints(2.54)
.MirrorMargins = True
End With
End Sub
Sub RunSpellCheck()
ActiveDocument.Content.Select
Selection.WholeStory
Selection.LanguageID = wdEnglishUK
ActiveDocument.CheckSpelling
End Sub
Sub Enclosures()
With ActiveDocument
If Me.txtEncl1.Value <> "" Then
.Bookmarks("Encl").Range.Text = "Encls:"
Else
.Bookmarks("Encl").Range.Text = "Encl:"
End If
End With
End Sub
Any help will be appreciated.