VBA to add word list to Custom Dictionary

[Joe Was]

In Excel VBA this checks the Custom Dictionary for a word:

Sub myDicList()
Dim myWord$, myDic$

myDic = Application.SpellingOptions.UserDict

myWord = InputBox("Check the Dictionaries for the Word you enter below." & _
vbLf & vbLf & "Note: Your custom dictionary is currently set to:" & vbLf & _
" " & myDic, "Lookup Your Word!")

If myWord = "" Then GoTo myEnd

If Not Application.CheckSpelling(myWord, CustomDictionary:=myDic, IgnoreUppercase:=False) Then
MsgBox "Not in dictionary!"

Else
MsgBox "Is in dictionary!"

End If

myEnd:
End Sub


But, this next code only creates a dummy custom.dic and does not update the real user custom dictionary?

Sub add_Dic()
Dim myWord$

Close #1
Open Application.SpellingOptions.UserDict For Output As #1

myWord = Selection.Value

If Not IsEmpty(myWord) Then
Write #1, myWord

MsgBox myWord & ", was Added to the current custom dictionary: " _
& Application.SpellingOptions.UserDict
End If

Close #1

End Sub

Does anyone know if you can add words by code?

From help it points to WORD as a way, but could not get it there as well?

In WORD VBA this lists the Custom Dictionaries, but can't seem to add any words to it by code?

Sub myDicts()

For Each d In CustomDictionaries

If d.Name = Application.CustomDictionaries.ActiveCustomDictionary.Name Then
MsgBox "Active Dictionary: " & d.Path & Application.PathSeparator & d.Name
Else
MsgBox "InActive Dictionary: " & d.Path & Application.PathSeparator & d.Name
End If

d.Write "Relo"
Next d

End Sub


Any ideas on adding a list of words to an Office User Defined Custom Dictionary used by Spell-Check?

The key-word Scripting Dictionary is not checked by SpellCheck even though you can add to it by code?

 

[Norie]

Joe

Shouldn't you be using Append instead of Output here?

Open Application.SpellingOptions.UserDict For Output As #1

This worked for me.

Sub add_Dic()
Dim myWord$

    Set myCust = Application.CustomDictionaries.ActiveCustomDictionary
    
    Open myCust.Path & "\" & myCust.Name For Append As #1
    
        myWord = "Another New Word"
        
        If Not IsEmpty(myWord) Then
            Print #1, myWord
        End If
    
    Close #1

End Sub

 

[Joe Was]

Thanks Norie,

Was running around with this for some time.

The code below now works, it takes a list of words from Column A in Excel and adds the words to the custom dictionary.


Sub addToDict()
'Standard module code, like: Module1.
'Add a list of words in Column "A" to the Custom Dictionary!
Dim o_WordApp As Object, o_ActCustDict As Object
Dim r_MyCell As Range
Dim s_MyWord$, s_ActCustDictNm$
Dim l_LastRow&, l_StartRow&

'********************************************************************
'The Row that the"Add to Dictionary" Word List Starts in!
l_StartRow = 3
'********************************************************************
l_LastRow = ActiveSheet.Range("A65536").End(xlUp).Row
s_MyMsg = "Current custom dictionary: " & s_ActCustDictNm & vbLf & "Added: "

Set r_MyRng = ActiveSheet.Range(Cells(l_StartRow, 1), Cells(l_LastRow, 1))
Set o_WordApp = GetObject(, "Word.Application")
Set o_ActCustDict = o_WordApp.Application.CustomDictionaries.ActiveCustomDictionary
s_ActCustDictNm = o_ActCustDict.Name

Open o_ActCustDict.Path & "\" & o_ActCustDict.Name For Append As #1

For Each r_MyCell In r_MyRng
s_MyWord = r_MyCell.Value

If Not IsEmpty(s_MyWord) Then
Print #1, s_MyWord

s_MyMsg = s_MyMsg & s_MyWord & ", "

End If
Next r_MyCell

Close #1

MsgBox s_MyMsg
End Sub

 

[walt1122]

WOW! Thank you both for all this assistance I will put the code in the spreadsheet and it sure looks like this will take care of the problem. A problem that has been bothering me since they installed this new version of Excel.

thanks again

Walt

 

[Joe Was]

This is an improvement on the code above. It now works if WORD is not currently Open.


Sub addToDict()
'Standard module code, like: Module1.
'Add a list of words in Column "A" to the Custom Dictionary!

Dim o_WordApp As Object
Dim o_ActCustDict As Object
Dim r_MyCell As Range, r_MyRng As Range
Dim s_MyWord$, s_ActCustDictNm$, s_MyMsg$
Dim l_LastRow&, l_StartRow&, n&

'********************************************************************
'The Row that the"Add to Dictionary" Word List Starts in!
l_StartRow = 3
'********************************************************************
l_LastRow = ActiveSheet.Range("A65536").End(xlUp).Row

Set r_MyRng = ActiveSheet.Range(Cells(l_StartRow, 1), Cells(l_LastRow, 1))

Set o_WordApp = CreateObject("Word.Application")
Set o_ActCustDict = o_WordApp.Application.CustomDictionaries.ActiveCustomDictionary
s_ActCustDictNm = o_ActCustDict.Name
s_MyMsg = "Current custom dictionary: " & s_ActCustDictNm & vbLf & "Added: "

Open o_ActCustDict.Path & "\" & o_ActCustDict.Name For Append As #1

For Each r_MyCell In r_MyRng
s_MyWord = r_MyCell.Value
If Not IsEmpty(s_MyWord) Then
If Not Application.CheckSpelling(s_MyWord, CustomDictionary:=s_ActCustDictNm, IgnoreUppercase:=False) Then
n = n + 1
Print #1, s_MyWord
s_MyMsg = s_MyMsg & s_MyWord & ", "
End If
End If
Next r_MyCell

Close #1
o_WordApp.Quit

If n > 0 Then
MsgBox s_MyMsg
Else
MsgBox s_MyMsg & " None needed to be Added!"
End If

End Sub

 

[walt1122]

Hi Joe Was, I hadn't noticed. I had outlook open when I tried the code so there weren't any problems. Worked great.

How are you with counters?? I posed a question a few weeks ago but never got any bites. I have some code from someone that allows me to import .TXT files larger than the 65536 limit imposed by Excel. The counter can be set to the number of lines < 65536 you want and when that number is reached it creates a new TAB and continues importing them all over again. I need the counter to also have an =IF statement or something so I can control when it does break after the perdetermined number of lines set by the counter = some number. Here is the problem, by setting up only by some arbitrary stop line <65536 it can break at the wrong place. It can break lines of data about a person. In this case it is the pension checks a retiree gets one each and every month. So I would like to see all twelve or so lines about the one person before it broke to the next TAB. There are "blanks" between the data or there is a header page that repeats that has words like "NORTHERN". Any way to get this to work the way I have described, so I can keep all the persons data on one TAB and not have it start too near the end of one and force the remaining data onto the next??

thanks

Walt

 

[Norie]

Walt

Can you start a new thread or post a link to the original?

What I would suggest is just adding a simple check for the end/beginning of each record.

But exactly how that would be done would depend on the current code.

 

[walt1122]

Hi Norie,
>Can you start a new thread or post a link to the original?

can do! I think?
http://www.mrexcel.com/board2/viewtopic.php?t=193885&highlight=

>What I would suggest is just adding a simple check for the end/beginning of each record.

simple? maybe for people like you and Joe Was! I wish I had even a smidgen of your knowledge.

>But exactly how that would be done would depend on the current code.
looks something like this:
Sub LargeFileImport()
' This will split a very large text file (FileName)
' Into multiple Text Files (sPath)
' Based on a set number of records (CounterMax)

'Dimension Variables
Dim Datafile As Variant
Dim ResultStr As String
Dim g As String
Dim FileNum As Integer
Dim Counter As Variant
Dim CounterMax As Variant
Dim sPath As String
Dim FileCounter As Integer
Dim FileName As String



'Output File
FileCounter = 1
sPath = "C:\testing\temp_" & FileCounter & ".txt"
'Number of Records in Each Text File
CounterMax = 64500
'Call Autpen
'Ask User for File's Name
Application.DefaultFilePath = ThisWorkbook.Path

Datafile = Application.GetOpenFilename(Title:="Need to locate the Northern Trust Benefit Payment.TXT file. Try Pension Accounting\200X DB Plans... ")
If Datafile = False Then
MsgBox "Please help me find the location of the Northern Trust Benefit Payment.TXT file"
Datafile = Application.GetOpenFilename(Title:="Please locate the Northern Trust Benefit Payment.TXT file")
If Datafile = False Then
Exit Sub
End If
End If
' Opens the data file and imports just the relevant columns
'FileName = "C:\Account Analysis - (180 Char)_030106.txt"
'Check for no entry
FileName = Datafile
'Get Next Available File Handle Number
FileNum = FreeFile()
'Open Text File For Input
Open FileName For Input As #FileNum
'Get Next Available File Handle Number
g = FreeFile()
'Open Text File For Output
Open sPath For Output As #g
'Turn Screen Updating Off
'Application.ScreenUpdating = False
'Set The Counter to 1
Counter = 1

'Loop Until the End Of File Is Reached
Do While Seek(FileNum) <= LOF(FileNum)
'Display Importing Row Number On Status Bar
Application.StatusBar = "Importing Row " & _
Counter & " of text file " & FileName
'Store One Line Of Text From File To Variable
Line Input #FileNum, ResultStr
'Output One Line Of Text From Variable To File
Print #g, ResultStr
ResultStr = vbNullString

'Check to See if we should start a new Output File
If Counter Mod CounterMax = 0 Then
'Close Current Output File
Close #g
'Open a New Ouput File
FileCounter = FileCounter + 1
sPath = "C:\testing\temp_" & FileCounter & ".txt"
g = FreeFile()
Open sPath For Output As #g
End If
'Increment the Counter By 1
Counter = Counter + 1
'Start Again At Top Of 'Do While' Statement
Loop
'Close The Open Text File
Close #g
Close #FileNum
'Remove Message From Status Bar
Application.StatusBar = False
MsgBox "Great, that's Completed! Next step is to pull in the .TXT and convert it to .XLS Just say OK"
Macro10

End Sub


then I have it working on the data by adding in some formulas to get the information in a useable format and then do the subtotals to get the sub totals and total totals.

hope this makes some sense to you.

thanks

Walt

 

[Norie]

Walt

Is there anything in the data that will determine when you would want to start a new file/tab?

This is the code that currently decides whether or not to start a new file/tab.

If Counter Mod CounterMax = 0 Then 
     'Close Current Output File 
     Close #g 
     'Open a New Ouput File 
     FileCounter = FileCounter + 1 
     sPath = "C:\testing\temp_" & FileCounter & ".txt" 
     g = FreeFile() 
     Open sPath For Output As #g 
End If

You would probably replace the If statement with something like this.

If ResultStr = "Something that tells us to create a new file." Then

You would probably have to rearrange some of the other code as well.

Can you post some sample data?

 

[walt1122]

Yes Norie, sample data should be in the link I provided.

http://www.mrexcel.com/board2/viewtopic.php?t=193885&highlight=

The posting some time back shows what a "sample" looks like. It contains names , social security numbers, addresses bank account info so I'm sure you understand why I can only show you a sample. For all intent and purpose it comes to me as if is a finished report ready to print, has the header and page numbers. I have not see at any time where the supplier of the report "Northern Trust" has displayed the individuals data on two pages so I'm thinking the words "Northern Trust" could be a good break-point.

thanks

Walt