Attachment 'Word2MoinV21.bas'

Download

   1 Attribute VB_Name = "Word2MoinV2"
   2 'Microsoft Word 2000 to MoinMoin converter.
   3 ' by John Whitlock (John-Whitlock@ieee.org), 2003
   4 ' This code is ugly, slow, and might not work the way you want it to.
   5 ' It is also public domain, so have fun.
   6 ' Feel free to contact me, but don't expect much help...
   7 '
   8 'To install:
   9 ' Start Word
  10 ' Start Visual Basic Editor (from Tools menu or Alt-F11)
  11 ' Import the module (File -> Import) into the Normal template
  12 '
  13 'To Run:
  14 ' Select Tools -> Macro -> Macros
  15 ' Select Word2Moin
  16 ' Select "Run"
  17 '
  18 'To Cancel: Hit Ctrl-Break
  19 '
  20 'What it does:
  21 ' Converts the Word field "TOC" into a Moin table with inter-document links
  22 ' Converts Word Headings into Moin Headlines
  23 '  Inserts Anchor() macro and section number, if TOC was found
  24 ' Converts Bold, Italic, Underlined, Superscript, and Subscript to Moin equivalents
  25 ' Converts Lists to Moin lists (does not handle multi-level lists well)
  26 ' Converts Tabs to Moin tables
  27 ' Converts Tables to Moin Tables (does not handle merged and empty cells well)
  28 ' Replaces page breaks with Moin line rules
  29 ' Separates paragraphs with extra line breaks
  30 ' Copies the results to the clipboard
  31 '
  32 'What doesn't work well:
  33 ' Section numbers - sometimes, the algorithm misses a section
  34 ' Multi-level lists - converted to flat lists
  35 ' Letter lists (a, b, c) - converted to numbered lists
  36 ' Empty Table Cells - Sometimes converted, sometimes not
  37 ' Merged Table Cells - No support for cell spanning
  38 ' Character conversion - dashes, left/right quote marks not converted to plain ASCII equivalents
  39 '
  40 'The character conversion issue might keep your page from validating as good HTML.
  41 ' To have Word convert for you, save the page as plain text.
  42 
  43 ' /////////////////////////////////////////////////////////////////////////////
  44 Type TOC_Entry
  45     Number As String
  46     Name As String
  47     Found As Boolean
  48 End Type
  49 
  50 ' /////////////////////////////////////////////////////////////////////////////
  51 Enum eFormatType
  52     eftBold
  53     eftItalic
  54     eftUnder
  55     eftSuper
  56     eftSub
  57 End Enum
  58 
  59 ' /////////////////////////////////////////////////////////////////////////////
  60 Type TableCellFormat
  61     FirstCell As Boolean    'Cell is first cell in row
  62     LastCell As Boolean     'Cell is last cell in row
  63     Color As String         'Cell's background color
  64     HorizAlign As String    'L, C, R
  65     VertAlign As String     'T, C, B
  66     RowSpan As Integer      '0 or 1, for now
  67     ColSpan As Integer      '0 or 1, for now
  68 End Type
  69 
  70 ' /////////////////////////////////////////////////////////////////////////////
  71 Option Base 1
  72 Option Explicit
  73 Dim TOC_Entries() As TOC_Entry
  74 Dim IsTOC As Boolean
  75 
  76 ' /////////////////////////////////////////////////////////////////////////////
  77 Sub Word2Moin()
  78     
  79     'nah let's see it work!
  80     'Application.ScreenUpdating = False
  81     
  82     'Find the table of contents, if there is one
  83     IsTOC = False
  84     ConvertTableOfContents
  85     
  86     'Convert Headings
  87     Call ConvertHeading(wdStyleHeading1, "= ", " =")
  88     Call ConvertHeading(wdStyleHeading2, "== ", " ==")
  89     Call ConvertHeading(wdStyleHeading3, "=== ", " ===")
  90     Call ConvertHeading(wdStyleHeading4, "==== ", " ====")
  91     Call ConvertHeading(wdStyleHeading5, "===== ", " =====")
  92     
  93     ConvertFormat eftBold
  94     ConvertFormat eftItalic
  95     ConvertFormat eftUnder
  96     ConvertFormat eftSuper
  97     ConvertFormat eftSub
  98     
  99     'Call ShowLists
 100     ConvertLists
 101     ConvertTabs
 102     ConvertTables
 103     ReplacePageBreaks
 104     ExpandLineBreaks
 105     SetFixedWidthFont
 106     'AddTableComments
 107     
 108 ExitWord2Wiki:
 109     'let's not Copy to clipboard
 110     'ActiveDocument.Content.Copy
 111     
 112     
 113     'Application.ScreenUpdating = True
 114 End Sub ' Word2Moin
 115 
 116 Sub SetFixedWidthFont()
 117     Selection.WholeStory
 118     Selection.Font.Name = "Courier New"
 119     Selection.Font.Size = 8
 120 End Sub
 121 
 122 '' ADDS A COMMENT LINE BETWEEN ROWS OF A TABLE TO MAKE IT EASIER TO READ / EDIT FROM SOURCE VIEW
 123 'Private Sub AddTableComments()
 124 '    Dim nextPara As Paragraph
 125 '    Dim iLoopPara As Integer
 126 '
 127 '    For iLoopPara = ActiveDocument.Paragraphs.Count To 1 Step -1
 128 '        Set nextPara = ActiveDocument.Paragraphs(iLoopPara)
 129 '        If InStr(nextPara.Range.Text, "[tableRow/]") > 0 Then
 130 '            nextPara.Range.Text = Replace(nextPara.Range.Text, "[tableRow/]", "##" & vbCr)
 131 '        End If
 132 '    Next iLoopPara
 133 'End Sub ' AddTableComments
 134 
 135 ' /////////////////////////////////////////////////////////////////////////////
 136 'yoda2
 137 Private Sub ExpandLineBreaks()
 138     Dim nextPara As Paragraph
 139     Dim iLoopPara As Integer
 140     
 141     For iLoopPara = ActiveDocument.Paragraphs.Count To 1 Step -1
 142     'For Each nextPara In ActiveDocument.Paragraphs
 143         'Debug.Print nextPara.Range.Text
 144         
 145         Set nextPara = ActiveDocument.Paragraphs(iLoopPara)
 146         
 147         If (Left(nextPara.Range.Text, 7)) = "[list/]" Then
 148             
 149             'nextPara.Range.Text = Right(nextPara.Range.Text, Len(nextPara.Range.Text) - 7)
 150             If (Left(nextPara.Range.Text, 15)) = "[list/][first/]" Then
 151                 nextPara.Range.Text = "<<BR>>" & vbCr & Right(nextPara.Range.Text, Len(nextPara.Range.Text) - 15)
 152             Else
 153                 nextPara.Range.Text = Right(nextPara.Range.Text, Len(nextPara.Range.Text) - 7)
 154             End If
 155         Else
 156             'this logic is ambiguous:
 157             'If _
 158             '   Not Len(nextPara.Range.Text) = 1 And _
 159             '   InStr(nextPara.Range.Text, "||") = 0 And _
 160             '   Not (Left(nextPara.Range.Text, 1)) = "=" And _
 161             '   Not (Left(nextPara.Range.Text, 2)) = "[[" And _
 162             '   Not (Left(nextPara.Range.Text, 4)) = "----" And _
 163             '   True Then
 164             If _
 165                Not (Len(nextPara.Range.Text) = 1) And _
 166                (InStr(nextPara.Range.Text, "||") = 0) And _
 167                (Not (Left(nextPara.Range.Text, 1)) = "=") And _
 168                (Not (Left(nextPara.Range.Text, 2)) = "[[") And _
 169                (Not (Left(nextPara.Range.Text, 63)) = "##") And _
 170                (Not (Left(nextPara.Range.Text, 4)) = "----") And _
 171                True Then
 172                 'Debug.Print para.Range.Text
 173                 Call nextPara.Range.InsertAfter(vbCr)
 174             End If
 175         End If
 176     'Next nextPara
 177     Next iLoopPara
 178 End Sub ' ExpandLineBreaks
 179 
 180 ' /////////////////////////////////////////////////////////////////////////////
 181 Private Sub ConvertTableOfContents()
 182     With ActiveDocument
 183         If .Fields.Count >= 1 Then
 184             Dim C As Integer
 185             Dim Max As Integer
 186                 
 187             'Search Fields for a Table Of Contents
 188             For C = 1 To .Fields.Count
 189                 'If we find a Table of Contents, process it
 190                 If InStr(LTrim(.Fields(C).Code), "TOC") = 1 Then
 191                     .Fields(C).Update
 192                     
 193                     Dim TOC As String
 194                     Dim Entry As String
 195                     Dim LastPos As Long
 196                     Dim Pos As Long
 197                     Dim FirstTime As Boolean
 198                     
 199                     TOC = .Fields(C).Result
 200                     
 201                     'Get each entry in the table, insert into array
 202                     LastPos = 1
 203                     Pos = InStr(TOC, vbCr)
 204                     FirstTime = True
 205                     Do While (Pos > 0)
 206                         Dim F1 As Long
 207                         Dim F2 As Long
 208                         Dim EntryNum As Long
 209                         
 210                         Entry = Trim(Mid(TOC, LastPos, Pos - LastPos))
 211                         Entry = Replace(Entry, "^l", "")
 212                         
 213                         If (Len(Entry) > 0) Then
 214                             If (FirstTime) Then
 215                                 EntryNum = 1
 216                                 ReDim TOC_Entries(1)
 217                                 FirstTime = False
 218                             Else
 219                                 EntryNum = UBound(TOC_Entries) + 1
 220                                 ReDim Preserve TOC_Entries(EntryNum)
 221                             End If
 222                                             
 223                             F1 = InStr(Entry, vbTab)
 224                         
 225                             If (F1 > 0) Then
 226                                 F2 = InStr(F1 + 1, Entry, vbTab)
 227                                 If (F2 = 0) Then
 228                                     'Handle Appendix sections'
 229                                     F1 = InStr(Entry, "-")
 230                                     F2 = InStr(F1 + 1, Entry, vbTab)
 231                                     If (F2 = 0) Then
 232                                         F1 = InStr(Entry, "  ")
 233                                         F2 = InStr(F1 + 1, Entry, vbTab)
 234                                     End If
 235                                     
 236                                     If (F1 = 0) Then
 237                                         'Give up on finding a number
 238                                         F1 = InStr(1, Entry, vbTab)
 239                                         TOC_Entries(EntryNum).Number = ""
 240                                         TOC_Entries(EntryNum).Name = Left(Entry, F1)
 241                                     Else
 242                                         TOC_Entries(EntryNum).Number = Replace(Mid(Entry, 1, F1 - 1), " ", "")
 243                                         TOC_Entries(EntryNum).Name = Mid(Entry, F1 + 1, F2 - F1 - 1)
 244                                     End If
 245                                 Else
 246                                     TOC_Entries(EntryNum).Number = Trim(Mid(Entry, 1, F1 - 2))
 247                                     TOC_Entries(EntryNum).Name = Mid(Entry, F1 + 1, F2 - F1 - 1)
 248                                 End If
 249                             End If
 250                             
 251                             'Check for null entries
 252                             If (Len(TOC_Entries(EntryNum).Number) = 0 And _
 253                                (Len(TOC_Entries(EntryNum).Name) = 0)) Then
 254                                 ReDim Preserve TOC_Entries(EntryNum - 1)
 255                             Else
 256                                 TOC_Entries(EntryNum).Found = False
 257                             End If
 258                                                     
 259                         End If
 260                         LastPos = Pos + 1
 261                         Pos = InStr(LastPos, TOC, vbCr)
 262                     Loop
 263                     
 264                     .Fields(C).Select
 265                     
 266                     'Delete Word version, insert MoinMoin version
 267                     With Selection
 268                         .Delete
 269                         .InsertAfter ("'''Table Of Contents'''" & vbCr & vbCr)
 270                         
 271                         For Pos = 1 To UBound(TOC_Entries)
 272                         'Create a table, with a slight indent for entries that are not top-level
 273                             .InsertAfter ("||")
 274                             If (Len(TOC_Entries(Pos).Number) = 1) Then
 275                                 .InsertAfter ("||<(>")
 276                             Else
 277                                 .InsertAfter (" ||")
 278                             End If
 279                             .InsertAfter ("'''" & TOC_Entries(Pos).Number & "'''||" & _
 280                                 "[#s" & TOC_Entries(Pos).Number & " " & TOC_Entries(Pos).Name & "]||" & vbCr)
 281                         Next
 282                     End With
 283                     
 284                     'Stop looking for Table Of Contents
 285                     IsTOC = True
 286                     Exit For
 287                 End If
 288             Next
 289         End If
 290     End With
 291 End Sub ' ConvertTableOfContents
 292 
 293 ' /////////////////////////////////////////////////////////////////////////////
 294 Private Sub ConvertHeading(headingStyle As Long, Optional preString As String = "", Optional postString As String = "")
 295     Dim normalStyle As Style
 296     Set normalStyle = ActiveDocument.Styles(wdStyleNormal)
 297     
 298     ActiveDocument.Select
 299     
 300     With Selection.find
 301     
 302         .ClearFormatting
 303         .Style = ActiveDocument.Styles(headingStyle)
 304         .Text = ""
 305         
 306         .format = True
 307         .MatchCase = False
 308         .MatchWholeWord = False
 309         .MatchWildcards = False
 310         .MatchSoundsLike = False
 311         .MatchAllWordForms = False
 312         
 313         .Forward = True
 314         .Wrap = wdFindContinue
 315         
 316         Do While .Execute
 317             With Selection
 318                 Dim Heading As String
 319                 
 320                 Heading = .Text
 321                 .Style = normalStyle
 322                 .Collapse
 323                 .MoveEndUntil vbCr
 324                 .Delete
 325                 
 326                 'Eliminate any manual form feeds
 327                 Heading = Replace(Heading, vbFormFeed, "")
 328                 
 329                 'Replace any newlines with spaces
 330                 Heading = Replace(Heading, vbCr, " ")
 331                 
 332                 'Removed leading / training spaces
 333                 Heading = Trim(Heading)
 334                                                        
 335                 'Search the TOC entries for this section, insert bookmark etc.
 336                 If (IsTOC) Then
 337                     Dim E As Long
 338                     For E = 1 To UBound(TOC_Entries)
 339                         If (Not TOC_Entries(E).Found) Then
 340                             If (StrComp(Heading, TOC_Entries(E).Name) = 0) Then
 341                                 .InsertBefore "[[Anchor(s" & TOC_Entries(E).Number & ")]]" & vbCr
 342                                 Heading = TOC_Entries(E).Number & " " & Heading
 343                                 TOC_Entries(E).Found = True
 344                                 Exit For
 345                             End If
 346                         End If
 347                     Next E
 348                 End If
 349                                                        
 350                 'Print the Heading
 351                 .InsertAfter preString & Heading & postString
 352             End With
 353         Loop
 354     End With
 355 End Sub ' ConvertHeading
 356 
 357 ' /////////////////////////////////////////////////////////////////////////////
 358 Private Sub ReplacePageBreaks()
 359     
 360     Selection.find.ClearFormatting
 361     Selection.find.Replacement.ClearFormatting
 362     With Selection.find
 363         .Text = "^m"
 364         .Replacement.Text = "----" & vbCr
 365         .Forward = True
 366         .Wrap = wdFindContinue
 367         .format = False
 368         .MatchCase = False
 369         .MatchWholeWord = False
 370         .MatchWildcards = False
 371         .MatchSoundsLike = False
 372         .MatchAllWordForms = False
 373     End With
 374     Selection.find.Execute Replace:=wdReplaceAll
 375     
 376     Selection.find.ClearFormatting
 377     Selection.find.Replacement.ClearFormatting
 378     With Selection.find
 379         .Text = "^b"
 380         .Replacement.Text = "----" & vbCr
 381         .Forward = True
 382         .Wrap = wdFindContinue
 383         .format = False
 384         .MatchCase = False
 385         .MatchWholeWord = False
 386         .MatchWildcards = False
 387         .MatchSoundsLike = False
 388         .MatchAllWordForms = False
 389     End With
 390     Selection.find.Execute Replace:=wdReplaceAll
 391     
 392 End Sub ' ReplacePageBreaks
 393 
 394 ' /////////////////////////////////////////////////////////////////////////////
 395 Private Sub ConvertFormat(format As eFormatType)
 396     ActiveDocument.Select
 397     With Selection.find
 398         Dim pre As String
 399         Dim post As String
 400     
 401         .ClearFormatting
 402         Select Case format
 403             Case eftBold:
 404                 .Font.Bold = True
 405                 pre = "'''"
 406                 post = "'''"
 407             Case eftItalic:
 408                 .Font.Italic = True
 409                 pre = "''"
 410                 post = "''"
 411             Case eftUnder:
 412                 .Font.Underline = wdUnderlineSingle
 413                 pre = "__"
 414                 post = "__"
 415             Case eftSuper:
 416                 .Font.Superscript = True
 417                 pre = "^"
 418                 post = "^"
 419             Case eftSub:
 420                 .Font.Subscript = True
 421                 pre = ",,"
 422                 post = ",,"
 423         End Select
 424         
 425         .Text = ""
 426         
 427         .format = True
 428         .MatchCase = False
 429         .MatchWholeWord = False
 430         .MatchWildcards = False
 431         .MatchSoundsLike = False
 432         .MatchAllWordForms = False
 433         
 434         .Forward = True
 435         .Wrap = wdFindContinue
 436         
 437         Do While .Execute
 438             With Selection
 439                 If InStr(1, .Text, vbCr) Then
 440                     ' Just process the chunk before any newline characters
 441                     ' We'll pick-up the rest with the next search
 442                     .Collapse
 443                     .MoveEndUntil vbCr
 444                 End If
 445 
 446                 ' Don't bother to markup whitespace (prevents a loop, as well)
 447                 If (.Text = vbCr Or .Text = " " Or .Text = "") Then
 448                     .MoveRight
 449                 Else
 450                     .InsertBefore pre
 451                     .InsertAfter post
 452                 End If
 453 
 454                 Select Case format
 455                     Case eftBold:       .Font.Bold = False
 456                     Case eftItalic:     .Font.Italic = False
 457                     Case eftUnder:      .Font.Underline = wdUnderlineNone
 458                     Case eftSuper:      .Font.Superscript = False
 459                     Case eftSub:        .Font.Subscript = False
 460                 End Select
 461             End With
 462         Loop
 463     End With
 464 End Sub ' ConvertFormat
 465 
 466 ' /////////////////////////////////////////////////////////////////////////////
 467 Private Function OutlineLevelToNumber(level As WdOutlineLevel) As Integer
 468     Select Case level
 469     Case wdOutlineLevel1: OutlineLevelToNumber = 2
 470     Case wdOutlineLevel2: OutlineLevelToNumber = 3
 471     Case wdOutlineLevel3: OutlineLevelToNumber = 4
 472     Case wdOutlineLevel4: OutlineLevelToNumber = 5
 473     Case wdOutlineLevel5: OutlineLevelToNumber = 6
 474     Case wdOutlineLevel6: OutlineLevelToNumber = 7
 475     Case wdOutlineLevel7: OutlineLevelToNumber = 8
 476     Case wdOutlineLevel8: OutlineLevelToNumber = 9
 477     Case wdOutlineLevel9: OutlineLevelToNumber = 10
 478     Case Else: OutlineLevelToNumber = 1
 479     End Select
 480 End Function ' OutlineLevelToNumber
 481 
 482 
 483 
 484 ' /////////////////////////////////////////////////////////////////////////////
 485 ' SOME TEST CODE THAT OUTPUTS DATA ON NUMBERED/BULLETED LISTS IN WORD TO A FILE
 486 ' by Softintheheadware 6/27/07 Wed
 487 
 488 Sub ShowLists()
 489     Dim iLoopLists As Integer
 490     Dim sOut As String
 491     Dim nextList As ListParagraphs
 492     Dim nextPara As Paragraph
 493     Dim iCount As Integer
 494     Dim iLoopPara As Integer
 495     
 496     Dim sFilePath As String
 497     sFilePath = InputBox("Save report to?", "Save report to? (blank to abort)", "c:\word_lists.txt")  ' prompt, title, default
 498     
 499     If sFilePath = "" Then
 500         Exit Sub
 501     End If
 502     
 503     sOut = ""
 504     For iLoopLists = 1 To ActiveDocument.Lists.Count
 505         'sOut = sOut & "List " & format$(iLoopLists) & ": " & nextList.Count & " paragraphs" & vbCr
 506         sOut = sOut & "-------------------------------------------------------------------------------" & vbCrLf
 507         sOut = sOut & "List #" & CStr(iLoopLists) & vbCrLf
 508         
 509         Set nextList = ActiveDocument.Lists(iLoopLists).Range.ListParagraphs
 510         
 511         'sOut = sOut & "  Paragraphs: " & nextList.Count & vbCrLf
 512         
 513         'iCount = 0
 514         
 515         For iLoopPara = 1 To nextList.Count
 516         'ENUMERATES THROUGH LIST BACKWARD: For Each nextPara In nextList
 517             Set nextPara = nextList(iLoopPara)
 518             'iCount = iCount + 1
 519             sOut = sOut & "  " & Right("000" & CStr(iLoopPara), 3) & ": " & nextPara.Range.ListFormat.ListString & " " & nextPara.Range.Text '& vbCrLf
 520             
 521             If Trim(nextPara.Range.ListFormat.ListTemplate.Name) <> "" Then
 522                 sOut = sOut & "    ListTemplate.Name = " & nextPara.Range.ListFormat.ListTemplate.Name & vbCrLf
 523             End If
 524             
 525             'sOut = sOut & "    OutlineNumbered: "
 526             'If (nextPara.Range.ListFormat.ListTemplate.OutlineNumbered = True) Then
 527             '    sOut = sOut & "True" & vbCrLf
 528             'Else
 529             '    sOut = sOut & "False" & vbCrLf
 530             'End If
 531             
 532             sOut = sOut & "    ListLevelNumber: " & CStr(nextPara.Range.ListFormat.ListLevelNumber) & vbCrLf
 533             
 534             sOut = sOut & "    ListLevel NumberStyle: " & ListLevelNumberStyleToText(nextPara.Range.ListFormat.ListTemplate.ListLevels(nextPara.Range.ListFormat.ListLevelNumber).NumberStyle) & vbCrLf
 535             
 536             'sOut = sOut & "    ListLevel NumberPosition: " & CStr(nextPara.Range.ListFormat.ListTemplate.ListLevels(nextPara.Range.ListFormat.ListLevelNumber).NumberPosition) & vbCrLf
 537         'Next nextPara
 538         Next iLoopPara
 539     Next iLoopLists
 540     
 541     'MsgBox sOut
 542     Call WriteTextToFile(sFilePath, sOut, False)
 543     
 544     MsgBox "ShowLists FINISHED."
 545     
 546 End Sub ' ShowLists
 547 
 548 ' /////////////////////////////////////////////////////////////////////////////
 549 ' WRITE TEXT TO A FILE
 550 ' by Softintheheadware 2002-2006
 551 '
 552 ' NOTES:
 553 ' write sString to a file sFilePath
 554 ' if bAppend=TRUE, appends to file if it already exists, else overwrites file
 555 ' if bEnabled=FALSE, does nothing. If omitted or TRUE, writes to file
 556 ' =============================================================================
 557 ' HISTORY:
 558 '
 559 ' DATE        WHO        MODIFICATION
 560 ' 10/??/2002  Apple-O    now supports unicode
 561 ' 11/11/2006  Apple-O    merged write/append into one function
 562 
 563 'Public Shared Sub WriteTextToFile(ByVal strTextToWrite As String, ByVal strFileName As String, ByVal bAppend As Boolean)
 564 Sub WriteTextToFile(ByVal sFilePath As String, ByVal sString As String, ByVal bAppend As Boolean)
 565     Dim objFSO As FileSystemObject
 566     Dim objFile As TextStream
 567     Set objFSO = CreateObject("Scripting.FileSystemObject")
 568     If objFSO.FileExists(sFilePath) Then
 569         If bAppend Then
 570             'APPEND
 571             Set objFile = objFSO.OpenTextFile(sFilePath, ForAppending, True, TristateUseDefault)
 572         Else
 573             'OVERWRITE
 574             Set objFile = objFSO.OpenTextFile(sFilePath, ForWriting, True, TristateUseDefault)
 575         End If
 576     Else
 577         'CREATE NEW
 578         Set objFile = objFSO.OpenTextFile(sFilePath, ForWriting, True, TristateUseDefault)
 579     End If
 580     Call objFile.Write(sString & vbCrLf)
 581     
 582     objFile.Close
 583 End Sub ' WriteTextToFile
 584 
 585 ' /////////////////////////////////////////////////////////////////////////////
 586 ' receives a WdListNumberStyle and returns a text description
 587 ' by Softintheheadware 6/27/07 Wed
 588 
 589 Function ListLevelNumberStyleToText(WdListNumberStyle As Integer) As String
 590     Dim sValue As String
 591     Select Case WdListNumberStyle
 592         Case wdListNumberStyleArabic '= 0
 593             sValue = "wdListNumberStyleArabic"
 594         Case wdListNumberStyleUppercaseRoman '= 1
 595             sValue = "wdListNumberStyleUppercaseRoman"
 596         Case wdListNumberStyleLowercaseRoman '= 2
 597             sValue = "wdListNumberStyleLowercaseRoman"
 598         Case wdListNumberStyleUppercaseLetter '= 3
 599             sValue = "wdListNumberStyleUppercaseLetter"
 600         Case wdListNumberStyleLowercaseLetter '= 4
 601             sValue = "wdListNumberStyleLowercaseLetter"
 602         Case wdListNumberStyleOrdinal '= 5
 603             sValue = "wdListNumberStyleOrdinal"
 604         Case wdListNumberStyleCardinalText '= 6
 605             sValue = "wdListNumberStyleCardinalText"
 606         Case wdListNumberStyleOrdinalText '= 7
 607             sValue = "wdListNumberStyleOrdinalText"
 608         Case wdListNumberStyleArabicLZ '= 22
 609             sValue = "wdListNumberStyleArabicLZ"
 610         Case wdListNumberStyleBullet '= 23
 611             sValue = "wdListNumberStyleBullet"
 612         Case wdListNumberStyleLegal '= 253
 613             sValue = "wdListNumberStyleLegal"
 614         Case wdListNumberStyleLegalLZ '= 254
 615             sValue = "wdListNumberStyleLegalLZ"
 616         Case wdListNumberStyleNone '= 255
 617             sValue = "wdListNumberStyleNone"
 618         Case Else
 619             sValue = "(unknown)"
 620     End Select
 621     ListLevelNumberStyleToText = sValue
 622 End Function ' ListLevelNumberStyleToText
 623 
 624 ' /////////////////////////////////////////////////////////////////////////////
 625 ' SOME USEFUL ENUMERATIONS FOR WORD LISTS
 626 'Enum WdListType
 627 '   wdListNoNumbering = 0
 628 '   wdListListNumOnly = 1
 629 '   wdListBullet = 2
 630 '   wdListSimpleNumbering = 3
 631 '   wdListOutlineNumbering = 4
 632 '   wdListMixedNumbering = 5
 633 'End Enum
 634 'Enum WdListNumberStyle
 635 '    wdListNumberStyleArabic = 0
 636 '    wdListNumberStyleUppercaseRoman = 1
 637 '    wdListNumberStyleLowercaseRoman = 2
 638 '    wdListNumberStyleUppercaseLetter = 3
 639 '    wdListNumberStyleLowercaseLetter = 4
 640 '    wdListNumberStyleOrdinal = 5
 641 '    wdListNumberStyleCardinalText = 6
 642 '    wdListNumberStyleOrdinalText = 7
 643 '    wdListNumberStyleArabicLZ = 22
 644 '    wdListNumberStyleBullet = 23
 645 '    wdListNumberStyleLegal = 253
 646 '    wdListNumberStyleLegalLZ = 254
 647 '    wdListNumberStyleNone = 255
 648 'End Enum
 649 
 650 ' /////////////////////////////////////////////////////////////////////////////
 651 ' Now handles nested lists! modifications by Softintheheadware, 6/27/07 Wed
 652 
 653 Private Sub ConvertLists()
 654     Dim nextPara As Paragraph
 655     Dim WdListNumberStyle As Integer
 656     Dim sNextBullet As String
 657     Dim sIndentSpace As String
 658     Dim sFirst As String
 659     Dim iRightTrim As Integer
 660     
 661     Call TagFirstListElements
 662     
 663     For Each nextPara In ActiveDocument.ListParagraphs
 664         WdListNumberStyle = nextPara.Range.ListFormat.ListTemplate.ListLevels(nextPara.Range.ListFormat.ListLevelNumber).NumberStyle
 665         Select Case WdListNumberStyle
 666             Case wdListNumberStyleArabic '= 0
 667                 sNextBullet = "1. "
 668             Case wdListNumberStyleUppercaseRoman '= 1
 669                 sNextBullet = "I. "
 670             Case wdListNumberStyleLowercaseRoman '= 2
 671                 sNextBullet = "i. "
 672             Case wdListNumberStyleUppercaseLetter '= 3
 673                 sNextBullet = "A. "
 674             Case wdListNumberStyleLowercaseLetter '= 4
 675                 sNextBullet = "a. "
 676             Case wdListNumberStyleOrdinal '= 5
 677                 sNextBullet = "1. "
 678             Case wdListNumberStyleCardinalText '= 6
 679                 sNextBullet = "1. "
 680             Case wdListNumberStyleOrdinalText '= 7
 681                 sNextBullet = "1. "
 682             Case wdListNumberStyleArabicLZ '= 22
 683                 sNextBullet = "1. "
 684             Case wdListNumberStyleBullet '= 23
 685                 sNextBullet = "* "
 686             Case wdListNumberStyleLegal '= 253
 687                 sNextBullet = "1. "
 688             Case wdListNumberStyleLegalLZ '= 254
 689                 sNextBullet = "1. "
 690             Case wdListNumberStyleNone '= 255
 691                 sNextBullet = "(none)"
 692             Case Else
 693                 sNextBullet = ""
 694         End Select
 695 
 696         If sNextBullet <> "" Then
 697 'If (InStr(nextPara.Range.Text, "first numeric") > 0) Then
 698 '    sFirst = sFirst
 699 'End If
 700             
 701             sIndentSpace = String(nextPara.Range.ListFormat.ListLevelNumber, " ") & String(nextPara.Range.ListFormat.ListLevelNumber, " ")
 702             
 703             Call nextPara.Range.ListFormat.RemoveNumbers
 704             
 705             If Left(nextPara.Range.Text, 8) = "[first/]" Then
 706                 sFirst = "[first/]"
 707                 iRightTrim = 8
 708                 'nextPara.Range.Text = Right(nextPara.Range.Text, Len(nextPara.Range.Text) - 8)
 709             Else
 710                 sFirst = ""
 711                 iRightTrim = 0
 712             End If
 713             
 714             If sNextBullet = "(none)" Then
 715                 'nextPara.Range.Text = sIndentSpace & nextPara.Range.Text
 716                 'Call nextPara.Range.InsertBefore("[list/]" & sFirst & sIndentSpace)
 717                 'nextPara.Range.Text = "[list/]" & sFirst & sIndentSpace & nextPara.Range.Text
 718                 nextPara.Range.Text = "[list/]" & sFirst & sIndentSpace & Right(nextPara.Range.Text, Len(nextPara.Range.Text) - iRightTrim)
 719             Else
 720                 'nextPara.Range.Text = sIndentSpace & nextPara.Range.Text & sNextBullet
 721                 'Call nextPara.Range.InsertBefore("[list/]" & sFirst & sIndentSpace & sNextBullet)
 722                 'nextPara.Range.Text = "[list/]" & sFirst & sIndentSpace & sNextBullet & nextPara.Range.Text
 723                 nextPara.Range.Text = "[list/]" & sFirst & sIndentSpace & sNextBullet & Right(nextPara.Range.Text, Len(nextPara.Range.Text) - iRightTrim)
 724             End If
 725             
 726         End If
 727         
 728         'OLD:
 729         'If nextPara.Range.ListFormat.ListType = wdListBullet Then
 730             ' UNORDERED LIST
 731                 'call nextPara.Range.InsertBefore(" * ")
 732                 'Call nextPara.Range.InsertBefore(String(OutlineLevelToNumber(nextPara.OutlineLevel), " ") & "* ")
 733                 'Call nextPara.Range.InsertBefore(String(nextPara.Range.ListFormat.ListLevelNumber, " ") & "* ")
 734         'Else
 735             ' ORDERED LIST
 736             'call nextPara.Range.InsertBefore(" 1. ")
 737             'Call nextPara.Range.InsertBefore(String(OutlineLevelToNumber(nextPara.OutlineLevel), " ") & "1. ")
 738             ' numbered?
 739 
 740             'nextPara.Range.ListFormat.ListTemplate.ListLevels(nextPara.Range.ListFormat.ListLevelNumber).NumberStyle
 741             'OLD: If IsNumeric(nextPara.Range.ListFormat.ListString) Then
 742             'If IsNumeric(nextPara.Range.ListFormat.ListString) Then
 743             '    Call nextPara.Range.InsertBefore(String(nextPara.Range.ListFormat.ListLevelNumber, " ") & "1. ")
 744             'Else
 745             '    ' uppercase or lower?
 746             '    ' alpha or roman?
 747             '    Call nextPara.Range.InsertBefore(String(nextPara.Range.ListFormat.ListLevelNumber, " ") & "1. ")
 748             'End If
 749         'End If
 750 
 751     Next nextPara
 752 
 753 End Sub ' ConvertLists
 754 
 755 ' /////////////////////////////////////////////////////////////////////////////
 756 
 757 Sub TagFirstListElements()
 758     Dim iLoopLists As Integer
 759     Dim nextList As ListParagraphs
 760     'Dim nextPara As Paragraph
 761     For iLoopLists = 1 To ActiveDocument.Lists.Count
 762         Set nextList = ActiveDocument.Lists(iLoopLists).Range.ListParagraphs
 763         'Set nextPara = nextList(1)
 764         'Call nextPara.Range.InsertBefore("[first/]")
 765         'nextPara.Range.Text = "[first/]" & nextPara.Range.Text
 766         Call nextList(1).Range.InsertBefore("[first/]")
 767     Next iLoopLists
 768 End Sub ' TagFirstListElements
 769 
 770 ' /////////////////////////////////////////////////////////////////////////////
 771 Private Function ColorToWiki(Color As Long) As String
 772     Dim raw As String
 773     raw = Hex(Color)
 774     
 775     If (raw = "FF000000") Then
 776         'Plain White
 777         ColorToWiki = "FFFFFF"
 778         Exit Function
 779     End If
 780     
 781     'Trim down long ones
 782     If (Len(raw) > 6) Then raw = Right(raw, 6)
 783     
 784     'Lengthen short ones
 785     Do While (Len(raw) < 6)
 786         raw = "0" & raw
 787     Loop
 788     
 789     'Swap Order
 790     Dim C2W As String
 791     C2W = Mid(raw, 5, 2) & Mid(raw, 3, 2) & Mid(raw, 1, 2)
 792     
 793     ColorToWiki = C2W
 794 End Function ' ColorToWiki
 795 
 796 ' /////////////////////////////////////////////////////////////////////////////
 797 Private Sub ConvertTabs()
 798     Dim para As Paragraph
 799     For Each para In ActiveDocument.Paragraphs
 800         If (InStr(1, para.Range.Text, vbTab)) Then
 801             para.Range.InsertBefore "||"
 802             para.Range.Select
 803             Selection.Collapse
 804             Selection.MoveEndUntil vbCr
 805             Selection.InsertAfter "||"
 806         End If
 807     Next para
 808 End Sub ' ConvertTabs
 809 
 810 ' /////////////////////////////////////////////////////////////////////////////
 811 ' This method doesn't handle merged cells at all
 812 ' It will convert all tabs to ||, though
 813 
 814 Private Sub ConvertTables()
 815     Dim thisTable As table
 816     Dim sTextTable As String
 817     Dim arrRows As Variant
 818     Dim arrCols As Variant
 819     Dim iLoopRows As Integer
 820     Dim iLoopCols As Integer
 821     Dim iMaxWidth As Integer
 822     Dim iNumCols As Integer
 823     Dim iTotalWidth As Integer
 824     Dim sRowDividerComment As String
 825     
 826     For Each thisTable In ActiveDocument.Tables
 827         'Determine how many rows and columns there are
 828         Dim tableRow, tableCol As Long
 829         Dim tableMaxRow, tableMaxCol As Long
 830         thisTable.Select
 831         tableMaxRow = Selection.Information(wdMaximumNumberOfRows)
 832         tableMaxCol = Selection.Information(wdMaximumNumberOfColumns)
 833         
 834         'Create format arrays for mapping
 835         Dim tableFormats() As TableCellFormat
 836         ReDim tableFormats(tableMaxRow, tableMaxCol)
 837         Dim R, C As Long
 838         For R = 1 To tableMaxRow
 839             For C = 1 To tableMaxCol
 840                 tableFormats(R, C).FirstCell = False
 841                 tableFormats(R, C).LastCell = False
 842                 tableFormats(R, C).Color = "FFFFFF"
 843                 tableFormats(R, C).HorizAlign = "C"
 844                 tableFormats(R, C).VertAlign = "C"
 845                 tableFormats(R, C).RowSpan = 0
 846                 tableFormats(R, C).ColSpan = 0
 847             Next C
 848         Next R
 849         
 850         ''Check format of each cell
 851         thisTable.Select
 852         Dim thisCell As Cell
 853         For Each thisCell In thisTable.Range.Cells
 854             With thisCell
 855                 C = .ColumnIndex
 856                 R = .RowIndex
 857                 If (C = 1) Then tableFormats(R, C).FirstCell = True
 858                 If .Range.Information(wdMaximumNumberOfColumns) = C Then tableFormats(R, C).LastCell = True
 859                 'Information(wdAtEndOfRowMarker) Then tableFormats(R, C).LastCell = True
 860                 tableFormats(R, C).Color = ColorToWiki(.Range.Shading.BackgroundPatternColor)
 861                 If .Range.Paragraphs(1).Alignment = wdAlignParagraphLeft Then tableFormats(R, C).HorizAlign = "L"
 862                 If .Range.Paragraphs(1).Alignment = wdAlignParagraphRight Then tableFormats(R, C).HorizAlign = "R"
 863                 If .VerticalAlignment = wdCellAlignVerticalTop Then tableFormats(R, C).VertAlign = "T"
 864                 If .VerticalAlignment = wdCellAlignVerticalBottom Then tableFormats(R, C).VertAlign = "B"
 865                 'For now, I can't think of a way of making this accurate
 866                 tableFormats(R, C).RowSpan = 1
 867                 tableFormats(R, C).ColSpan = 1
 868             End With
 869         Next thisCell
 870         
 871         'You may be asking why this is a seperate step.  It's a good question.
 872         'It's mostly because determining the RowSpan and ColSpan might require a seperate step
 873         For Each thisCell In thisTable.Range.Cells
 874             If (Len(thisCell.Range.Text) > 2) Then
 875                 With thisCell
 876                     'Convert cell contents
 877                     Dim rawText As String
 878                     Dim endText As String
 879                     'Toss out the carriage return
 880                     rawText = Left(.Range.Text, Len(.Range.Text) - 2)
 881                     endText = Right(.Range.Text, 1)
 882                     Dim newText As String
 883                     newText = ""
 884                     newText = Replace(rawText, vbCr, "<<BR>>")
 885                     'If (InStr(1, rawText, vbCr)) Then
 886                     '    Do While (Len(rawText) > 0)
 887                     '        Select Case Left(rawText, 1)
 888                     '        Case vbCr: newText = newText & "<<BR>>"
 889                     '        'Case vbLf: newText = newText & "<<BR>>"
 890                     '        Case Else: newText = newText & Left(rawText, 1)
 891                     '        End Select
 892                     '        rawText = Mid(rawText, 2)
 893                     '    Loop
 894                     'Else
 895                     '    newText = rawText
 896                     'End If
 897                     newText = newText & endText
 898                     
 899                     C = .ColumnIndex
 900                     R = .RowIndex
 901                     Dim format As String
 902                     Dim formatStarted As Boolean
 903                     format = ""
 904                     formatStarted = False
 905                     
 906                     If tableFormats(R, C).FirstCell Then
 907                         'format = format & "[tableRow/]" ' add first comment at top of table
 908                         'format = format & "||"
 909                     End If
 910                     
 911                     If tableFormats(R, C).ColSpan = 1 Then
 912                         If tableFormats(R, C).HorizAlign <> "L" Then
 913                             If (Not formatStarted) Then
 914                                 formatStarted = True
 915                                 format = format & "<"
 916                             End If
 917                             If tableFormats(R, C).HorizAlign = "C" Then
 918                                 format = format & ":"
 919                             Else
 920                                 format = format & ")"
 921                             End If
 922                         End If
 923                     Else
 924                         If tableFormats(R, C).HorizAlign <> "C" Then
 925                             If (Not formatStarted) Then
 926                                 formatStarted = True
 927                                 format = format & "<"
 928                             End If
 929                             If tableFormats(R, C).HorizAlign = "L" Then
 930                                 format = format & "("
 931                             Else
 932                                 format = format & ")"
 933                             End If
 934                         End If
 935                     End If
 936                     
 937                     If tableFormats(R, C).VertAlign <> "C" Then
 938                         If (Not formatStarted) Then
 939                             formatStarted = True
 940                             format = format & "<"
 941                         End If
 942                         If tableFormats(R, C).VertAlign = "T" Then
 943                             format = format & "^"
 944                         Else
 945                             format = format & "v"
 946                         End If
 947                     End If
 948                     
 949                     'Row Span - always 1, no action
 950                     'Col Span - always 1, no action
 951                     
 952                     'Color must be last
 953                     If tableFormats(R, C).Color <> "FFFFFF" Then
 954                         If (Not formatStarted) Then
 955                             formatStarted = True
 956                             format = format & "<"
 957                         End If
 958                         format = format & "#" & tableFormats(R, C).Color
 959                     End If
 960                     
 961                     If (formatStarted) Then format = format & ">"
 962                     
 963                     .Range.Text = format & newText
 964                     
 965                     If (tableFormats(R, C).LastCell) Then
 966                         '.Range.InsertAfter "||"
 967                     End If
 968                 End With
 969             End If
 970         Next thisCell
 971         'format = format & "[tableRow/]" ' add next comment after row
 972         
 973         'Exit Sub
 974         
 975         'Convert the table to text, convert tabs to "||"
 976         Dim aRange As Range
 977         Set aRange = thisTable.ConvertToText(wdSeparateByTabs)
 978         'aRange.Text = aRange.Text & "[tableRow/]" ' add final comment at bottom of table
 979         
 980         aRange.Select
 981         Selection.Font.Name = "Courier New"
 982         Selection.Font.Size = 8
 983         
 984 '        With Selection.find
 985 '            .ClearFormatting
 986 '            .Replacement.ClearFormatting
 987 '            .Text = "^t"
 988 '            .Replacement.Text = " ||"
 989 '            .Forward = True
 990 '            .Wrap = wdFindContinue
 991 '            .format = False
 992 '            .MatchCase = False
 993 '            .MatchWholeWord = False
 994 '            .MatchWildcards = False
 995 '            .MatchSoundsLike = False
 996 '            .MatchAllWordForms = False
 997 '            .Execute Replace:=wdReplaceAll
 998 '        End With
 999         
1000         arrRows = Split(aRange.Text, vbCr)
1001         iMaxWidth = 0
1002         For iLoopRows = 0 To UBound(arrRows) - 1
1003             arrCols = Split(arrRows(iLoopRows), vbTab)
1004             iNumCols = UBound(arrCols) + 1
1005             For iLoopCols = 0 To UBound(arrCols) - 1
1006                 If Len(arrCols(iLoopCols)) > iMaxWidth Then
1007                     iMaxWidth = Len(arrCols(iLoopCols))
1008                 End If
1009             Next iLoopCols
1010         Next iLoopRows
1011         
1012         'iTotalWidth = ((iMaxWidth - 2) * iNumCols) - 2 - 3
1013         iTotalWidth = (iMaxWidth * iNumCols) + (iNumCols * 2)
1014         sRowDividerComment = "## " & String(iTotalWidth, "#")
1015         sTextTable = ""
1016         sTextTable = sTextTable & sRowDividerComment & vbCr
1017         
1018         For iLoopRows = 0 To UBound(arrRows) - 1
1019             'If arrRows(iLoopRows) <> "[tableRow/]" Then
1020                 arrCols = Split(arrRows(iLoopRows), vbTab)
1021                 For iLoopCols = 0 To UBound(arrCols)
1022                     sTextTable = sTextTable & "||" & Left(arrCols(iLoopCols) & String(iMaxWidth, " "), iMaxWidth)
1023                 Next iLoopCols
1024                 sTextTable = sTextTable & " ||" & vbCr
1025             'Else
1026             '    sTextTable = sTextTable & "[tableRow/]" & vbCr
1027             'End If
1028             sTextTable = sTextTable & sRowDividerComment & vbCr
1029         Next iLoopRows
1030         
1031         aRange.Text = sTextTable
1032 
1033         
1034         
1035     Next thisTable
1036 End Sub ' ConvertTables
1037 
1038 ' /////////////////////////////////////////////////////////////////////////////
1039 

Attached Files

To refer to attachments on a page, use attachment:filename, as shown below in the list of files. Do NOT use the URL of the [get] link, since this is subject to change and can break easily.
  • [get | view] (2007-06-28 16:59:03, 41.3 KB) [[attachment:Word2MoinV2.bas]]
  • [get | view] (2008-10-17 16:41:29, 41.1 KB) [[attachment:Word2MoinV21.bas]]
  • [get | view] (2007-06-28 16:59:28, 44.0 KB) [[attachment:Word2MoinV2_test_document.doc]]
  • [get | view] (2004-11-02 19:30:20, 24.1 KB) [[attachment:WordToMoin.bas]]
 All files | Selected Files: delete move to page copy to page

You are not allowed to attach a file to this page.