VBA Snippets

Add

Sub Style_Add(ByVal sStyleName As String)
Const sPROCNAME As String = "Style_Add"
   
Dim objStyle As Style
   
   On Error GoTo ErrorHandler
   If (Style_ExistsInDocument(sStyleName) = True) Then
      Call Style_Delete(sStyleName)
   End If
   
   Set objStyle = ActiveDocument.Styles.Add(Name:=sStyleName, Type:=WdStyleType.wdStyleTypeParagraph)
      
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

Change

Changes the format of a currently existing style in the active document.

Public Sub Style_Change(sStyleName As String)
Const sPROCNAME As String = "Style_Change"
   On Error GoTo AnError
'      .AutomaticallyUpdate = True                          'automatically apply the style

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

Create

Sub Style_Create() 
Dim objStyle As Style 

On Error Resume Next 
Set objStyle = ActiveDocument.Styles.Item("MyNewStyle") 
objStyle.Delete 
On Error GoTo -1 

Set objStyle = ActiveDocument.Styles.Add(Name:="MyNewStyle", _ 
                                         Type:=WdStyleType.wdStyleTypeParagraph) 

With objStyle 
   .BaseStyle = "Normal" 
   .NextParagraphStyle = "Normal" 
   .Font.Bold = False 
   .Font.Italic = False 
   .Font.Underline = False 
   .Font.Name = "Arial" 
   .Font.Size = 14 
   .Font.Color = RGB(0,0,0) 
   .Font.TextColor.RGB = RGB(0, 0, 0) 
   .ParagraphFormat.Alignment = WdParagraphAlignment.wdAlignParagraphLeft 
   .ParagraphFormat.OutlineLevel = WdOutlineLevel.wdOutlineLevelBodyText 
   
   .ParagraphFormat.LineSpacingRule = WdLineSpacing.wdLineSpaceAtLeast 
   .ParagraphFormat.LineSpacing = 12 
   .ParagraphFormat.SpaceBefore = 4    'in cm  
   .ParagraphFormat.SpaceAfter = 2     'in cm  

   .ParagraphFormat.LeftIndent = CentimetersToPoints(1)   'before   'in points 
   .ParagraphFormat.RightIndent = CentimetersToPoints(1)  'after    'in points 
'positive value for a first-line indent, negative value for a hanging indent
   .ParagraphFormat.FirstLineIndent = CentimetersToPoints(-1.5) 

   .ParagraphFormat.WidowControl = False 
   .ParagraphFormat.KeepTogether = False 
   .ParagraphFormat.KeepWithNext = False 
   .ParagraphFormat.PageBreakBefore = True 
End With 

End Sub 

CreateStyle_BodyText1

Sub CreateStyle_BodyText1()
Const sPROCNAME As String = "CreateStyle_BodyText1"
Dim objStyle As Style
Dim sStyleName As String
   On Error GoTo ErrorHandler
   sStyleName = "Body Text 1"
   If (Style_ExistsInDocument(sStyleName) = True) Then
      Call Style_Delete(sStyleName)
   End If
   Call Style_CreateCustom(sStyleName)
   Set objStyle = ActiveDocument.Styles.Item(sStyleName)
   With objStyle
      .BaseStyle = "Normal"
      .NextParagraphStyle = sStyleName
      .ParagraphFormat.LineSpacingRule = WdLineSpacing.wdLineSpaceSingle
      .ParagraphFormat.SpaceBefore = 6
      .ParagraphFormat.SpaceAfter = 6
   End With
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

CreateStyle_BulletLevel1

Sub CreateStyle_BulletLevel1()
Const sPROCNAME As String = "CreateStyle_BulletLevel1"
Dim objStyle As Style
Dim sStyleName As String
Dim oListTemplate As Word.ListTemplate
Dim oListLevel As Word.ListLevel
   On Error GoTo ErrorHandler
   sStyleName = "Bullet Level 1"
   If (Style_ExistsInDocument(sStyleName) = True) Then
      Call Style_Delete(sStyleName)
   End If
   Call Style_CreateCustom(sStyleName)
   Set objStyle = ActiveDocument.Styles.Item(sStyleName)
   If Application.ListGalleries(wdBulletGallery).Modified(1) = True Then
      Application.ListGalleries(wdBulletGallery).Reset 1
   End If
   Set oListTemplate = Application.ListGalleries(wdBulletGallery).ListTemplates(1)
   Set oListLevel = oListTemplate.ListLevels(1)
   oListLevel.Font.Size = 15
   With objStyle
      .Font.ColorIndex = RGB(0, 0, 0)
      .BaseStyle = "List Paragraph"
      .NextParagraphStyle = sStyleName
      .LinkToListTemplate Application.ListGalleries(wdBulletGallery).ListTemplates(1)
      .ParagraphFormat.LineSpacingRule = WdLineSpacing.wdLineSpaceSingle
      .ParagraphFormat.SpaceBefore = 6
      .ParagraphFormat.SpaceAfter = 6
      .ParagraphFormat.LeftIndent = CentimetersToPoints(0.63 + 0.63)
      .ParagraphFormat.RightIndent = CentimetersToPoints(0)  'after
      .ParagraphFormat.FirstLineIndent = CentimetersToPoints(-0.63)
   End With
   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

DefineComponentBorders

Defines the Borders component when defining a new style.

Public Sub Style_DefineComponentBordersFormat(sStyleName As style)
Const sPROCNAME As String = "Style_DefineComponentBorders"
   On Error GoTo AnError
   With sStyleName.Font.Borders
      .AlwaysInFront = True   'true if page borders are displayed in front of text
'      .DistanceFrom = Return_DistanceFrom("FTX")
'      .DistanceFromTop = 4
'      .DistanceFromLeft = 4
'      .DistanceFromBottom = 4                     'in points
'      .DistanceFromRight = 4
'      .Enable = False              'Returns / sets border formatting for the object
      .EnableFirstPageInSection = False
      .EnableOtherPagesInSection = False
'      .InsideColorIndex = Return_ShadingColour("AU")
'      .InsideLineStyle = Return_LineStyle("NO")
'      .InsideLineWidth = Return_LineWidth("025P")
'      .JoinBorders = False
'      .OutsideColorIndex = Return_ShadingColour("AU")
'      .OutsideLineStyle = Return_LineStyle("NO")
'      .OutsideLineWidth = Return_LineWidth("025P")
'      .Shadow = False
'      .SurroundFooter = False
'      .SurroundHeader = False
   End With
   If gbDEBUG = False Then Exit Sub
AnError:
'   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
   Call MsgBox( _
        "define the BORDERS component for the style """ & sStyleName & """")
End Sub

DefineComponentBulletsNumbering

Defines the Bullets & Numbering component when defining a new style.

Public Sub Style_DefineComponentBulletsNumbering(sStyleName As style)
Const sPROCNAME As String = "Style_DefineComponentBulletsNumbering"

   On Error GoTo AnError
   With sStyleName


   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "define the BULLETS & NUMBERING component for the style """ & sStyleName & """")
End Sub

DefineComponentFont

Defines the Font component when defining a new style.

Public Sub Style_DefineComponentFont(sStyleName As style, _
                                           Optional sFontName As String = "UN", _
                                           Optional bBold As Boolean = False, _
                                           Optional bItalic As Boolean = False, _
                                           Optional sngFontSize As Single = 9.5, _
                                           Optional sUnderline As String = "NO", _
                                           Optional sShadingColour As String = "AU", _
   Optional bStrikethrough As Boolean = False, _
   Optional bDoublestrkethrough As Boolean = False, _
   Optional bSuperscript As Boolean = False, Optional bSubscript As Boolean = False, _
   Optional bShadow As Boolean = False, Optional bOutline As Boolean = False, _
   Optional bEmboss As Boolean = False, Optional bEngrave As Boolean = False, _
   Optional bSmallcaps As Boolean = False, Optional bAllcaps As Boolean = False, _
   Optional bHidden As Boolean = False, Optional iScaling As Integer = 100, _
   Optional iSpacing As Integer = 0, _
   Optional sCaptionPosition As String = "AB", _
   Optional iKerning As Integer = 0, Optional sAnimation As String = "NO")
   
Const sPROCNAME As String = "Style_DefineComponentFont"
   On Error GoTo AnError
   
   With sStyleName.Font
      .Name = Return_FontName(sFontName)
      .Bold = bBold
      .Italic = bItalic
      .Size = sngFontSize
      .Underline = zReturn_Underline(sUnderline)
      .ColorIndex = zReturn_ShadingColour(sShadingColour)
'checkboxes
      .StrikeThrough = bStrikethrough
      .DoubleStrikeThrough = bDoublestrkethrough
      .Superscript = bSuperscript
      .Subscript = bSubscript
      .Shadow = bShadow
      .Outline = bOutline
      .Emboss = bEmboss
      .Engrave = bEngrave
      .SmallCaps = bSmallcaps
      .AllCaps = bAllcaps
      .Hidden = bHidden
'next tab
      .Scaling = iScaling               'the scaling percentage of the text
      .Spacing = iSpacing                 'whats the character spacing default ???
      .Position = zReturn_CaptionPosition(sCaptionPosition)
      .Kerning = iKerning                '0 no kerning or a number eg  16
      .Animation = zReturn_Animation(sAnimation)
      End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "define the FONT component for teh style """ & sStyleName & """")
End Sub

DefineComponentFrame

Defines the Frame formatting component when defining a new style.

Public Sub Style_DefineComponentFrame(sStyleName As style)
Const sPROCNAME As String = "Style_DefineComponentFrame"
   On Error GoTo AnError
   With sStyleName

   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "define the FRAME component for the style """ & sStyleName & """")
End Sub

DefineComponentParagraph

Defines the Paragraph formatting when defining a new style.

Public Sub Style_DefineComponentParagraph(sStyleName As style)
Const sPROCNAME As String = "Style_DefineComponentParagraph"
   On Error GoTo AnError
   With sStyleName.ParagraphFormat
      .LineSpacingRule = zReturn_ParaLineSpacing("AL")
'      .LineSpacing = 0
      
      .LeftIndent = 0
      .RightIndent = 0
      .Alignment = wdAlignParagraphCenter
      .FirstLineIndent = 0
      
      With .Shading
         .BackgroundPatternColorIndex = wdBlue
         .ForegroundPatternColorIndex = wdAuto
         .Texture = zReturn_ShadingTexture("NO")
      End With
      
      With .Borders
        .DistanceFromTop = 1
        .DistanceFromBottom = 0
        .DistanceFromLeft = 2
        .DistanceFromRight = 0
      End With
   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "define the PARAGRAPH component for the style """ & sStyleName & """")
End Sub

DefineComponentTabs

Defines the tabs component when defining a new style.

Public Sub Style_DefineComponentTabs(sStyleName As style)
Const sPROCNAME As String = "Style_DefineComponentTabs"
   On Error GoTo AnError
   With sStyleName

   End With
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "define the TABS component for the style """ & sStyleName & """")
End Sub

DefineOne

Defines a new style in the active document.

Public Sub Style_DefineOne(sStyleName As String, _
                           Optional sBasedOnStyle As String)
Const sPROCNAME As String = "Style_DefineOne"
Dim styNewStyle As style
   On Error GoTo AnError
   Set styNewStyle = ActiveDocument.Styles.Add(Name:=sStyleName, _
                                               Type:=wdStyleTypeParagraph)
   With styNewStyle
      .BaseStyle = "Heading 1"                         'formatting is based on this style
      .NextParagraphStyle = "Normal"                   'next paragraph afterwards
      .LanguageID = zReturn_LanguageID("NO")
         
      Call Style_DefineFontFormat(styNewStyle)
      
      Call Style_DefineParagraphFormat(styNewStyle)
      
      Call Style_DefineTabsFormat(styNewStyle)
         
      Call Style_DefineBordersFormat(styNewStyle)
         
      Call Style_DefineFrameFormat(styNewStyle)
      
      Call Style_DefineBulletsNumberingFormat(styNewStyle)
         
   End With

   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "define the new style """ & sStyleName & """ in the active document")
End Sub

Delete

Sub Style_Delete(ByVal sStyleName As String)
Const sPROCNAME As String = "Style_Delete"
   
Dim objStyle As Style
   
   On Error GoTo ErrorHandler
   Set objStyle = ActiveDocument.Styles.Item(sStyleName)
   objStyle.Delete

   Exit Sub
ErrorHandler:
   Call Error_Handle(msMODULENAME, sPROCNAME, Err.Number, Err.Description)
End Sub

DeleteAll

Deletes all the styles in the active document that are either in use, built-in or user-defined.

Public Sub Styles_DeleteAll(Optional bInUse As Boolean = False, _
                            Optional bBuiltIn As Boolean = False, _
                            Optional bUserDefined As Boolean = False)
Const sPROCNAME As String = "Styles_DeleteAll"

Dim style As style
   On Error GoTo AnError
   For Each style In ActiveDocument.Styles
      On Error Resume Next
      If bInUse = True Then If style.InUse = True Then style.Delete
      If bBuiltIn = True Then If style.BuiltIn = True Then style.Delete
      If bUserDefined = True Then If style.BuiltIn = False Then style.Delete
   Next style
   If gbDEBUG = False Then Exit Sub
AnError:
   Call Error_Handle(msMODULENAME, sPROCNAME, 1,
        "delete all the Custom styles in the active document that are:" & vbcrlf & _
        "in use, built-in or user defined")
End Sub

ExistsInDocument

Function Style_ExistsInDocument(ByVal sStyleName As String) As Boolean
Dim objStyle As Style
   
   On Error GoTo ErrorHandler
   Set objStyle = ActiveDocument.Styles.Item(sStyleName)
   Style_ExistsInDocument = True
   
   Exit Function
ErrorHandler:
   Style_ExistsInDocument = False
End Function

HasAnyShapes

Public Function Sel_HasAnyShapes() As Boolean
   On Error GoTo AnError
   If Application.Selection.Range.ShapeRange.Count > 0 Then
      Sel_HasAnyShapes = True
   End If
AnError:
   Sel_HasAnyShapes = False
End Function

Question_ValidateStylesAll

Public Function Question_ValidateStylesAll() As Boolean
Dim breturn As Boolean
Dim lResult As VBA.VbMsgBoxResult
Dim sMessage As String
    sMessage = "Are you sure you want to validate all the styles in this document."
    lResult = MsgBox(sMessage, vbYesNo + vbQuestion, g_sCOMPANYNAME & " (" & g_sVERSION & ") - " & "Validate Styles")
    If (lResult = vbYes) Then breturn = True
    If (lResult = vbNo) Then breturn = False
    Call Tracer_Add("QUESTION", sMessage)
    Question_ValidateStylesAll = breturn
End Function

StyleChange

Public Sub Sel_StyleChange(ByVal sstylename As String)
   On Error GoTo AnError
   Application.Selection.Style = ActiveDocument.Styles(sstylename)
   If gbDEBUG_ERRMSG = False Then Exit Sub
AnError:
   Call Error_Handle("Sel_StyleChange", msMODULENAME, _
        "change the style of the selection.")
End Sub

StyleNameIncorrect

Public Sub Message_StyleNameIncorrect(ByVal sStyleName As String)
Dim sMessage As String
    sMessage = "The style '" & sStyleName & "' is incorrect"
    Call MsgBox(sMessage, vbOKOnly + vbInformation, g_sCOMPANYNAME & " (" & g_sVERSION & ") - " & "Style Name Incorrect")
    Call Tracer_Add("MESSAGE", sMessage)
End Sub

---

© 2024 Better Solutions Limited. All Rights Reserved. © 2024 Better Solutions Limited Top