Ruby Tuesday said:
On the basis that the OP wanted to know how to get the code to run, I
thought I would offer a solution which only requires Notepad to create a
working application, provided certain system components are in place. These
components should be present if you have a reasonably up-to-date Windows
installation - so it shouldn't need any fiddling around with.
To get the data into Access, open up any normal text editor (eg NotePad) and
copy and paste the code into a new file and save the file as "Xtractor.hta"
The .hta extension is for a html application.
The code was really just for a bit of fun - to try out these hta files. One
plus side is that I can post plain text to the newsgroup, but there are a
number of downsides, including error handling. If posting attachments were
allowed, I am sure an Access/VBA/DAO solution would be better than the
VBS/ADO code posted here.
Anyway, feel free to try it out and let me know how you get on.
Fletcher
Copy everything below the stars:
' ************************************************
<html>
<head>
<title>Table Extractor</title>
<script language="vbscript">
<!--
Sub DoMain()
Dim lngMaxCols
Dim strFolder
Dim strDbName
Dim strDbPath
Dim strMsg
strFolder = document.all.txtFolder.value
If Right(strFolder,1) <> "\" Then
strFolder = strFolder & "\"
End If
If Not FolderExists(strFolder) Then
Msgbox "Non-existant Folder"
Exit Sub
End If
If CountWordDocs(strFolder) < 1 Then
Msgbox "No Word Docs"
Exit Sub
End If
strDbName = document.all.txtDbName.value
strDbPath = strFolder & strDbName
If FileExists(strDbPath) = True Then
strMsg = "The following file already exists:"
strMsg = strMsg & vbCrLf
strMsg = strMsg & "Do you want to overwrite it?"
If Msgbox(strMsg, vbExclamation OR vbYesNoCancel) <> vbYes Then
Exit Sub
End If
If Not DeleteFile(strDbPath) Then
strMsg = "Error deleting file"
strMsg = strMsg & vbCrLf
strMsg = strMsg & "Check the file is not in use."
MsgBox strMsg, vbCritical
Exit Sub
End If
End If
If IsNumeric(document.all.txtMaxColumns.value) Then
lngMaxCols = Clng(document.all.txtMaxColumns.value)
Else
Msgbox "Columns"
Exit Sub
End If
If (lngMaxCols < 1) OR (lngMaxCols > 200) Then
Msgbox "Columns"
Exit sub
End If
If CreateDb(strDbPath, lngMaxCols) = False Then
Msgbox "Error Creating Database", vbCritical
Exit Sub
End If
ImportDocs strFolder, strDbPath, lngMaxCols
strMsg = "Word tables successfully imported" & vbCrLf
strMsg = strMsg & "Do you want to open the database?"
If Msgbox(strMsg, vbInformation OR vbYesNoCancel) = vbYes Then
StartDb(strDbPath)
End If
End Sub
Function CleanString(strDirty)
Dim strClean
Dim lng
strClean = Trim(strDirty)
If Len(strClean) > 0 Then
strClean = Replace(strClean, Chr(13), vbCrLf)
For lng = Len(strClean) To 1 Step -1
If Asc(Mid(strClean, lng, 1)) > 32 Then
Exit For
End If
Next
strClean = Left(strClean, lng)
End If
If Len(strClean) > 255 Then
strClean = Left(strClean, 250) & "..."
End If
CleanString = strClean
End Function
Function FolderExists(strFolder)
On Error Resume Next
Dim fso
Dim fld
FolderExists = False
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strFolder)
If Err.Number = 0 Then FolderExists = True
Set fld = Nothing
Set fso = Nothing
End Function
Function FileExists(strPath)
On Error Resume Next
Dim fso
Dim fil
FileExists = False
Set fso = CreateObject("Scripting.FileSystemObject")
Set fil = fso.GetFile(strPath)
If Err.Number = 0 Then FileExists = True
Set fil = Nothing
Set fso = Nothing
End Function
Function DeleteFile(strPath)
On Error Resume Next
Dim fso
DeleteFile = False
Set fso = CreateObject("Scripting.FileSystemObject")
fso.DeleteFile strPath, True
If Err.Number = 0 Then DeleteFile = True
Set fso = Nothing
End Function
Sub StartDb(strDbPath)
Dim wshShell
Dim lng
Set wshShell = CreateObject("WScript.Shell")
lng = wshShell.Run(strDbPath, 1)
Set wshShell = Nothing
End Sub
Function CountWordDocs(strFolder)
On Error Resume Next
Dim fil
Dim lng
lng = 0
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strFolder)
If Err.Number = 0 Then
For each fil in fld.Files
If Right(fil.Name, 4) = ".doc" Then
lng = lng + 1
End If
Next
End If
Set fil = Nothing
Set fld = Nothing
Set fso = Nothing
CountWordDocs = lng
End Function
Sub SetFolder()
Dim strFolder
strFolder = BrowseFolder("Choose a folder", &h0007, "c:\")
If Len(strFolder)>0 Then
document.all.txtFolder.value = strFolder
End If
End Sub
Function BrowseFolder(sPrompt, BrowseInfo, root)
On Error Resume Next
Dim oShell
Dim oFolder
Dim iColonPos
Dim oWshShell
Set oShell = CreateObject("Shell.Application")
Set oWshShell = CreateObject("WScript.Shell")
Set oFolder = oShell.BrowseForFolder(&h0&, sPrompt, BrowseInfo, root)
BrowseFolder = oFolder.ParentFolder.ParseName(oFolder.Title).Path
If Err.Number <> 0 Then
BrowseFolder = Null
If oFolder.Title = "Desktop" Then
BrowseFolder = oWshShell.SpecialFolders("Desktop")
End If
iColonPos = InStr(oFolder.Title, ":")
If iColonPos > 0 Then
BrowseFolder = Mid(oFolder.Title, iColonPos - 1, 2) & "\"
End If
End If
End Function
Function GetFolder()
Dim objShell
Dim objFolder
set objShell = CreateObject("Shell.Application")
set objFolder = objShell.BrowseForFolder(0, "Example", 0, "" )
If (not objFolder is nothing) then
GetFolder = "X" 'objFolder.Path
Else
GetFolder = ""
End if
set objFolder = Nothing
set objShell = Nothing
End function
Sub ImportTables(wdDoc, rst, lngMaxCols)
Dim wdTbl
Dim lngTblNo
Dim wdRow
Dim wdCol
Dim strValue
lngTblNo = 0
For Each wdTbl In wdDoc.Tables
lngTblNo = lngTblNo + 1
For Each wdRow In wdTbl.Rows
rst.AddNew
rst(1) = wdDoc.path & "\" & wdDoc.Name
rst(2) = lngTblNo
rst(3) = wdRow.Index
For Each wdCol In wdTbl.Columns
strValue = wdTbl.Cell(wdRow.Index, wdCol.Index).Range.Text
strValue = CleanString(strValue)
If Len(strValue) > 0 And (wdCol.Index < (lngMaxCols + 1)) Then
rst(3 + wdCol.Index) = strValue
End If
Next
rst.Update
Next
Next
Set wdTbl = Nothing
End Sub
Sub ImportDocs(strFolder, strDbPath, lngMaxCols)
Dim strSQL
Dim strCnn
Dim cnn
Dim rst
Dim wdApp
Dim wdDoc
Dim fso
Dim fld
Dim fil
strCnn = "Provider=Microsoft.Jet.OLEDB.4.0;"
strCnn = strCnn & "Data Source=" & strDbPath
Set cnn = CreateObject("ADODB.Connection")
cnn.ConnectionString = strCnn
cnn.Open
strSQL = "SELECT * FROM tblWordTables"
Set rst = CreateObject("ADODB.Recordset")
rst.Open strSQL, cnn, 2, 3
Set wdApp = CreateObject("Word.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(strFolder)
For Each fil In fld.Files
If Right(fil.Name, 4) = ".doc" Then
Set wdDoc = wdApp.Documents.Open(fil.Path)
ImportTables wdDoc, rst, lngMaxCols
wdDoc.Close
Set wdDoc = Nothing
End If
Next
Set fil = Nothing
Set fld = Nothing
Set fso = Nothing
wdApp.Quit
Set wdApp = Nothing
rst.Close
Set rst = Nothing
cnn.Close
Set cnn = Nothing
End Sub
Function CreateTextColumn(catCatalog, tblTable, strColumnName)
On Error Resume Next
Const adVarWChar = 202
Dim col
Set col = CreateObject("ADOX.Column")
col.ParentCatalog = catCatalog
col.Name = strColumnName
col.Type = adVarWChar
col.properties("Nullable").Value = True
col.Properties("Jet OLEDB:Allow Zero Length").Value = False
tblTable.Columns.Append col
If Err.Number = 0 Then CreateTextColumn = True
Set col = Nothing
End Function
Function CreateLongColumn(catCatalog, tblTable, strColumnName)
On Error Resume Next
Const adInteger = 3
Dim col
Dim idx
Set col = CreateObject("ADOX.Column")
col.ParentCatalog = catCatalog
col.Name = strColumnName
col.Type = adInteger
tblTable.Columns.Append col
If Err.Number = 0 Then
Set col = Nothing
Set idx = CreateObject("ADOX.Index")
idx.Name = strColumnName
idx.Unique = False
Set col = CreateObject("ADOX.Column")
col.Name = strColumnName
idx.Columns.Append col
tblTable.Indexes.Append idx
If Err.Number = 0 Then
CreateLongColumn = True
End If
End If
Set idx = Nothing
Set col = Nothing
End Function
Function CreatePrimaryKey(catCatalog, tblTable, strColumnName)
On Error Resume Next
Const adInteger = 3
Dim col
Set col = CreateObject("ADOX.Column")
col.ParentCatalog = catCatalog
col.Name = strColumnName
col.Type = adInteger
col.Properties("AutoIncrement").Value = True
tblTable.Columns.Append col
If Err.Number = 0 Then
tblTable.Keys.Append "PrimaryKey", 1, strColumnName
If Err.Number = 0 Then
CreatePrimaryKey = True
End If
End If
Set col = Nothing
End Function
Function CreateDb(strPath, lngMaxCols)
On Error Resume Next
Dim cat
Dim tbl
Dim col
Dim str
Dim strColName
Dim lngColCount
CreateDb = True
Set cat = CreateObject("ADOX.Catalog")
str = "Provider=Microsoft.Jet.OLEDB.4.0;"
str = str & "Jet OLEDB:Engine Type=5;"
str = str & "Data Source=" & strPath
cat.Create str
If Err.Number <> 0 Then Exit Function
Set tbl = CreateObject("ADOX.Table")
tbl.ParentCatalog = cat
tbl.Name = "tblWordTables"
If Not CreatePrimaryKey(cat, tbl, "ID") Then Exit Function
If Not CreateTextColumn(cat, tbl, "DocPath") Then Exit Function
If Not CreateLongColumn(cat, tbl, "TableNo") Then Exit Function
If Not CreateLongColumn(cat, tbl, "RowNo") Then Exit Function
For lngColCount = 1 to lngMaxCols
strColName = Cstr(1000 + lngColCount)
strColName = "Column" & Mid(strColName, 2)
If Not CreateTextColumn(cat, tbl, strColName) Then
Exit Function
End If
Next
cat.Tables.Append tbl
If Err.Number = 0 Then
CreateDb = True
Else
Msgbox Err.Description
End If
Set tbl = Nothing
Set cat = Nothing
End Function
-->
</script>
<body bgcolor="#CCCCFF">
<table>
<th colspan="2" align="center">Extract Tables From Microsoft Word</th>
<tr><td> </td><td> </td></tr>
<tr>
<td>Document Folder</td>
<td><input type="text" id="txtFolder" value="C:\"</td>
</tr>
<tr>
<td>Database Name</td>
<td><input type="text" id="txtDbName" value="WordTables.mdb"</td>
</tr>
<tr>
<td>Maximum Columns</td>
<td><input type="text" id="txtMaxColumns" value="10"</td>
</tr>
<tr><td> </td><td> </td></tr>
<tr>
<td><input type="button" name="cmdFolder" value="Change Folder"
onclick="SetFolder()"></td>
<td><input type="button" name="cmdImport" value="Import Tables"
onclick="DoMain()"></td>
</tr>
</table>
</body>
</html>
