Hi Fletcher, thanks for posting the code.
How do you execute Xtractor.hta file?
When use IE6, it prompt me with a form(which I filed in) but without
'submit' button to execute. Perhaps I overlook something ...
Thanks again.
"Fletcher Arnold" <fletch@home.com> wrote in message
news:c1l97r$fe$1@hercules.btinternet.com...[color=blue]
> "Ruby Tuesday" <rubytuezdayz@yahoo.com> wrote in message
> news:c1ku11$1k12ov$1@ID-205437.news.uni-berlin.de...[color=green]
> > Thank you, Fletcher.
> >
> > "Fletcher Arnold" <fletch@home.com> wrote in message
> > news:c1ivca$e8t$1@sparta.btinternet.com...[color=darkred]
> > > "Ruby Tuesday" <rubytuzdayz@yahoo.com> wrote in message
> > > news:c1irh5$1go9g6$1@ID-205437.news.uni-berlin.de...
> > > > Fletcher, thanks for the code. I test it and it works, but there are[/color][/color][/color]
a[color=blue][color=green]
> > few[color=darkred]
> > > > things I'd love to know how.
> > > >
> > > > Instead of displaying it on the msg box, how would you insert it to[/color][/color]
> the[color=green][color=darkred]
> > > > database, say, the access or mysql database? Do I have to use ODBC?[/color][/color]
> How?[color=green][color=darkred]
> > >
> > >
> > > If you can give me a while, I will post a more complete example.
> > >
> > > Fletcher[/color][/color]
>
>
> 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.[/color]
These[color=blue]
> 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)[/color]
and[color=blue]
> copy and paste the code into a new file and save the file as[/color]
"Xtractor.hta"[color=blue]
> The .hta extension is for a html application.
>
> The code was really just for a bit of fun - to try out these hta files.[/color]
One[color=blue]
> 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[/color]
were[color=blue]
> 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>
>
>
>[/color]
