'Please do not delete this section
'
'Developed by Tania Hew 07/2008
'
'
'Cancel Macro'
Private Sub CancelButton_Click()
YesLocation.Value = False
NoLocation.Value = False
Word2DokuWiki.Hide
End Sub
'Convert'
Private Sub ConvertButton_Click()
If YesLocation.Value = False And NoLocation.Value = False Then
MsgBox ("Please select whether or not to replace images by a specific image location")
Else
Dim FileName As String
FileName = GetFilename(ActiveDocument.Name)
Application.ScreenUpdating = False
HideRevisions
ReplaceQuotes
DokuWikiEscapeChars
' // 2011-06-20 by Taggic
DokuWikiConvertFootnotes
DokuWikiConvertHyperlinks
DokuWikiConvertH1
DokuWikiConvertH2
DokuWikiConvertH3
DokuWikiConvertH4
DokuWikiConvertH5
DokuWikiConvertItalic
DokuWikiConvertBold
DokuWikiConvertUnderline
DokuWikiConvertStrikeThrough
DokuWikiConvertSuperscript
DokuWikiConvertSubscript
DokuWikiConvertLists
DokuWikiConvertTable
UndoDokuWikiEscapeChars
DokuWikiSaveAsHTMLAndConvertImages
MoveJPGFilesToNewFolder
MovePNGFilesToNewFolder
MoveGIFFilesToNewFolder
removeImages
ActiveDocument.Content.Copy 'Copy to clipboard
Application.ScreenUpdating = True
AutoCopyToFile
'ManualCopyToFile
'CLEAN UP
'DeleteHTMFile 'Remove HTM File'
'DeleteHTMFolder 'Remove HTM Folder and contents'
'Workaround to have original Word document open at end of conversion
' ActiveDocument.Close
' Application.Documents.Open (FileName)
'Close Word to DokuWiki Converter dialog
Word2DokuWiki.Hide
MsgBox ("Word to DokuWiki Conversion complete!")
End If
End Sub
Private Sub NoLocation_Click()
ImageLocation.Locked = True
ImageLocation.BackColor = &H8000000F
NoLabel.Visible = True
YesLabel.Visible = False
End Sub
Private Sub YesLocation_Click()
ImageLocation.Locked = False
ImageLocation.BackColor = &H80000005
YesLabel.Visible = True
NoLabel.Visible = False
End Sub
Private Sub HideRevisions()
ActiveDocument.ShowRevisions = False
End Sub
Private Sub DokuWikiConvertH1()
ReplaceHeading wdStyleHeading1, "======"
End Sub
Private Sub DokuWikiConvertH2()
ReplaceHeading wdStyleHeading2, "====="
End Sub
Private Sub DokuWikiConvertH3()
ReplaceHeading wdStyleHeading3, "===="
End Sub
Private Sub DokuWikiConvertH4()
ReplaceHeading wdStyleHeading4, "==="
End Sub
Private Sub DokuWikiConvertH5()
ReplaceHeading wdStyleHeading5, "=="
End Sub
Private Sub DokuWikiConvertH6()
ReplaceHeading wdStyleHeading5, "="
End Sub
Private Sub DokuWikiConvertBold()
ActiveDocument.Select
With Selection.Find
.ClearFormatting
.Font.Bold = True
.Text = ""
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Forward = True
.Wrap = wdFindContinue
Do While .Execute
With Selection
If Len(.Text) > 1 And InStr(1, .Text, vbCr) Then
' Just process the chunk before any newline characters
' We'll pick-up the rest with the next search
.Collapse
.MoveEndUntil vbCr
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr Then
If Not Left(.Text, 2) = "**" Then
.InsertBefore "**"
End If
If Not Right(.Text, 2) = "**" Then
.InsertAfter "**"
End If
End If
.Style = ActiveDocument.Styles("Normal")
.Font.Bold = False
End With
Loop
End With
End Sub
Private Sub DokuWikiConvertItalic()
ActiveDocument.Select
With Selection.Find
.ClearFormatting
.Font.Italic = True
.Text = ""
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Forward = True
.Wrap = wdFindContinue
Do While .Execute
With Selection
If Len(.Text) > 1 And InStr(1, .Text, vbCr) Then
' Just process the chunk before any newline characters
' We'll pick-up the rest with the next search
.Collapse
.MoveEndUntil vbCr
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr Then
If Not Left(.Text, 2) = "//" Then
.InsertBefore "//"
End If
If Not Right(.Text, 2) = "//" Then
.InsertAfter "//"
End If
End If
.Style = ActiveDocument.Styles("Normal")
.Font.Italic = False
End With
Loop
End With
End Sub
Private Sub DokuWikiConvertUnderline()
ActiveDocument.Select
With Selection.Find
.ClearFormatting
.Font.Underline = True
.Text = ""
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Forward = True
.Wrap = wdFindContinue
Do While .Execute
With Selection
If Len(.Text) > 1 And InStr(1, .Text, vbCr) Then
' Just process the chunk before any newline characters
' We'll pick-up the rest with the next search
.Collapse
.MoveEndUntil vbCr
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr Then
If Not Left(.Text, 2) = "__" Then
.InsertBefore "__"
End If
If Not Right(.Text, 2) = "__" Then
.InsertAfter "__"
End If
End If
.Style = ActiveDocument.Styles("Normal")
.Font.Underline = False
End With
Loop
End With
End Sub
Private Sub DokuWikiConvertStrikeThrough()
ActiveDocument.Select
With Selection.Find
.ClearFormatting
.Font.StrikeThrough = True
.Text = ""
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Forward = True
.Wrap = wdFindContinue
Do While .Execute
With Selection
If Len(.Text) > 1 And InStr(1, .Text, vbCr) Then
' Just process the chunk before any newline characters
' We'll pick-up the rest with the next search
.Collapse
.MoveEndUntil vbCr
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr Then
If Not Left(.Text, 2) = "" Then
.InsertBefore ""
End If
If Not Right(.Text, 2) = "" Then
.InsertAfter ""
End If
End If
.Style = ActiveDocument.Styles("Normal")
.Font.StrikeThrough = False
End With
Loop
End With
End Sub
Private Sub DokuWikiConvertSuperscript()
ActiveDocument.Select
With Selection.Find
.ClearFormatting
.Font.Superscript = True
.Text = ""
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Forward = True
.Wrap = wdFindContinue
Do While .Execute
With Selection
.Text = Trim(.Text)
If Len(.Text) > 1 And InStr(1, .Text, vbCr) Then
' Just process the chunk before any newline characters
' We'll pick-up the rest with the next search
.Collapse
.MoveEndUntil vbCr
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr Then
If Not Left(.Text, 2) = "" Then
.InsertBefore ""
End If
If Not Right(.Text, 2) = "" Then
.InsertAfter ""
End If
End If
.Style = ActiveDocument.Styles("Normal")
.Font.Superscript = False
End With
Loop
End With
End Sub
Private Sub DokuWikiConvertSubscript()
ActiveDocument.Select
With Selection.Find
.ClearFormatting
.Font.Subscript = True
.Text = ""
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Forward = True
.Wrap = wdFindContinue
Do While .Execute
With Selection
.Text = Trim(.Text)
If Len(.Text) > 1 And InStr(1, .Text, vbCr) Then
' Just process the chunk before any newline characters
' We'll pick-up the rest with the next search
.Collapse
.MoveEndUntil vbCr
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr Then
If Not Left(.Text, 2) = "" Then
.InsertBefore ""
End If
If Not Right(.Text, 2) = "" Then
.InsertAfter ""
End If
End If
.Style = ActiveDocument.Styles("Normal")
.Font.Subscript = False
End With
Loop
End With
End Sub
Private Sub DokuWikiConvertLists()
Dim para As Paragraph
For Each para In ActiveDocument.ListParagraphs
With para.Range
.InsertBefore " "
If .ListFormat.ListType = wdListBullet Then
.InsertBefore "*"
Else
.InsertBefore "-"
End If
For i = 1 To .ListFormat.ListLevelNumber
.InsertBefore " "
Next i
.ListFormat.RemoveNumbers
End With
Next para
End Sub
' // 2011-06-20 add by Taggic
Private Sub DokuWikiConvertFootnotes()
Dim footnoteCount As Integer
footnoteCount = ActiveDocument.Footnotes.Count
For i = 1 To footnoteCount
With ActiveDocument.Footnotes(1)
Dim addr As String
addr = .Range.Text
.Reference.InsertAfter "((" & addr & "))"
.Delete
End With
Next i
End Sub
Private Sub DokuWikiConvertHyperlinks()
Dim hyperCount As Integer
hyperCount = ActiveDocument.Hyperlinks.Count
For i = 1 To hyperCount
With ActiveDocument.Hyperlinks(1)
Dim addr As String
addr = .Address
.Delete
.Range.InsertBefore "[[" & addr & "|"
.Range.InsertAfter "]]"
End With
Next i
End Sub
' Replace all smart quotes with their dumb equivalents
Private Sub ReplaceQuotes()
Dim quotes As Boolean
quotes = Options.AutoFormatAsYouTypeReplaceQuotes
Options.AutoFormatAsYouTypeReplaceQuotes = False
ReplaceString ChrW(8220), """"
ReplaceString ChrW(8221), """"
ReplaceString "ë", "'"
ReplaceString "í", "'"
Options.AutoFormatAsYouTypeReplaceQuotes = quotes
End Sub
Private Sub DokuWikiEscapeChars()
EscapeCharacter "*"
EscapeCharacter "#"
EscapeCharacter "_"
EscapeCharacter "-"
EscapeCharacter "+"
EscapeCharacter "{"
EscapeCharacter "}"
EscapeCharacter "["
EscapeCharacter "]"
EscapeCharacter "~"
EscapeCharacter "^^"
EscapeCharacter "|"
EscapeCharacter "'"
End Sub
Private Function ReplaceHeading(styleHeading As String, headerPrefix As String)
Dim normalStyle As Style
Set normalStyle = ActiveDocument.Styles(wdStyleNormal)
ActiveDocument.Select
With Selection.Find
.ClearFormatting
.Style = ActiveDocument.Styles(styleHeading)
.Text = ""
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Forward = True
.Wrap = wdFindContinue
Do While .Execute
With Selection
If InStr(1, .Text, vbCr) Then
' Just process the chunk before any newline characters
' We'll pick-up the rest with the next search
.Collapse
.MoveEndUntil vbCr
End If
' Don't bother to markup newline characters (prevents a loop, as well)
If Not .Text = vbCr Then
.InsertBefore headerPrefix
.InsertBefore vbCr
.InsertAfter headerPrefix
End If
.Style = normalStyle
End With
Loop
End With
End Function
Private Sub DokuWikiConvertTable()
Dim TotTables As Long
TableCellData
Do While ActiveDocument.Tables.Count() > 0
ActiveDocument.Tables(1).Range.Select
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " $s$|$s$ "
.Replacement.Text = "I"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = " $s$^^$s$ "
.Replacement.Text = "/\"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Application.DefaultTableSeparator = "|"
Selection.Rows.ConvertToText Separator:=wdSeparateByDefaultListSeparator, NestedTables:=True
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p"
.Replacement.Text = "|^p|"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.InsertBefore ("|")
Selection.InsertParagraphAfter
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^p|^p"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "$s$blank$s$"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "||"
.Replacement.Text = "| 1 |"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "||"
.Replacement.Text = "| 2 |"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "| |"
.Replacement.Text = "| 3 |"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With Selection.Find
.Text = "| |"
.Replacement.Text = "| 4 |"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Paragraphs(1).Range.Select
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "|"
.Replacement.Text = "^^"
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Loop
End Sub
Private Sub UndoDokuWikiEscapeChars()
UndoEscapeCharacter "*"
UndoEscapeCharacter "#"
UndoEscapeCharacter "_"
UndoEscapeCharacter "-"
UndoEscapeCharacter "+"
UndoEscapeCharacter "{"
UndoEscapeCharacter "}"
UndoEscapeCharacter "["
UndoEscapeCharacter "]"
UndoEscapeCharacter "~"
UndoEscapeCharacter "^^"
UndoEscapeCharacter "|"
UndoEscapeCharacter "'"
End Sub
Private Function EscapeCharacter(char As String)
ReplaceString char, " $s$" & char & "$s$ "
End Function
Private Function UndoEscapeCharacter(char As String)
ReplaceString " $s$" & char & "$s$ ", char
End Function
Private Function ReplaceString(findStr As String, replacementStr As String)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = findStr
.Replacement.Text = replacementStr
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Function
'begin my functions'
'function to get file name path of document - full path plus file name minus file extension
'Example if file is C:\Documents & Settings\taniah\My Documents\docname.doc, this would
'return C:\Documents & Settings\taniah\My Documents\docname'
Private Function GetFilename(ByVal strPath As String) As String
GetFilename = ActiveDocument.Path & "\" & ActiveDocument.Name
'Strip the .doc from the end
GetFilename = Left(GetFilename, Len(GetFilename) - 4)
End Function
'function to get file name only of text document minus extension
'Example if file is C:\Documents & Settings\taniah\My Documents\docname.doc, this would
'return docname'
Private Function GetFilenameOnly(ByVal strPath As String) As String
Dim lngPos As Long
Dim fName As String
If (Left$(strPath, 4) <> "*.txt") And (Len(strPath) > 0) Then
On Error GoTo LocalHandler
'Get all characters up to .txt string
lngPos = InStr(strPath, ".txt")
GetFilenameOnly = Left$(strPath, lngPos - 1)
Else
LocalHandler:
'Return error
MsgBox ("There was an error retrieving file name. Please ensure that current file is a text document")
'Application.Quit
End If
End Function
Private Sub DokuWikiSaveAsHTMLAndConvertImages()
Dim s As Shape
Dim FileLocation As String
For Each s In ActiveDocument.Shapes
s.ConvertToInlineShape
Next
FileLocation = ActiveDocument.Path + "\" + ActiveDocument.Name
FileName = GetFilename(ActiveDocument.Name)
FolderName = FileName + "-Dateien"
ActiveDocument.SaveAs FileName:=FileName + ".htm", _
FileFormat:=wdFormatFilteredHTML, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False
'Rename all the files with a Unique name
'strDir = Dir(FileName & "-Dateien\*.jpg")
'Ask for image location on wiki'
Dim iShape As InlineShape
If YesLocation.Value = True Then
sLocation = ImageLocation.Text
'Put image location link in DokuWiki format for all images produced in text file'
Set FS = CreateObject("Scripting.FileSystemObject")
If FS.FolderExists(FolderName) = False Then
FS.CreateFolder (FolderName)
End If
If FS.FolderExists(FolderName) Then
Set f = FS.GetFolder(FolderName)
Set fc = f.Files
i = 1
For Each f In fc
If i <= ActiveDocument.InlineShapes.Count Then
Set iShape = ActiveDocument.InlineShapes.Item(i)
iShape.Range.InsertBefore "{{" + sLocation + ":" + f.Name & "|}}"
i = i + 1
End If
Next
End If
ElseIf NoLocation.Value = True Then
'Go through every image that has been produced and substitute the link in the DokuWiki page
Set FS = CreateObject("Scripting.FileSystemObject")
If FS.FolderExists(FolderName) Then
Set f = FS.GetFolder(FolderName)
Set fc = f.Files
i = 1
For Each f In fc
If i <= ActiveDocument.InlineShapes.Count Then
Set iShape = ActiveDocument.InlineShapes.Item(i)
iShape.Range.InsertBefore "{{: " + f.Name & " :}}"
i = i + 1
End If
Next
End If
Else
'If Cancel was chosen, do nothing.
'Shell "explorer.exe " + FileName + "-Dateien", vbNormalFocus
End If
'MsgBox ("HTML creation done")
End Sub
'function to move jpg files from one folder to a newly created folder
Private Sub MoveJPGFilesToNewFolder()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String
FileName = GetFilename(ActiveDocument.Name)
FolderName = FileName + "-Dateien"
FromPath = FolderName
ToPath = FileName + " IMAGES"
FileExt = "*.jpg*"
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
JPGFNames = Dir(FromPath & FileExt)
If (Len(JPGFNames) = 0) Then
'MsgBox "No files in " & FromPath
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(ToPath) = False Then
FSO.CreateFolder (ToPath)
End If
FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
MsgBox "You can find the image files associated with the created wiki page here: " & ToPath
End Sub
'function to move png files from one folder to a newly created folder
Private Sub MovePNGFilesToNewFolder()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String
FileName = GetFilename(ActiveDocument.Name)
FolderName = FileName + "-Dateien"
FromPath = FolderName
ToPath = FileName + " IMAGES"
FileExt = "*.png*"
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
PNGFNames = Dir(FromPath & FileExt)
If (Len(PNGFNames) = 0) Then
'MsgBox "No files in " & FromPath
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(ToPath) = False Then
FSO.CreateFolder (ToPath)
End If
FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
MsgBox "You can find the image files associated with the created wiki page here: " & ToPath
End Sub
'function to move gif files from one folder to a newly created folder
Private Sub MoveGIFFilesToNewFolder()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String
FileName = GetFilename(ActiveDocument.Name)
FolderName = FileName + "-Dateien"
FromPath = FolderName
ToPath = FileName + " IMAGES"
FileExt = "*.gif*"
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
GIFFNames = Dir(FromPath & FileExt)
If (Len(GIFFNames) = 0) Then
'MsgBox "No files in " & FromPath
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
If FSO.FolderExists(ToPath) = False Then
FSO.CreateFolder (ToPath)
End If
FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
MsgBox "You can find the image files associated with the created wiki page here: " & ToPath
End Sub
'Function to delete the HTM file created
Private Function DeleteHTMFile()
Dim HTMFile As String
'HTM File should have same name as current document minus extension
HTMFile = GetFilenameOnly(ActiveDocument.Name) + ".htm"
'Look for specified file
For Each HTMLDoc In Application.Documents
If HTMLDoc.Name = HTMFile Then
wdDoc.Close
End If
Next HTMLDoc
'Delete File
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.deletefile (ActiveDocument.Path + "\" + HTMFile), True
End Function
'function to Delete HTML folder that is automatically created when html file is created
Private Sub DeleteHTMFolder()
Dim FSO As Object
Dim FolderName As String
Dim FileName As String
Set FSO = CreateObject("scripting.filesystemobject")
FileName = GetFilename(ActiveDocument.Name)
FolderName = FileName + "-Dateien"
If Right(FolderName, 1) = "\" Then
FolderName = Left(FolderName, Len(FolderName) - 1)
End If
If FSO.FolderExists(FolderName) = False Then
'MsgBox FolderName & " doesn't exist"
'there were no images found in source document
MsgBox "No images were found in source document."
Exit Sub
End If
On Error GoTo 0
'Delete files
FSO.deletefile FolderName & "\*.*", True
'Delete subfolders
FSO.deletefolder FolderName & "\*.*", True
Dir "C:\" 'This line added so that folder can be deleted without error'
'Delete folder
FSO.deletefolder FolderName, True
On Error GoTo 0
End Sub
'Function to remove images from a document'
Private Sub removeImages()
' enregistrée le 23/10/2006 par OLIVIER
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^g"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
'Create Dokuwiki version of page using user-specified file name to store contents'
'Function not used
Private Sub ManualCopyToFile()
Dim sTemp As String
'retrieve clipboard text content
sTemp = ActiveDocument.Content
'Open File Save As Dialog'
With Application.Dialogs(wdDialogFileSaveAs)
.Name = "*.txt"
.Show
If Err Then
'This code runs if the dialog was cancelled
MsgBox "Dialog Cancelled"
Exit Sub
End If
End With
End Sub
'automatically create text file with DokuWiki syntax of document content
Private Sub AutoCopyToFile()
Dim sTemp As String
Dim fullDocName As String
Dim docName As String
'retrieve clipboard text content
sTemp = ActiveDocument.Content
'get full document name
fullDocName = ActiveDocument.Name
'get filename excluding file extension
docName = GetFilename(fullDocName) + ".txt"
'THIS SECTION CAN REPLACE SECTION BELOW IF WANT TO BE GIVEN OPTION
'TO NOT OVERWRITE FILES
'Dim strMsg As String
'strMsg = "A file called " & docName & " already exists. Do you want to replace the existing " & strSaveAsName & "?"
' Check if the file already exists
'If Dir(docName & "*") = "" Then
'If file does not exist, save without prompting.
'save clipboard content to a text file having same name as Word document
'ActiveDocument.SaveAs FileName:=docName, FileFormat:=wdFormatText, FileFormat:=wdFormatText, _
'LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
':="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
'SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
'False
'Else
' If file does exist, prompt with warning message.
' Check value of button clicked in message box.
'Select Case MsgBox(strMsg, vbYesNoCancel + vbExclamation)
'Case vbYes
' If Yes was chosen, save and overwrite existing file.
'On Error GoTo LocalHandler
'save clipboard content to a text file having same name as Word document
'ActiveDocument.SaveAs FileName:=docName, FileFormat:=wdFormatText, FileFormat:=wdFormatText, _
'LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
':="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
'SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
'False
'Case vbNo
' If No was chosen, prompt for file name
' using the File SaveAs dialog box.
'With Dialogs(wdDialogFileSaveAs)
'.Name = "*.txt"
'.Show
'End With
'Case Else
' If Cancel was chosen, do nothing.
'End Select
'End If
'Need to add code below to rename images folder so name is based on the user-provided text file name
'END THIS SECTION
On Error GoTo LocalHandler
MsgBox ("Any existing text files will be overwritten.")
'save clipboard content to a text file having same name as Word document
ActiveDocument.SaveAs FileName:=docName, FileFormat:=wdFormatText, _
LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False
LocalHandler:
'MsgBox ("There was an error saving the text file. ")
'Application.Quit
End Sub
Private Sub TableCellData()
Dim i As Long, oColMax As Long, oRowMax As Long, oCellCnt As Long
Dim strColStart As String, strRowStart As String
Dim strColEnd As String, strRowEnd As String
Dim strMsg1 As String, strMsg2 As String, strMsg3 As String, strMsg4 As String, strMsg5
If Application.Documents.Count Then
With Selection
If .Information(wdWithInTable) Then
i = ActiveDocument.Range(0, .Tables(1).Range.End).Tables.Count
strMsg1 = TableConfigID(i)
oColMax = .Tables(1).Columns.Count
oRowMax = .Tables(1).Rows.Count
oCellCnt = .Tables(1).Range.Cells.Count
strMsg2 = "/Max. columns: " & oColMax & "/" _
& "Max. rows: " & oRowMax
strMsg3 = "Total cells: " & oCellCnt & ". "
strColStart = alphaChar(.Information(wdStartOfRangeColumnNumber))
strRowStart = .Information(wdStartOfRangeRowNumber)
strColEnd = alphaChar(.Information(wdEndOfRangeColumnNumber))
strRowEnd = .Information(wdEndOfRangeRowNumber)
Select Case .Cells.Count
Case Is < 2
strMsg4 = "At cell: " & strColStart & strRowStart & ". "
If Not .Tables(1).Uniform Then
strMsg5 = "This table contains split or merged cells."
End If
Case Else
If .Tables(1).Uniform Then
strMsg4 = "Selection spans: " _
& strColStart & strRowStart & ":" & strColEnd & strRowEnd & "."
Else
'Stet as appropriate to suppress or report spans in tables with split or merged cells
strMsg4 = "Table contains split/merged cells." _
& " The span can not be positively determined."
'strMsg4 = "Selection spans: " & strColStart & strRowStart & ":" _
& strColEnd & strRowEnd & ". Span susceptible to" _
& " error due to split/merged cells."
strMsg5 = ""
End If
End Select
'Can use message box, status bar, or both
' MsgBox strMsg1 & strMsg2 & vbCr & vbCr & strMsg3 _
' & vbCr & vbCr & strMsg4 & vbCr & vbCr & strMsg5, _
' vbInformation + vbOKOnly, "Table Data"
Application.StatusBar = strMsg1 & strMsg2 & "/" & strMsg3 & strMsg4 & strMsg5
End If
End With
End If
lbl_Exit:
Exit Sub
End Sub
Function TableConfigID(ByVal i As Long) As String
Dim TopTbl As Table, Nest1Tbl As Table, Nest2Tbl As Table
Dim x As Long, y As Long
Dim ttCell As Word.Cell, ntCell As Word.Cell
Dim tmpMsg1 As String, tmpMsg2 As String, tmpMsg3 As String
Set TopTbl = ActiveDocument.Tables(i)
tmpMsg1 = "Table " & i
x = 0
For Each ttCell In TopTbl.Range.Cells
If ttCell.Tables.Count > 0 Then
For Each Nest1Tbl In ttCell.Tables
x = x + 1
If Selection.InRange(Nest1Tbl.Range) Then
tmpMsg1 = "Table " & i & "{Table " & x & "}"
End If
y = 0
For Each ntCell In Nest1Tbl.Range.Cells
If ntCell.Tables.Count > 0 Then
For Each Nest2Tbl In ntCell.Tables
y = y + 1
If Selection.InRange(Nest2Tbl.Range) Then
tmpMsg1 = "Table " & i & "{Table " & x & "{Table " & y & "}}"
End If
Next Nest2Tbl
End If
Next ntCell
Next Nest1Tbl
End If
Next ttCell
TableConfigID = tmpMsg1
lbl_Exit:
Exit Function
End Function
Function alphaChar(pAribicNum As Integer) As String
Select Case pAribicNum
Case Is < 27
alphaChar = String(1, (pAribicNum + 64))
Case Is < 53
alphaChar = "A" & String(1, (pAribicNum - (26) + 64))
Case Is >= 53
alphaChar = "B" & String(1, (pAribicNum - (52) + 64))
End Select
lbl_Exit:
Exit Function
End Function