VBA Snippets

Frame_GetDetails

Public Sub Frame_GetDetails()
Dim objframe As Word.Frame

   Set objframe = ActiveDocument.Frames(1)

   Debug.Print "WidthRule : " & objframe.WidthRule
   Debug.Print "Width : " & objframe.Width
   Debug.Print "HeightRule : " & objframe.HeightRule
   Debug.Print "HorizontalPosition : " & objframe.HorizontalPosition
   Debug.Print "RelativeHorizontalPosition : " & objframe.RelativeHorizontalPosition
   Debug.Print "VerticalPosition : " & objframe.VerticalPosition
   Debug.Print "RelativeVerticalPosition : " & objframe.RelativeVerticalPosition
   Debug.Print "HorizontalDistanceFromText : " & objframe.HorizontalDistanceFromText
   Debug.Print "VerticalDistanceFromText : " & objframe.VerticalDistanceFromText

End Sub

Frame_Insert

Inserts a frame at the current position in the active document.

Public Sub Frame_Insert()
Const sPROCNAME As String = "Frame_Insert"
Dim sText$
   On Error GoTo AnError
   
   With Selection
   
   'from before
   '   Selection.MoveDown Unit:=wdLine, count:=1
   '   ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 50, 50, 100, 80).Select
   
      Call Para_Select
      sText = Selection
      .Delete
   
       ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, 10, 10).Select
       
       'depending on where the text box is inserted originally depends on where the anchor is ??
       
       .ShapeRange.TextFrame.TextRange.Select
       
       .ShapeRange(1).ConvertToFrame
       With .Frames(1)
           .Select
           .TextWrap = True
           .WidthRule = wdFrameExact
           .Width = CentimetersToPoints(4.28)
           .HeightRule = wdFrameAuto
           .HorizontalPosition = CentimetersToPoints(1.5)
           .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
           .VerticalPosition = CentimetersToPoints(0.15)
           .RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
           .HorizontalDistanceFromText = CentimetersToPoints(0.32)
           .VerticalDistanceFromText = CentimetersToPoints(0.32)
           .LockAnchor = False
           
       End With
       .Borders(wdBorderTop).LineStyle = wdLineStyleNone
       .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
       .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
       .Borders(wdBorderRight).LineStyle = wdLineStyleNone
       .TypeText Text:=sText

   End With

   If gbDEBUG = False Then Exit Sub
AnError:
'   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
   Call MsgBox( _
        "")
End Sub

Picture_Paste

Pastes a picture from the clipboard.

Public Sub Picture_Paste()
Const sPROCNAME As String = "Picture_Paste"
   On Error GoTo AnError
   
    Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, _
        Placement:=wdInLine, DisplayAsIcon:=False

   If gbDEBUG = False Then Exit Sub
AnError:
'   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
   Call MsgBox( _
        "")
End Sub

Public Sub Word_PicturePaste(XLSheet As String, _
                             XLBookmark As String, _
                             WDBookmark As String)
   On Error GoTo AnError
   gXLwrkb.Sheets(XLSheet).Range(XLBookmark).Copy
   gWDappl.activedocument.Bookmark(WDBookmark).Select
   gWDappl.Selection.PasteSpecial Link:=False, DisplayAsIcon:=False
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle("Word_PicturePaste", msMODULENAME, 1, _
        "paste the Excel range")
End Sub

Shape_Resize

Adjusts the size of a given shape may be redundent after the "at least".

Public Sub Shape_Resize(iHeight As Integer, _
                        iWidth As Integer)   
Const sPROCNAME As String = "Shape_Resize"
   On Error GoTo AnError
   With Selection
       .MoveLeft wdCharacter, 1, wdExtend
       On Error GoTo NoChart
       .InlineShapes(1).LockAspectRatio = msoFalse
       .InlineShapes(1).Height = iHeight
       .InlineShapes(1).Width = iWidth
       .MoveRight wdCharacter, 1
   End With
NoChart:
   If gbDEBUG = False Then Exit Sub
AnError:
'   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
   Call MsgBox( _
        "resize the shape ??")
End Sub

Shapes_DisplayList

Public Sub Shapes_DisplayList(ByVal objShapes As Word.Shapes)

   Dim sshapename As String
   Dim icount As Integer

   For icount = objShapes.Count To 1 Step -1
       sshapename = objShapes.Item(icount).Name
   
       Debug.Print sshapename
       
   Next icount
End Sub

TextBox_GetDetails

Public Sub TextBox_GetDetails()
Dim objtextboxshape As Word.Shape

   Set objtextboxshape = ActiveDocument.Shapes(1)

   Debug.Print "Left : " & objtextboxshape.Left
   Debug.Print "Top : " & objtextboxshape.Top
   Debug.Print "Width : " & objtextboxshape.Width
   Debug.Print "Height : " & objtextboxshape.Height

End Sub

TextBox_RestrictLength

Limits the number of carriage returns allowed in a multi-line text box.

Public Function TextBox_RestrictLength(sText As String, _
                                       iLinesMax As Integer, _
                                       ctrlTextBox As TextBox, _
                                       Optional bReset As Boolean = False) As String

Static stextbefore As String
Dim ilinescount As Integer
   On Error GoTo AnError
   If bReset = True Then bUpDateTextBox = True
   ilinescount = Str_CharNoOf(sText)

   If (ilinescount < iLinesMax) Then
      TextBox_RestrictLength = sText
      stexbefore = sText
   End If
   If (ilinescount = iLinesMax) Then
      bUpdateTextBox = False
     ctrlTextBox.Text = stextbefore
      TextBox_RestrictLength = stextbefore
      ilinescount = ilinescount + 1
   End If

   If gbDEBUG = False Then Exit Function
AnError
   Call Error_Handle("TextBox_RestrictLength", msMODULENAME, 1, _
        "")
End Function