Saberexcel - o site das macros
Exemplo de macros e planilha do Aplicativo Microsoft Excel VBA, contém procedimentos com userforms e commandbuttons, que selecionam fontes, e também caracteres Wingdings , através de Userforms Objetos VBA(Visual Basic Application).

Option Explicit

Sub Selecionando_fontes()
Dim iI As Integer
Dim wksChars As Worksheet
Set wksChars = Worksheets("Characters")

Load frmFontPicker

With frmFontPicker
For iI = 1 To 4
.Controls("cmdFont" & iI).Caption = _
wksChars.Range("myFont" & iI).Cells(1, 1).Font.Name
wksChars.Range("myFontName" & iI).Value = _
.Controls("cmdFont" & iI).Caption
Next ' iI
.Show
End With

With wksChars
For iI = 1 To 4
.Range("myFontName" & iI).Value = _
.Range("myFont" & iI).Cells(1, 1).Font.Name
Next ' iI
End With

Unload frmFontPicker
Set wksChars = Nothing
Application.StandardFont = "Arial Narrow"
End Sub

CRIANDO UM MENU

Option Explicit

Sub Create_Menu()
Dim MyBar As CommandBar
Dim MyPopup As CommandBarPopup
Dim MyButton As CommandBarButton

Delete_Menu

Set MyBar = CommandBars.Add(Name:="My Fonts", _
Position:=msoBarFloating, temporary:=True)

With MyBar
.Top = 125
.Left = 850

Set MyButton = .Controls.Add(Type:=msoControlButton)
With MyButton
.Caption = "Select Fonts"
.Style = msoButtonCaption
.BeginGroup = True
.OnAction = "SelectFonts"
End With
.Width = 100
.Visible = True
End With
End Sub

Sub Delete_Menu()
On Error Resume Next
CommandBars("My Fonts").Delete
On Error GoTo 0
End Sub

'-----------------------------------'

EM OUTRO MÓDULO INSIRA OS CÓDIGOS:
Sub Macro1()
With Application
.UserName = "E_Marcondes"
.StandardFont = "Arial Narrow"
.StandardFontSize = "10"
.DefaultFilePath = "C:\VBA\"
.EnableSound = False
.RollZoom = False
End With
End Sub

Sub Macro2()

Application.Goto Reference:="myFont1"
With Selection.Font
.Name = "Courier New"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
End Sub

Sub Abrir_caixa_dialogo_fonte()
Application.Dialogs(xlDialogFont).Show
End Sub

Sub abrir()
wksChars.Select
frmFontPicker.Show
End Sub


NO MODULO DE CÓDIGO DO USERFORM

Option Explicit
Dim myFontName As String
Dim wksChars As Worksheet
Dim rngChars As Range
Dim bFont As Boolean

Private Sub subFontFormatDialog(myFontNumber As Integer)
Dim myFontName As String
'''Dim myFontNumber As Integer
Dim wksChars As Worksheet
Dim rngChars As Range
Dim bFont As Boolean

Set wksChars = Worksheets("Characters")

Set rngChars = wksChars.Range("myFont" & myFontNumber)

rngChars.Select
bFont = Application.Dialogs(xlDialogFormatFont).Show
DoEvents

Me.Controls("cmdFont" & myFontNumber).Caption = _
wksChars.Range("myFont" & myFontNumber).Cells(1, 1).Font.Name

wksChars.Cells(1, 1).Select
Set rngChars = Nothing
Set wksChars = Nothing
End Sub

Private Sub cmdFont1_Click()
subFontFormatDialog 1
End Sub

Private Sub cmdFont2_Click()
subFontFormatDialog 2
End Sub

Private Sub cmdFont3_Click()
subFontFormatDialog 3
End Sub

Private Sub cmdFont4_Click()
subFontFormatDialog 4
End Sub

Private Sub cmdOkay_Click()
Me.Hide
End Sub

Aplicativo Microsoft Excel VBA --(( SaberExcel VBA ))--