'Alan Kaplan 11-21-08, 4-1-2009, 4-2
'alan dot kaplan at va dot gov
'command line syntax: uniquelist filewithdupes.txt newfile header
'header is YES/NO
'4-2 fixes no header CSV queries

Option Explicit 
Const ForReading = 1 
Const ForAppending = 8 
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H0001

Dim cstring, retval
Dim OConn, oRS, strPathtoTextFile, strFileName
Dim strFile, strpath 
Dim strFileFullName, strFilePath, strHeader, strLine1 
dim quote
quote=chr(34)
Dim strExt, tArray
Dim strNewFile, appendout
Dim bEcho, bCSV, wshshell
Set wshShell = WScript.CreateObject("WScript.Shell")
Dim strDelimit, strField1, batch

If IsCScript Then 
	bEcho = True
Else
	bEcho = False
End If 

Set OConn = CreateObject("ADODB.Connection")
Set oRS = CreateObject("ADODB.Recordset")

Dim fso,oFile,oRead
Set fso = CreateObject("Scripting.FileSystemObject")

If WScript.Arguments.Count >0 Then 
	strFileFullName = WScript.Arguments(0)
Else
	Dim message
	message = "This script extracts, counts and writes a unique list of items from a text or CSV file. " & _
	" You can drag a file onto it or use the file name as a parameter.  By default, the new file is written to the" & _
	" same path as where the script resides. If a CSV file, the unique list is just the first column."
	retval = MsgBox (message,vbOKCancel,"Unique List Welcome")
	If retval = vbCancel Then WScript.Quit
GetName
End If 

Set oFile = fso.GetFile(strFileFullName)
strFile=  ofile.name
strFilePath = ofile.parentfolder.path

tArray = Split (strFile,".")
strExt = tArray(UBound(tArray))
If LCase(strExt) = "csv" Then
	 bCSV = True
Else
	bCSv = False
End If 

If bCSV Then 
	strDelimit = ";FMT=Delimited"
End If 

strNewFile = strFilePath & "\UniqueList_" & strFile  	'Name of log file. 

If WScript.Arguments.Count = 2 Then 
	strNewFile = WScript.Arguments(1)
End If 

If WScript.Arguments.Count = 3 Then
	strHeader = WScript.Arguments(2)
	batch = True 
Else
	Set oRead = fso.OpenTextFile(strFileFullName,ForReading)
	strLine1 = oRead.ReadLine
	oRead.Close
	Set oRead = Nothing
		retval = MsgBox ("Is this line a header?" & VbCrLf & strLine1,vbYesNoCancel,"Header Present?")
		Select Case retval
			Case vbYes
				strHeader = "Yes"
			Case vbNo
				strHeader = "No"
			Case Else
				WScript.Quit
		End Select 
End If 


If strHeader = "Yes" then 
				If InStr(strLine1,",") Then 
					tArray = Split(strLine1,",")
					strField1 = tArray(0)
				Else
					strField1 = strLine1
				End If 
				strField1 = "[" & strField1 & "]"
Else
				if bCSV = True Then 
					strField1 = "F1"
				Else
					strField1 = "*"
				End If 
End If 



If fso.FileExists(strNewFile) Then fso.DeleteFile strNewFile, True 

cstring =  "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="&_
	strFilePath & "\;Extended Properties=" & quote & "Text;HDR=" &  strHeader & strDelimit&  quote & ";"

oConn.Open cstring 

'sorted 
Dim strQuery
strQuery = "SELECT Distinct " & strField1 & " FROM ["  & strFile & "];"
oRS.Open strQuery  ,OConn, adOpenStatic, adLockOptimistic, adCmdText

If Not batch Then 
	retval = MsgBox(oRS.RecordCount & " unique records found in column 1.  Write out the list?",vbYesNo,"Write List?")
	If retval = vbNo Then WScript.Quit
End If 

If WScript.Arguments.Count < 2 Then
	strNewFile = InputBox("Path of new unique file","New file path",strNewFile)
	If strNewFile = "" Then WScript.Quit
End If 

Set appendout = fso.OpenTextFile(strNewFile, ForAppending, True)

Do Until oRS.EOF
  	 EchoAndLog oRS.Fields.Item(0)
     oRS.MoveNext
Loop

appendout.Close

MsgBox "Done.  New file is: " & VbCrLf & strNewFile,vbInformation + vbOKOnly,"Complete"

Sub GetName()
	'just to look nice.  Does not work with server, though...
	On Error Resume Next 
	Dim objDialog
	Dim strInitDir, intResult
	'get path name, ending in \
	Dim scriptpath
	scriptpath = Left(Wscript.ScriptFullName, InStrRev(Wscript.ScriptFullName, "\"))
	
	strInitDir =  scriptpath
	Set objDialog = CreateObject("UserAccounts.CommonDialog")
	If Err = 0 Then 
		objDialog.Filter = "Text Files|*.txt|CSV Files|*.csv|All Files|*.*"
		objDialog.FilterIndex = 1
		objDialog.InitialDir = strInitDir
		intResult = objDialog.ShowOpen
		
		If intResult = 0 Then
		    Wscript.Quit
		    Else
		    strFileFullName = objDialog.FileName
		End If
	Else
		strFileFullName = InputBox("Path to Source","Path",strpath & "\") 
	End If 
	On Error GoTo 0 
End Sub 


Sub EchoAndLog (message)
	'Echo output and write to log
	if bEcho Then Wscript.Echo message
	AppendOut.WriteLine message
End Sub  


Function IsCScript()
    If (InStr(UCase(WScript.FullName), "CSCRIPT") <> 0) Then
        IsCScript = True
    Else
        IsCScript = False
    End If
End Function