Attachment 'Word2MoinV2.bas'
Download 1 Attribute VB_Name = "Word2Moin"
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.You are not allowed to attach a file to this page.