Free Article Spinner Code for Free Traffic System

Every article spinner might have it's own definition and tags. But here I'm only going to deal with Article Spinning as it relates to Free Traffic System.

"Spinning" means you write variations of the article right in the article body. For example, suppose you had a sentence like this...

It uses many well known tactics.

Free Traffic System says create variations of your sentence doing this...

It uses [spin]many|a lot of|lots of|numerous[/spin] well known tactics.

Form that, Free Traffic System can publish the same content on 30 blogs without ever getting any duplicate content flags or penalties. If you create variations of many of your sentences, Free Traffic System can literally generate countless versions of your article.

Yes, the example above was created using my macro.

I was over at the SquidU forum and I found myself reading posts that [spin]said|supposed|thought|whispered[/spin] lensmasters were using Free Traffic System. Free Traffic System is a website where article authors get together with blog owners. The blog owners publish the article content on their blogs, including up to 2 backlinks for a 450 word article.

I was [spin]curious|inquisitive|inquiring|snooping[/spin], so I signed up for the [spin]free|gratis|free of charge|without charge[/spin] account. I am an article writer, so naturally I [spin]spent|exhausted|used up|tired[/spin] my time only in the portion of Free Traffic System that dealt with submitting articles for backlinks. For [spin]each|every[/spin] article I submit, I'm guaranteed 60 backlinks. Two backlinks per article, submitted to 30 [spin]different|dissimilar|diverse|unlike[/spin] blogs.

Now, Free Traffic System wants you to " spin " articles to get [spin]higher|senior|superior|advanced[/spin] quality backlinks. The video tutorial kept repeating that. Personally, I wish there had been an HTML guide, and not a video.

Now, being a developer, I can't just take all my articles and " spin " them by hand. That would take hours and hours of [spin]manual|physical|labor-intensive|blue-collar[/spin] labor. Instead, I [spin]created|shaped|bent|fashioned[/spin] a macro inside Microsoft Word to help me spin them. I'm sharing that code with you here.

The code is Microsoft Word macro. The steps to use are...

1) Open your article in Microsoft Word.

2) Cut & paste the macro code (see below) into a Word macro.

3) Execute the macro called "SpinArticle".

4) The macro prompts you at every replace it makes, so you can decide if the replacement is good or if you want to cancel. The synonym generator can't know if it's got the right meaning, nor does it parse the sentence. It simply suggests synonyms. You have to make the final decision if you want to keep the variations.

And that it. After you confirm all the replacements, you'll have a spun article ready for use with Free Traffic System.

Now, the code does a couple of things. One, it removes all the [spin] tags when it starts. That way it won't spin something that has already been spun. Two, it's only spinning adjectives (see the code and you'll see what I mean). I found that spinning adjectives creates plenty of variations. Plus, you probably don't want to modify your nouns or verbs. Adjectives are safe, easy replaces.

Download the Microsoft Word document to get the latest version. You can also cut & paste the code below, but it's an older, less functional version. I added a custom "user form" to the Word Document and there's no way I know of to convert that to something that can be cut & paste. So, if you want the the most fully functional code, download the Word Document.

Option Explicit

'* ********* ********* ********* ********* *********
'* prompts to add [spin] tags to the active document
'* ********* ********* ********* ********* *********
Public Sub SpinArticle()
Dim objSI As Word.SynonymInfo
Dim strWord As String
Dim strData As String
Dim strResult As String
Dim arrItems() As String
Dim blnReplaced As Boolean
Dim i As Integer
Dim j As Integer
Dim intMax As Integer
Dim blnIsCap As Boolean
Dim strTemp As String
Dim strChar As String
Dim lngNumWords As Long
Dim strCap As String
Dim strPunc As String

RemoveTags

strResult = ""
strCap = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
strPunc = ".!?,;"

'* begin looping through every word in the ActiveDocument
lngNumWords = ActiveDocument.Words.Count
For j = 1 To lngNumWords
strWord = Trim(ActiveDocument.Words(j))
blnReplaced = False

'* only worry about large words
If Len(strWord) > 3 Then
Set objSI = Word.SynonymInfo(strWord)

'* check if the word is a NOUN or an ADJECTIVE
If UBound(objSI.PartOfSpeechList) <> 0 Then
'If objSI.PartOfSpeechList(1) = wdNoun Then
If objSI.PartOfSpeechList(1) = wdAdjective Then

'* check is synonyms found
If objSI.Found = True Then

'* check for capitalization
strChar = Left(strWord, 1)
If InStr(strCap, strChar) > 0 Then
blnIsCap = True
Else
blnIsCap = False
End If

'* examine the list of synonyms and prepare [spin] tags
arrItems = objSI.SynonymList(1)
'arrItems = objSI.RelatedWordList
If UBound(arrItems) <> 0 Then

strData = "[spin]" & Trim(strWord)
intMax = UBound(arrItems)
If intMax > 3 Then intMax = 3
For i = 1 To intMax
strTemp = arrItems(i)
If blnIsCap Then
strTemp = UCase(Left(strTemp, 1)) _
& Right(strTemp, Len(strTemp) - 1)
End If
strData = strData & "|" & strTemp
Next i
strData = strData & "[/spin]"

'* confirm this replacement is good
If j > 3 And j < lngNumWords - 3 Then
strTemp = ActiveDocument.Words(j - 3) _
& " " & ActiveDocument.Words(j - 2) _
& " " & ActiveDocument.Words(j - 1) _
& " " & Chr(34) & strWord & Chr(34) _
& " " & ActiveDocument.Words(j + 1) _
& " " & ActiveDocument.Words(j + 2) _
& " " & ActiveDocument.Words(j + 3)
Else
strTemp = Chr(34) & strWord & Chr(34)
End If
strTemp = InputBox("Change " & vbCrLf _
& strTemp & vbCrLf _
& " to " & vbCrLf _
& strData)
If StrPtr(strTemp) = 0 Then
'* user pressed cancel
Else
blnReplaced = True
strResult = strResult & " " & strData
End If
End If
End If
End If
End If
End If

'* if the word was not replace, add the original word to the result
If blnReplaced = False Then
If InStr(strPunc, strWord) > 0 Then
strResult = strResult & strWord
Else
strResult = strResult & " " & strWord
End If
End If
Next j

ActiveDocument.Select
Selection.Text = strResult

End Sub

'* ********* ********* ********* ********* *********
'* removes [spin] tags from the active document
'* ********* ********* ********* ********* *********
Public Sub RemoveTags()
Dim intStart As Integer
Dim intEnd As Integer
Dim strData As String
Dim arrItems() As String

'* move to the beginning of the document
Selection.HomeKey Unit:=wdStory

'* find the first [spin] tag
Selection.Start = 0
With Selection.Find
.Text = "[spin]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute

'* begin looping while [spin] tags are found
While Selection.Start > 0
intStart = Selection.Start

'* locate the ending [/spin] tag
With Selection.Find
.Text = "[/spin]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute

intEnd = Selection.End

'* adjust the selection to capture [spin]...[/spin]
Selection.Start = intStart
Selection.End = intEnd
Selection.Select

RemoveSelectionTags

'* locate the next [spin] tag
Selection.Start = 0
With Selection.Find
.Text = "[spin]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute

'* continue the looping
Wend
End Sub

'* ********* ********* ********* ********* *********
'* removes [spin] tags wrapping the current selection
'* ********* ********* ********* ********* *********
Public Sub RemoveSelectionTags()
Dim strData As String
Dim arrItems() As String

'* remove the [spin] tags
strData = Selection.Text
strData = Replace(strData, "[spin]", "")
strData = Replace(strData, "[/spin]", "")

'* split the alternates by the pipe delimiter
'* use the first alternative
arrItems = Split(strData, "|")
strData = arrItems(0)

Selection.Text = strData
End Sub