René Nyffenegger's collection of things on the web
René Nyffenegger on Oracle - Most wanted - Feedback -
 

Creating graphics with macros with MS Word

The following three Subs create an adp-«logo». In order to create it, the Do_graphic sub must be called.
Sub Do_graphic()
  
  Dim Dist_D            As Long
  Dim Dist_P            As Long
  Dim LetterSize        As Long
  
  Dim Fnt               As String
  
  Dim x_orig            As Long
  Dim y_orig            As Long
  
  
  Dim Black             As Long
  Dim Color_2           As Long 
  
  Dim LineWeight_1      As Long
  Dim LineWeight_2      As Long
  Dim LineWeight_3      As Long
  
  
  Black        = RGB(0, 0, 0)
  Color_2      = RGB(20, 80, 240)
  
  LineWeight_1 = 3
  LineWeight_2 = LineWeight_1 * 1.6
  LineWeight_3 = 0.5
  
  Fnt          = "Verdana"
  LetterSize   = 120
  
  x_orig       = 100
  y_orig       = 200
  
  Dist_D       = LetterSize / 1.7
  Dist_P       = Dist_D + LetterSize / 1.73
  
  DrawLine x_orig + LetterSize / 10, y_orig + LetterSize * 0.35, (Dist_D + Dist_P) * 2, 0, LineWeight_1
  DrawLine x_orig + LetterSize / 10, y_orig + LetterSize * 1.10, (Dist_D + Dist_P) * 2, 0, LineWeight_2
  DrawLine x_orig + LetterSize / 10, y_orig + LetterSize * 1.17, (Dist_D + Dist_P) * 2, 0, LineWeight_3
  

  DrawLetter "a", x_orig, y_orig, LetterSize, LetterSize, Fnt, Color_2
  DrawLetter "d", x_orig + Dist_D, y_orig, LetterSize, LetterSize, Fnt, Color_2
  DrawLetter "p", x_orig + Dist_P, y_orig, LetterSize, LetterSize, Fnt, Color_2

End Sub


Sub DrawLetter(Letter As String, x As Long, y As Long, w As Long, fontSize As Long, FontName As String, Color As Long)
  ' h (= height): not needed, it's automatically calculated below (txtf.AutoSize)

  Dim sh    As Shape
  Dim txtr  As Range
  Dim txtf  As TextFrame
  
  Set sh = ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, x, y, w, 1)

  
  Set txtf = sh.TextFrame
  Set txtr = txtf.TextRange
  
  txtr.Text = Letter
  
 
  txtr.Font.Size     = fontSize
  txtr.Font.Bold     = msoTrue
  txtr.Font.Name     = FontName
  txtr.Font.Color    = Color
  
  txtf.MarginLeft    = 0
  txtf.MarginRight   = 0
  txtf.MarginTop     = 0
  txtf.MarginBottom  = 0
  
  sh.Fill.Visible    = msoFalse
  sh.Line.Visible    = msoFalse
  
  txtf.AutoSize      = True
   
End Sub

Sub DrawLine(x As Long, y As Long, w As Long, h As Long, weight As Long)

  Dim sh As Shape
  
  Set sh = ActiveDocument.Shapes.AddLine(x, y, x + w, y + h)
  
  sh.Line.weight = weight

End Sub