LoginSignup
0
0

More than 3 years have passed since last update.

【VBA】図形を判断して同一のものだけ変更する(途中)

Last updated at Posted at 2019-06-18
Public dashstyle(2) As Integer
Public ForeColor_ObjectThemeColor(2) As Integer
Public ForeColor_TintAndShade(2) As Integer
Public ForeColor_Brightness(2) As Integer
Public Transparency(2) As Integer
Public Weight(2) As Integer
Public Style(2) As Integer
Public BeginArrowheadStyle(2) As Integer
Public EndArrowheadStyle(2) As Integer
Public BeginArrowheadLength(2) As Integer
Public EndArrowheadLength(2) As Integer
Public BeginArrowheadWidth(2) As Integer
Public EndArrowheadWidth(2) As Integer

Public specified As Boolean
Sub main()
    If 線保存(0) Then
        'If specified Then
            'Call 線変更
        'Else
            Call 線変更
        'End If
    End If
End Sub
Function 線指定()
    specified = 線保存(1)
End Function
Public Function 線保存(ByVal i As Integer) As Boolean
    Dim shp As ShapeRange
    'On Error GoTo ERR_HNDL
    Set shp = Selection.ShapeRange

    If 線判定(shp) Then
        With shp.Line
            dashstyle(i) = .dashstyle
            Transparency(i) = .Transparency
            Weight(i) = .Weight
            Style(i) = .Style
            BeginArrowheadStyle(i) = .BeginArrowheadStyle
            EndArrowheadStyle(i) = .EndArrowheadStyle
            BeginArrowheadLength(i) = .BeginArrowheadLength
            EndArrowheadLength(i) = .EndArrowheadLength
            BeginArrowheadWidth(i) = .BeginArrowheadWidth
            EndArrowheadWidth(i) = .EndArrowheadWidth
            ForeColor_ObjectThemeColor(i) = .ForeColor.ObjectThemeColor
            ForeColor_TintAndShade(i) = .ForeColor.TintAndShade
            ForeColor_Brightness(i) = .ForeColor.Brightness
        End With
        線保存 = True
        Exit Function
    End If

ERR_HNDL:
    線保存 = False
End Function
Public Function 線判定(ByRef shp As ShapeRange) As Boolean
    With shp
        If .Count > 1 Then
            MsgBox "一つだけ選択してください。"
            線判定 = False
            Exit Function
        End If

        If InStr(.Name, "Connector") = 0 Then
            MsgBox "線を選択してください。"
            線判定 = False
            Exit Function
        End If
    End With
    線判定 = True
End Function
Public Function 線変更()
    Dim shp As Shape
    'On Error GoTo ERR_HNDL

    For Each shp In ActiveSheet.Shapes
        If InStr(shp.Name, "Connector") <> 0 Then
            Call 線設定(shp)
        Else
            Debug.Print shp.Type
        End If
    Next
    Exit Function

ERR_HNDL:
End Function
Public Function 線設定(ByRef shp As Shape)
    With shp.Line
        Debug.Print shp.Name
        .dashstyle = dashstyle(0)
        .Transparency = Transparency(0)
        .Weight = Weight(0)
        .Style = Style(0)
        .BeginArrowheadStyle = BeginArrowheadStyle(0)
        .EndArrowheadStyle = EndArrowheadStyle(0)
        .BeginArrowheadLength = BeginArrowheadLength(0)
        .EndArrowheadLength = EndArrowheadLength(0)
        .BeginArrowheadWidth = BeginArrowheadWidth(0)
        .EndArrowheadWidth = EndArrowheadWidth(0)
        .ForeColor.ObjectThemeColor = ForeColor_ObjectThemeColor(0)
        .ForeColor.TintAndShade = ForeColor_TintAndShade(0)
        .ForeColor.Brightness = ForeColor_Brightness(0)
    End With
End Function

参考

https://www.relief.jp/docs/018476.html
https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1151038036
https://www.relief.jp/docs/excel-vba-get-name-selected-shapes.html
https://oshiete.goo.ne.jp/qa/3921059.html

0
0
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
0
0