home *** CD-ROM | disk | FTP | other *** search
/ PC Pro 1999 April / DPPCPRO0499.ISO / Rwc / Apps.txt next >
Encoding:
Text File  |  1999-01-25  |  3.1 KB  |  119 lines
  1. Listing one
  2. Public Sub ListEuroFonts()
  3.  
  4.     Dim vntFont As Variant
  5.     Dim intCount As Integer
  6.  
  7.     Let intCount = 1
  8.     
  9.     'List all the fonts
  10.  
  11.     For Each vntFont In FontNames
  12.  
  13.         With Selection
  14.             .TypeText intCount
  15.             .TypeText Chr(9)
  16.             .Font.Name = vntFont
  17.             .TypeText Chr(128)
  18.             .TypeText Chr(9)
  19.             .TypeText vntFont
  20.             .TypeText Chr(9)
  21.             .Font.Name = "Courier New"
  22.             .TypeText vntFont
  23.             .TypeText Chr(13)
  24.         End With
  25.  
  26.         Let intCount = intCount + 1
  27.     Next vntFont
  28.  
  29.     'Select the whole document
  30.     Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
  31.     
  32.     'Convert to a table
  33.     Selection.ConvertToTable Separator:=wdSeparateByTabs, _
  34.         NumColumns:=4, NumRows:=intCount - 1, _
  35.         Format:=wdTableFormatNone, ApplyBorders:=True, _
  36.         ApplyShading:=True, ApplyFont:=True, _
  37.         ApplyColor:=True, ApplyHeadingRows:=True, _
  38.         ApplyLastRow:=False, ApplyFirstColumn:=True, _
  39.         ApplyLastColumn:=False, Autofit:=True
  40.     
  41.     'Sort the table
  42.     Selection.Sort ExcludeHeader:=False, _
  43.         FieldNumber:="Column 4", _
  44.         SortFieldType:=wdSortFieldAlphanumeric, _
  45.         SortOrder:=wdSortOrderAscending, _
  46.         Separator:= wdSortSeparateByTabs, _
  47.         SortColumn:=False, _
  48.         CaseSensitive:=False, _
  49.         LanguageID:=wdEnglishUK
  50.         
  51.     'AutoFit to Contents
  52.     Selection.Tables(1).AutoFormat _
  53.         Format:=wdTableFormatSimple1, _
  54.         ApplyBorders:=False, ApplyShading:=False, _
  55.         ApplyFont:=False, ApplyColor:=False, _
  56.         ApplyHeadingRows:=False, ApplyLastRow:=False, _
  57.         ApplyFirstColumn:=False, ApplyLastColumn:=False, _
  58.         Autofit:=True
  59.     
  60.     'Go to the beginning
  61.     Selection.HomeKey Unit:=wdStory
  62. End Sub
  63.  
  64. Listing two
  65. Sub OneBecomesTwo()
  66.     
  67.     With ActiveWindow.Selection
  68.         .Cut
  69.         
  70.         With .SlideRange
  71.             .Layout = ppLayoutTwoColumnText
  72.             .Shapes(3).Select
  73.         End With
  74.         
  75.         With .ShapeRange.TextFrame.TextRange
  76.             .Select
  77.             .Characters(Start:=1, Length:=0).Select
  78.         End With
  79.         
  80.         ActiveWindow.View.Paste
  81.         .Unselect
  82.     End With
  83.  
  84. End Sub
  85.  
  86. Sub TwoBecomeOne()
  87.     
  88.     With ActiveWindow.Selection
  89.         .SlideRange.Shapes(3).Select
  90.         
  91.         With .ShapeRange.TextFrame.TextRange
  92.             .Select
  93.             .Characters(Start:=1, Length:=.Length).Select
  94.         End With
  95.         
  96.         .Cut
  97.  
  98.         With .SlideRange 
  99.             .Layout = ppLayoutText
  100.             .Shapes(2).Select
  101.         End With
  102.         
  103.         With .ShapeRange.TextFrame.TextRange
  104.             .Select
  105.             .Characters(Start:=.Length, Length:=0).Select
  106.             .InsertAfter Chr$(CharCode:=13)
  107.         End With
  108.         
  109.         With .ShapeRange.TextFrame.TextRange
  110.             .Characters(Start:=.Length, Length:=0).Select
  111.             .InsertAfter.Paste
  112.         End With
  113.         
  114.         .Unselect
  115.     End With
  116.     
  117. End Sub
  118.  
  119.