dankemper.net 2.0 :: VBScript

VBScript Coming Soon - VBScript Limitations

So, you have tried to get Microsoft Access to export your floating point values with a precision of more that just two (2)? The application itself will not do this for you. Even using a pre-defined format and setting precision yourself does nothing to effect an extraction/export of floating point numerical columns (attributes). I present this script to you to solve this problem. Since all databases are different, I should explain a little about the data I am working with first.

Let's call the database "HDB" for Historical Database. HDB contains just one table, "HISTORY", which has five attributes, and they are varname:Text, datetime:Date/Time, seconds:Number, floatval:Number, alpha:Text. The script uses ADO with regular expressions for date matching and conversion. If you are not familiar with regular expression substrings and/or character classes, I suggest you research perlre.

' MSAccess HDB database extraction utility

' Declare constants
Const Jet10 = 1 
Const Jet11 = 2 
Const Jet20 = 3 
Const Jet3x = 4 
Const Jet4x = 5

Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8

Sub convertDBToTab(cString, CSVFile)

Const adOpenStatic = 3
	Const adLockReadOnly = 1
	Const adCmdText = &H0001
	Const adOpenDynamic = 2
	Const adLockOptimistic = 3

Dim fso, FileCSV, myFile, file, fStream, f2Stream

Set fso = CreateObject("Scripting.FileSystemObject")

If (Not (fso.FileExists(CSVFile))) Then
      		Set myFile = fso.CreateTextFile(CSVFile, True)
      		myFile.Close
   	End If
   
   	Set file = fso.GetFile(CSVFile)
	Set fStream = file.OpenAsTextStream(ForWriting)

' MsgBox FileCSV.ParentFolder & "\" & FileCSV.Name

Dim objAccessConn, objAccessRs
	Set objAccessConn = CreateObject("ADODB.Connection")
	objAccessConn.Open cString

Set objAccessRs = CreateObject("ADODB.Recordset")
	objAccessRs.Open "Select * From HISTORY",objAccessConn,adOpenDynamic,adLockOptimistic

MsgBox "Connected to Database OK."

If (Not (fso.FileExists("C:\temp\extractLog.txt"))) Then
      		Set myFile = fso.CreateTextFile("C:\temp\extractLog.txt", True)
      		myFile.Close
	End If
   
	Set file = fso.GetFile("C:\temp\extractLog.txt")
	Set f2Stream = file.OpenAsTextStream(ForWriting) ' overwrite if exists
	Dim ctr
	ctr = 0

Do While Not objAccessRS.EOF
		Dim varName, dAndT, hdmSec, hdFloatVal, hdAlphaVal, MatchesCollection, rVal
		Dim month, day, year, hour, min, sec, ampm
		ctr = ctr + 1
	
		varName = objAccessRs("varname") 
		dAndT = objAccessRs("datetime")
		hdmSec = objAccessRs("seconds")
		hdFloatVal = objAccessRs("floatval")
		hdAlphaVal = objAccessRs("alpha")

Set regexpObject = New RegExp
   		With regexpObject
   			.Pattern = "(\d+)\/(\d+)\/(\d+)\s(\d+):(\d+):(\d+)\s([APM])"
   			.IgnoreCase = True
  		 	.Global = True
   		End With

rVal = regexpObject.Test(dAndT)
		If rVal Then
			Set MatchesCollection = regexpObject.Execute(dAndT)
			For Each Match in MatchesCollection
				month = Match.SubMatches(0)
				day = Match.SubMatches(1)
				year = Match.SubMatches(2)
				hour = Match.SubMatches(3)
				min = Match.SubMatches(4)
				sec = Match.SubMatches(5)
				ampm = Match.SubMatches(6)
				' MsgBox hour & ":" & min & ":" & sec & " --- " & ampm 
				If (Len(month) = 1) Then
					month = "0" & month
				End If
				If ((hour <> "12") AND (ampm = "P")) Then
					hour = hour + 12
					' MsgBox hour
				End If
				if ((hour = "12") AND (ampm = "A")) Then
					hour = "00"
					' MsgBox hour
				End If 
				dAndT = month & "/" & day & "/" & year & " " & hour & ":" & min & ":" & sec
			Next
		End If

fStream.WriteLine(varName & ", " & dAndT & ", " & hdmSec & ", " & hdFloatVal & ", " & hdAlphaVal)
		f2Stream.Write("Processing Line: " & ctr & vbCrLf)
	
		objAccessRS.MoveNext
	Loop

fStream.Close
	f2Stream.Close
	objAccessRs.Close
	objAccessConn.Close

Set objAccessRs = Nothing
	Set objAccessConn = Nothing

End sub

Dim WSHShell, strRegKey, connectionString
Dim dbFileName, dbOutFile

Set WSHShell = WScript.CreateObject("WScript.Shell")

' Let's see if command-line args were given
' Example call to this script would be 
' msAccessToText.vbs C:\temp\hdb.mdb C:\temp\hdb_data_out.txt

If WScript.Arguments.Count = 2 Then
	
	dbFileName = WScript.Arguments(0)
	dbOutFile = WScript.Arguments(1)

ElseIf WScript.Arguments.Count = 1 Then
	
	dbOutFile = WScript.Arguments(0)
	' We have the outfile, but not the database location and filename
	' get that from the registry
	strRegKey = "HKEY_LOCAL_MACHINE\SOFTWARE\MyCompany\HDB_DB"
	' MsgBox "The Registry Key is: " & WSHShell.RegRead(strRegKey)
	dbFileName = WSHShell.RegRead(strRegKey)

Else

' Get the registry entries for the database connection
	' and just set the outfile to mdbOut.txt

strRegKey = "HKEY_LOCAL_MACHINE\SOFTWARE\MyCompany\HDB_DB"
	' MsgBox "The Registry Key is: " & WSHShell.RegRead(strRegKey)
	dbFileName = WSHShell.RegRead(strRegKey)

' Example call is: convertDBToTab "c:\temp\hdb.mdb", "outfile.csv"
	' Set the outfile because it wasn't given on the command line 
	dbOutFile = "mdbOut.txt"

End If

If (dbFileName <> "") Then
	' MsgBox "Using Access Database, connecting now ..."
	connectionString = "Driver={Microsoft Access Driver (*.mdb)};" & "Dbq=" & dbFileName & ";" & "Uid=Admin;" & "Pwd=;"
End If

' Make the call
convertDBToTab connectionString, dbOutFile

' End Script