VBA/Excel/Access/Word/Excel/Chart Format

Материал из VB Эксперт
Версия от 12:47, 26 мая 2010; Admin (обсуждение | вклад) (1 версия)
(разн.) ← Предыдущая | Текущая версия (разн.) | Следующая → (разн.)
Перейти к: навигация, поиск

Add Chart Sheet

 
Option Explicit
Public Sub AddChartSheet()
  Dim aChart As Chart
  Set aChart = Charts.Add
  With aChart
    .Name = "Mangoes"
    .ChartType = xlColumnClustered
    .SetSourceData Source:=Sheets("Sheet1").Range("A3:D7"), PlotBy:=xlRows
    .HasTitle = True
    .ChartTitle.Text = "=Sheet1!R3C1"
  End With
End Sub



adds a light blue shadow to the box surrounding a legend:

 
Sub FormatShadow()
    Dim myChart As Chart
    Set myChart = ActiveChart
    With myChart.Legend.Format.Shadow
        .ForeColor.RGB = RGB(0, 0, 128)
        .OffsetX = 5
        .OffsetY = -3
        .Transparency = 0.5
        .Visible = True
    End With
End Sub



adds a line around the title and adds a glow around that line:

 
Sub AddGlowToTitle()
    Dim myChart As Chart
    Set myChart = ActiveChart
    myChart.ChartTitle.Format.Line.ForeColor.RGB = RGB(255, 255, 255)
    myChart.ChartTitle.Format.Line.DashStyle = msoLineSolid
    myChart.ChartTitle.Format.Glow.Color.ObjectThemeColor = msoThemeColorAccent6
    myChart.ChartTitle.Format.Glow.Radius = 8
End Sub



Adds major gridlines, title, and x-axis labels to an embedded chart

 
Public Sub SetXAxis()
    Dim myAxis As Axis
    Set myAxis = ActiveSheet.ChartObjects(1).Chart.Axes(xlCategory, xlPrimary)
    With myAxis    "Set properties of x-axis
        .HasMajorGridlines = True
        .HasTitle = True
        .AxisTitle.Text = "My Axis"
        .AxisTitle.Font.Color = RGB(1, 2, 3)
        .CategoryNames = Range("C2:C11")
        .TickLabels.Font.Color = RGB(11, 12, 13)
    End With
End Sub



Applying chart formatting

 
Sub ChartMods()
    ActiveChart.Type = xlArea
    ActiveChart.ChartArea.font.name = "Calibri"
    ActiveChart.ChartArea.font.FontStyle = "Regular"
    ActiveChart.ChartArea.font.Size = 9
    ActiveChart.PlotArea.Interior.ColorIndex = xlNone
    ActiveChart.Axes(xlValue).TickLabels.font.bold = True
    ActiveChart.Axes(xlCategory).TickLabels.font.bold = True
    ActiveChart.Legend.Position = xlBottom
End Sub



Background and Foreground color

 
Public Sub TestPoint()
    Dim myPoint As Point
    Set myPoint = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1).Points(3)
    With myPoint
        .ApplyDataLabels xlDataLabelsShowValue
        .MarkerBackgroundColor = RGB(1, 2, 3)
        .MarkerForegroundColor = RGB(11, 22, 33)
    End With
End Sub



Changing a Chart Title Using VBA

 
Sub ApplyTexture()
    Dim myChart As Chart
    Dim ser As Series
    Set myChart = ActiveChart
    Set ser = myChart.SeriesCollection(2)
    ser.Format.Fill.PresetTextured (msoTextureGreenMarble)
End Sub



Changing the Bevel and 3-D Format

 
Sub AssignBevel()
    Dim myChart As Chart
    Dim ser As Series
    Set myChart = ActiveChart
    Set ser = myChart.SeriesCollection(1)
    ser.Format.ThreeD.Visible = True
    ser.Format.ThreeD.BevelTopType = msoBevelCircle
    ser.Format.ThreeD.BevelTopInset = 16
    ser.Format.ThreeD.BevelTopDepth = 6
End Sub



creates the chart with absolute reference and format it

 
Sub CreateOHCLChart()
    Dim myChart As Chart
    Dim Ser As Series
    ActiveSheet.Shapes.AddChart(xlLineMarkers).Select
    Set myChart = ActiveChart
    myChart.SetSourceData Source:=range("Sheet1!$A$1:$E$33")
    With myChart.SeriesCollection(1)
        .MarkerStyle = xlMarkerStylePicture
        .Fill.UserPicture ("C:\dash.gif")
        .Border.LineStyle = xlNone
        .MarkerForegroundColorIndex = xlColorIndexNone
    End With
    With myChart.SeriesCollection(2)
        .MarkerStyle = xlMarkerStyleNone
        .Border.LineStyle = xlNone
    End With
    With myChart.SeriesCollection(3)
        .MarkerStyle = xlMarkerStyleNone
        .Border.LineStyle = xlNone
    End With
    " Format the Close series
    Set Ser = myChart.SeriesCollection(4)
    With Ser
        .MarkerBackgroundColorIndex = 1
        .MarkerForegroundColorIndex = 1
        .MarkerStyle = xlDot
        .MarkerSize = 9
        .Border.LineStyle = xlNone
    End With
    " Add High-Low Lines
    myChart.SetElement (msoElementLineHiLoLine)
    myChart.SetElement (msoElementLegendNone)
End Sub



defines a Chart object variable and a ChartGroup object variable and then stops:

 
Sub ExploreChartElements()
    Dim myChart As Chart
    Dim myChartg As ChartGroup
    Dim ser As Series
    Set myChart = ActiveChart
    Set myChartg = myChart.ChartGroups(1)
    Set ser = myChart.SeriesCollection(1)
    Stop
End Sub



Format Axis, Title font size and color

 
Sub FormattingCharts()
    Dim myChart As Chart
    Dim ws As Worksheet
    Dim ax As Axis
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set myChart = GetChartByCaption(ws, "GDP")
    If Not myChart Is Nothing Then
        Set ax = myChart.Axes(xlCategory)
        With ax
            .AxisTitle.Font.Size = 12
            .AxisTitle.Font.Color = vbRed
        End With
    End If
    Set ax = Nothing
    Set myChart = Nothing
    Set ws = Nothing
End Sub
Function GetChartByCaption(ws As Worksheet, sCaption As String) As Chart
    Dim myChart As ChartObject
    Dim myChart As Chart
    Dim sTitle As String
    Set myChart = Nothing
    For Each myChart In ws.ChartObjects
        If myChart.Chart.HasTitle Then
            sTitle = myChart.Chart.ChartTitle.Caption
            If StrComp(sTitle, sCaption, vbTextCompare) = 0 Then
                Set myChart = myChart.Chart
                Exit For
            End If
        End If
    Next
    Set GetChartByCaption = myChart
    Set myChart = Nothing
    Set myChart = Nothing
End Function



Format Soft Edges With Loop

 
Sub FormatSoftEdgesWithLoop()
    Dim myChart As Chart
    Dim ser As Series
    Set myChart = ActiveChart
    Set ser = myChart.SeriesCollection(1)
    For i = 1 To 6
        ser.Points(i).Format.SoftEdge.Type = i
    Next i
End Sub



formats the trendline for the first series in a chart:

 
Sub FormatLineOrBorders()
    Dim myChart As Chart
    Set myChart = ActiveChart
    With myChart.SeriesCollection(1).Trendlines(1).Format.Line
        .DashStyle = msoLineLongDashDotDot
        .ForeColor.RGB = RGB(50, 0, 128)
        .BeginArrowheadLength = msoArrowheadShort
        .BeginArrowheadStyle = msoArrowheadOval
        .BeginArrowheadWidth = msoArrowheadNarrow
        .EndArrowheadLength = msoArrowheadLong
        .EndArrowheadStyle = msoArrowheadTriangle
        .EndArrowheadWidth = msoArrowheadWide
    End With
End Sub



Formatting a Basic Chart

 
Sub FormattingCharts()
    Dim myChart As Chart
    Dim ws As Worksheet
    Dim ax As Axis
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set myChart = GetChartByCaption(ws, "GDP")
    If Not myChart Is Nothing Then
        Set ax = myChart.Axes(xlCategory)
        With ax
            .AxisTitle.Font.Size = 12
            .AxisTitle.Font.Color = vbRed
        End With
        Set ax = myChart.Axes(xlValue)
        With ax
            .HasMinorGridlines = True
            .MinorGridlines.Border.LineStyle = xlDashDot
        End With
        With myChart.PlotArea
            .Border.LineStyle = xlDash
            .Border.Color = vbRed
            .Interior.Color = vbWhite
            .Width = myChart.PlotArea.Width + 10
            .Height = myChart.PlotArea.Height + 10
        End With
        myChart.ChartArea.Interior.Color = vbWhite
        myChart.Legend.Position = xlLegendPositionBottom
    End If
    Set ax = Nothing
    Set myChart = Nothing
    Set ws = Nothing
End Sub
Function GetChartByCaption(ws As Worksheet, sCaption As String) As Chart
    Dim myChart As ChartObject
    Dim myChart As Chart
    Dim sTitle As String
    Set myChart = Nothing
    For Each myChart In ws.ChartObjects
        If myChart.Chart.HasTitle Then
            sTitle = myChart.Chart.ChartTitle.Caption
            If StrComp(sTitle, sCaption, vbTextCompare) = 0 Then
                Set myChart = myChart.Chart
                Exit For
            End If
        End If
    Next
    Set GetChartByCaption = myChart
    Set myChart = Nothing
    Set myChart = Nothing
End Function



formatting a border

 
Sub FormatBorder()
    Dim myChart As Chart
    Set myChart = ActiveChart
    With myChart.ChartArea.Format.Line
        .DashStyle = msoLineLongDashDotDot
        .ForeColor.RGB = RGB(50, 0, 128)
    End With
End Sub



Looping through the ChartObjects collection: changes the chart type of every embedded chart on the active sheet.

 
Sub ChartType()
    Dim myChart As ChartObject
    For Each myChart In ActiveSheet.ChartObjects
        myChart.Chart.Type = xlArea
    Next myChart
End Sub



Loop through each series in chart and alter marker colors

 
Public Sub TestSeries()
    Dim mySeries As Series
    Dim seriesCol As SeriesCollection
    Dim I As Integer
    I = 1
    Set seriesCol = ActiveSheet.ChartObjects(1).Chart.SeriesCollection
    For Each mySeries In seriesCol
        Set mySeries = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(I)
        With mySeries
            .MarkerBackgroundColor = RGB(1, 32, 43)
            .MarkerForegroundColor = RGB(11, 32, 43)
            .Border.Color = RGB(11, 12, 23)
        End With
        I = I + 1
    Next
End Sub



Manipulating Charts

 
Public Sub ChartInterior()
    Dim myChart As Chart
    "Reference embedded chart
    Set myChart = ActiveSheet.ChartObjects(1).Chart
    With myChart   "Alter interior colors of chart components
        .ChartArea.Interior.Color = RGB(1, 2, 3)
        .PlotArea.Interior.Color = RGB(11, 12, 1)
        .Legend.Interior.Color = RGB(31, 32, 33)
        If .HasTitle Then
            .ChartTitle.Interior.Color = RGB(41, 42, 43)
        End If
    End With
End Sub



Modifying chart properties: changes the Legend font for all charts on the active sheet.

 
Sub LegendMod()
    Dim myChart As ChartObject
    For Each myChart In ActiveSheet.ChartObjects
        With myChart.Chart.Legend.font
            .name = "Calibri"
            .FontStyle = "Bold"
            .Size = 12
        End With
    Next myChart
End Sub



proper syntax for SoftEdge:

 
Sub Main()
    Chart.Seriess(1).Points(i).Format.SoftEdge.Type = msoSoftEdgeType1
End Sub



Set Axes gridline and its border color

 
Sub FormattingCharts()
    Dim myChart As Chart
    Dim ws As Worksheet
    Dim ax As Axis
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set myChart = GetChartByCaption(ws, "GDP")
    If Not myChart Is Nothing Then
        Set ax = myChart.Axes(xlValue)
        With ax
            .HasMinorGridlines = True
            .MinorGridlines.Border.LineStyle = xlDashDot
        End With
    End If
    Set ax = Nothing
    Set myChart = Nothing
    Set ws = Nothing
End Sub
Function GetChartByCaption(ws As Worksheet, sCaption As String) As Chart
    Dim myChart As ChartObject
    Dim myChart As Chart
    Dim sTitle As String
    Set myChart = Nothing
    For Each myChart In ws.ChartObjects
        If myChart.Chart.HasTitle Then
            sTitle = myChart.Chart.ChartTitle.Caption
            If StrComp(sTitle, sCaption, vbTextCompare) = 0 Then
                Set myChart = myChart.Chart
                Exit For
            End If
        End If
    Next
    Set GetChartByCaption = myChart
    Set myChart = Nothing
    Set myChart = Nothing
End Function



Set PlotArea LineStyle, border color, width and height

 
Sub FormattingCharts()
    Dim myChart As Chart
    Dim ws As Worksheet
    Dim ax As Axis
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set myChart = GetChartByCaption(ws, "GDP")
    If Not myChart Is Nothing Then
        With myChart.PlotArea
            .Border.LineStyle = xlDash
            .Border.Color = vbRed
            .Interior.Color = vbWhite
            .Width = myChart.PlotArea.Width + 10
            .Height = myChart.PlotArea.Height + 10
        End With
    End If
    Set ax = Nothing
    Set myChart = Nothing
    Set ws = Nothing
End Sub
Function GetChartByCaption(ws As Worksheet, sCaption As String) As Chart
    Dim myChart As ChartObject
    Dim myChart As Chart
    Dim sTitle As String
    Set myChart = Nothing
    For Each myChart In ws.ChartObjects
        If myChart.Chart.HasTitle Then
            sTitle = myChart.Chart.ChartTitle.Caption
            If StrComp(sTitle, sCaption, vbTextCompare) = 0 Then
                Set myChart = myChart.Chart
                Exit For
            End If
        End If
    Next
    Set GetChartByCaption = myChart
    Set myChart = Nothing
    Set myChart = Nothing
End Function



sets up a two-color gradient using two theme colors:

 
Sub TwoColorGradient()
    Dim myChart As Chart
    Dim ser As Series
    Set myChart = ActiveChart
    Set ser = myChart.SeriesCollection(1)
    MyPic = "C:\Title1.jpg"
    ser.Format.Fill.TwoColorGradient msoGradientFromCorner, 3
    ser.Format.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent6
    ser.Format.Fill.BackColor.ObjectThemeColor = msoThemeColorAccent2



To apply one of the 3-D rotation presets to a chart element: use the SetPresetCamera method

 
Sub Assign3DPreset()
    Dim myChart As Chart
    Dim shp As Shape
    Set myChart = ActiveChart
    Set shp = myChart.Shapes(1)
    shp.ThreeD.SetPresetCamera msoCameraIsometricLeftDown
End Sub



To fill the bars of a data series with a picture

 
Sub FormatWithPicture()
    Dim myChart As Chart
    Dim ser As Series
    Set myChart = ActiveChart
    Set ser = myChart.SeriesCollection(1)
    MyPic = "C:\Title.jpg"
    ser.Format.Fill.UserPicture (MyPic)
End Sub



Working with a Chart Axis

 
Sub chartAxis()
    Dim myChartObject As ChartObject
    Set myChartObject = ActiveSheet.ChartObjects.Add(Left:=200, Top:=200, _
        Width:=400, Height:=300)
    
    myChartObject.Chart.SetSourceData Source:= _
        ActiveWorkbook.Sheets("Chart Data").Range("A1:E5")
    
    myChartObject.SeriesCollection.Add Source:=ActiveSheet.Range("C4:K4"), Rowcol:=xlRows
    myChartObject.SeriesCollection.NewSeries
    myChartObject.HasTitle = True
    
    With myChartObject.Axes(Type:=xlCategory, AxisGroup:=xlPrimary)
        .HasTitle = True
        .AxisTitle.Text = "Years"
        .AxisTitle.Font.Name = "Times New Roman"
        .AxisTitle.Font.Size = 12
        .HasMajorGridlines = True
        .HasMinorGridlines = False
    End With
End Sub



works on all the chart sheets in the active workbook

 
Sub ChartType2()
    Dim myChart As Chart
    For Each myChart In ActiveWorkbook.Charts
        myChart.Type = xlArea
    Next myChart
End Sub