|
 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 ))--
|