Sub sb_KeyWords_2()
Dim fso As FileSystemObject
Dim strR As TextStream, strW As TextStream
Dim lIdx_Phr&(), lIdx_Lin&()
Dim i%, j%, k%, m%, n%, iQty%, iW_Lin%(3), iW_Phr%(3), iFormat%
Dim bU_Lin As Boolean, bU_Phr As Boolean
Dim sPath$, sFileR$, sFileW$, sDlm$, sSfx$, sExt$, sSrc$(), sTgt$
' USER DATA SETUP
iW_Lin(1) = 290: iW_Lin(2) = 300 ' Low & Upper bounds of lines in target file
iW_Phr(1) = 3: iW_Phr(2) = 6 ' Low & Upper bounds of elements in line
sPath = "C:\Path1\Path2\Path3" ' type real path here w/o ending slash
sFileR = "TextPhrases" ' Name of sourse file
sSfx = "Rnd" ' Suffix of target file
sExt = "txt" ' A same extension for both of files
sDlm = "," ' Delimiter
iFormat = TristateUseDefault ' -2 - Opens the file using the system default
' iFormat = TristateMixed ' -2 - Opens the file using the system default
' iFormat = TristateTrue ' -1 - Opens the file as Unicode
' iFormat = TristateFalse ' 0 - Opens the file as ASCII
' PROCEDURE
sFileW = sFileR & "_" & sSfx
sFileR = sPath & "\" & sFileR & "." & sExt
sFileW = sPath & "\" & sFileW & "." & sExt
Set fso = CreateObject("Scripting.FileSystemObject")
With fso
Set strR = .OpenTextFile(sFileR, ForReading, , iFormat)
With strR
Do While Not .AtEndOfStream
iQty = iQty + 1
ReDim Preserve sSrc(1 To iQty)
sSrc(iQty) = .ReadLine
Loop
End With
Set strW = .OpenTextFile(sFileW, ForWriting, True, iFormat)
Randomize (GetTickCount) ' Set lines per file qty
iW_Lin(0) = Int((iW_Lin(2) - iW_Lin(1) + 1) * Rnd + iW_Lin(1))
ReDim lIdx_Lin(1 To 1)
For i = 1 To iW_Lin(0)
Sleep (Int(10 * Rnd + 1))
Randomize (GetTickCount) ' Set phrases qty
iW_Phr(0) = Int((iW_Phr(2) - iW_Phr(1) + 1) * Rnd + iW_Phr(1))
bU_Lin = True
ReDim Preserve lIdx_Lin(1 To i)
Do
sTgt = ""
ReDim lIdx_Phr(1 To 1)
Sleep (Int(10 * Rnd + 1))
Randomize (GetTickCount) ' Set phrases per line qty
For j = 1 To iW_Phr(0)
bU_Phr = True
ReDim Preserve lIdx_Phr(1 To j)
Do
k = Int((iQty - 1 + 1) * Rnd + 1)
For m = 1 To (j - 1)
bU_Phr = (k <> lIdx_Phr(m))
If Not bU_Phr Then Exit For
Next
Loop Until bU_Phr
lIdx_Phr(j) = k
lIdx_Lin(i) = lIdx_Lin(i) + k * (10 ^ j)
sTgt = sTgt & sDlm & Trim(sSrc(k))
Next
sTgt = Right(sTgt, Len(sTgt) - 1)
For n = 1 To (i - 1)
bU_Lin = (lIdx_Lin(n) <> lIdx_Lin(i))
If Not bU_Lin Then Exit For
Next
Loop Until bU_Lin
strW.WriteLine (sTgt)
Next
End With
End Sub
|
