Ms Word to HTML converter

VERSION 5.00
Begin VB.Form W2H
Caption = "IRES Word2HTML Converter"
ClientHeight = 6720
ClientLeft = 60
ClientTop = 360
ClientWidth = 11355
Icon = "W2H.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
ScaleHeight = 6720
ScaleWidth = 11355
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton Command1
Caption = "C&lear Log"
Height = 375
Left = 9120
TabIndex = 16
Top = 6120
Width = 2055
End
Begin VB.CommandButton cmdC2C
Caption = "&Copy Log to Clipboard"
Height = 375
Left = 6240
TabIndex = 15
Top = 6120
Width = 2295
End
Begin VB.ListBox lstLog
Height = 3570
Left = 6240
TabIndex = 13
Top = 2400
Width = 4935
End
Begin VB.CommandButton cmdC2H
Caption = "Convert to &HTML"
Height = 495
Left = 7440
TabIndex = 12
Top = 1440
Width = 2415
End
Begin VB.TextBox txtHTMLDest
Height = 375
Left = 6120
TabIndex = 10
Text = "C:\HTML"
Top = 720
Width = 5055
End
Begin VB.Frame Frame1
Height = 6495
Left = 120
TabIndex = 0
Top = 120
Width = 5895
Begin VB.ListBox fileList
Height = 5460
Left = 2760
Style = 1 'Checkbox
TabIndex = 5
Top = 840
Width = 2895
End
Begin VB.ComboBox cmbPattern
Height = 315
Left = 120
Style = 2 'Dropdown List
TabIndex = 4
Top = 6000
Width = 2535
End
Begin VB.DirListBox dirList
Height = 4815
Left = 120
TabIndex = 3
Top = 840
Width = 2535
End
Begin VB.DriveListBox drvList
Height = 315
Left = 120
TabIndex = 2
Top = 480
Width = 2535
End
Begin VB.CommandButton cmdSelList
Caption = "&Select All"
Height = 375
Left = 4320
TabIndex = 1
Top = 360
Width = 1335
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "Drive / Path:"
Height = 195
Left = 120
TabIndex = 8
Top = 240
Width = 915
End
Begin VB.Label Label2
Caption = "Select File(s) for Conversion:"
Height = 435
Left = 2760
TabIndex = 7
Top = 360
Width = 1410
WordWrap = -1 'True
End
Begin VB.Label Label3
AutoSize = -1 'True
Caption = "File Pattern:"
Height = 195
Left = 120
TabIndex = 6
Top = 5760
Width = 840
End
End
Begin VB.FileListBox fList
Height = 1260
Left = 3240
TabIndex = 9
Top = 4200
Width = 975
End
Begin VB.Label Label5
AutoSize = -1 'True
Caption = "Conversion Log:"
Height = 195
Left = 6240
TabIndex = 14
Top = 2160
Width = 1155
End
Begin VB.Label Label4
Caption = "HTML Destination:"
Height = 255
Left = 6120
TabIndex = 11
Top = 480
Width = 2295
End
End
Attribute VB_Name = "W2H"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub cmdC2C_Click()
Dim i2 As Integer
Clipboard.Clear
Dim aLog As String
For i2 = 0 To lstLog.ListCount - 1
aLog = aLog & lstLog.List(i2) & vbCrLf
Next
Clipboard.SetText aLog
End Sub

Private Sub cmdC2H_Click()
Me.Enabled = False
Dim aResult As String, afile As String, apath As String
Dim i2 As Integer
Dim aCurrentFileSelectedForConversion As String

For i2 = 0 To fileList.ListCount - 1
aCurrentFileSelectedForConversion = ""
If fileList.Selected(i2) = True Then
'Do While Len(aFile)

afile = fileList.List(i2)
apath = dirList.Path & "\"
If UCase(Right$(afile, 4)) = ".DOC" Then
aCurrentFileSelectedForConversion = afile
aResult = WordToHTML(apath & afile, txtHTMLDest.Text & "\" & Left(afile, Len(afile) - 4) & ".htm")
If aResult = "Success" Then
lstLog.AddItem aCurrentFileSelectedForConversion & " Successfully Converted"
Else
lstLog.AddItem aCurrentFileSelectedForConversion & " Failed to convert. Reason - " & aResult
End If
End If
End If
DoEvents
Next
Me.Enabled = True
MsgBox "Conversion Completed !!"
End Sub

Private Sub Command1_Click()
lstLog.Clear
End Sub

Private Sub Form_Load()
cmbPattern.AddItem "Word Files (*.DOC)."
cmbPattern.AddItem "All Files (*.*)."
cmbPattern.ListIndex = 0

'dirList.Path = drvList.Drive
On Error Resume Next
dirList.Path = "C:\"

Dim DirectoryFound As String

On Error GoTo 0
DirectoryFound = Dir(txtHTMLDest.Text, vbDirectory)
If (Len(DirectoryFound) = 0 Or Err = 76) Then
MkDir txtHTMLDest.Text
End If
End Sub
Private Sub cmbPattern_Click()
Dim pos1 As Integer
Dim pos2 As Integer
Dim txt As String

txt = cmbPattern.Text
pos1 = InStrRev(txt, "(")
pos2 = InStrRev(txt, ")")
fList.Pattern = Mid$(txt, pos1 + 1, pos2 - pos1 - 1)

End Sub
Private Sub fList_PatternChange()
fileList.Clear

Dim i As Integer
For i = 0 To fList.ListCount - 1
fileList.AddItem fList.List(i)
Next
End Sub



Private Sub drvSelect_Change()
'On Error GoTo DriveError
dirList.Path = drvList.Drive
Exit Sub

DriveError:
drvList.Drive = dirList.Path
Exit Sub

End Sub
Private Sub cmdSelList_Click()
Dim i As Integer
If cmdSelList.Caption = "&Select All" Then
cmdSelList.Caption = "&Deselect All"
For i = 0 To fileList.ListCount - 1
fileList.Selected(i) = True
Next i

Else
cmdSelList.Caption = "&Select All"
For i = 0 To fileList.ListCount - 1
fileList.Selected(i) = False
Next i

End If

End Sub
Private Sub drvList_Change()
'On Error GoTo DriveError
dirList.Path = drvList.Drive
Exit Sub

DriveError:
drvList.Drive = dirList.Path
Exit Sub
End Sub

Private Sub dirList_Change()
fileList.Clear
fList.Path = dirList.Path
Dim i As Integer
For i = 0 To fList.ListCount - 1
fileList.AddItem fList.List(i)
Next
cmdSelList.Caption = "&Select All"
End Sub

'Private Sub fList_Click()
' cmdConvertToWiki_Click
'End Sub
'-----------------------------------------------------------------------
Function WordToHTML(strWordDoc, strHTMLDoc)
On Error GoTo errH

Dim objWord
Set objWord = New Word.Application ' CreateObject("Word.Application")
objWord.Visible = False
objWord.Documents.Open (strWordDoc)

If Err.Number <> 0 Then
WordToHTML = Err.Description
Else
' Dim FileFormat
' Dim LockComments
' Dim Password
' Dim AddToRecentFiles
' Dim WritePassword
' Dim ReadOnlyRecommended
' Dim EmbedTrueTypeFonts
' Dim SaveNativePictureFormat
' Dim SaveFormsData
' Dim SaveAsAOCELetter
'
' FileFormat = wdFormatHTML
' LockComments = True
' Password = ""
' AddToRecentFiles = False
' WritePassword = ""
' ReadOnlyRecommended = False
' EmbedTrueTypeFonts = False
' SaveNativePictureFormat = True
' SaveFormsData = False
' SaveAsAOCELetter = False


' objWord.activedocument.SaveAs strHTMLDoc, FileFormat, LockComments, Password, AddToRecentFiles, WritePassword, ReadOnlyRecommended, EmbedTrueTypeFonts, SaveNativePictureFormat, SaveFormsData, SaveAsAOCELetter

objWord.ActiveDocument.SaveAs FileName:=strHTMLDoc, FileFormat:=10 _
, LockComments:=True, Password:="", AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=True, SaveFormsData:=False, SaveAsAOCELetter:= _
False

'check errors (this should be another routine)
If Err.Number <> 0 Then
WordToHTML = Err.Description
Else
WordToHTML = "Success"
End If
End If
objWord.ActiveDocument.Close
objWord.Quit
Set objWord = Nothing
Exit Function
errH:
objWord.ActiveDocument.Close
objWord.Quit
Set objWord = Nothing
WordToHTML = Err.Description
End Function