Arrows & Text Boxes

Jamey

New Member
Joined
Aug 31, 2012
Messages
22
I have a workbook, each sheet is protected. Each sheet is a report, which includes inserted images. I would like to be able to use arrows and textbox's to annotate the images in a report. I need help with two parts.
1. I need two individual macros. One to generate an Arrow, and the second to Generate a TextBox. Both formatted black, heave, and 3D as in the example. The macros will be launched from the ribbon, so the objects should be launched in the center of whatever the screen is presently displayed.

excelobjects.PNG


2. New reports are generated by a macro that creates a copy of the current report, and deletes data that does not need to be carried over (this include images contained within, and any textbox's / arrows over the images). When new reports are created, I need the TextBox & Arrows to be removed from the new report. So the code would need to be specific for only these two items.

Any help on this would be greatly appreciated!!!! Thanks in advance!
 

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
These should get you started:

Code:
Sub Add_Arrow()

    Dim sName As String
    Dim sngXStart As Single
    Dim sngYStart As Single
    Const SngXOffset As Single = 100
    Const SngYOffset As Single = 100
    sngXStart = (ActiveWindow.Width / 2) - 70
    sngYStart = (ActiveWindow.Height / 2) - 70
    
    ActiveSheet.Shapes.AddLine(sngXStart, sngYStart, sngXStart + SngXOffset, sngYStart + SngYOffset).Select
    sName = "XX_AR_" & Format(Now(), "HHMMSS.MS")
    Selection.Name = sName
    With ActiveSheet.Shapes(sName)
        With .Line
            .EndArrowheadStyle = msoArrowheadOpen
            .EndArrowheadLength = msoArrowheadLengthMedium
            .EndArrowheadWidth = msoArrowheadWidthMedium
            .Weight = 2
            .ForeColor.RGB = RGB(0, 0, 0)
        End With
        With .Shadow
            .Visible = True
            .Type = 23
        End With
    End With

End Sub

Sub Add_Box()

    Dim sName As String
    Dim lx As Long
    
    DeleteTheseShapes
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, (ActiveWindow.Width / 2) - 100, (ActiveWindow.Height / 2) - 25, 200, 50).Select
    sName = "XX_TB_" & Format(Now(), "HHMMSS.MS")
    Selection.Name = sName
    
    With ActiveSheet.Shapes(sName)
        With .Line
            .Visible = msoTrue
            .ForeColor.RGB = RGB(0, 0, 0)
            .BackColor.RGB = RGB(0, 0, 0)
            .Weight = 1.5
        End With
        With .Fill
            .Visible = msoTrue
            .ForeColor.RGB = RGB(0, 0, 0)
            .BackColor.RGB = RGB(0, 0, 0)
        End With
        With .TextFrame.Characters
            .Text = "Your Text Here"
            .Font.ColorIndex = 2
            .Font.Size = 18
        End With
        With .Shadow
            .Visible = True
            .Type = 23 '46 types
        End With
    End With


End Sub

Sub DeleteTheseShapes()

    Dim lx As Long
    
    For lx = ActiveSheet.Shapes.Count To 1 Step -1
        If Left(ActiveSheet.Shapes(lx).Name, 3) = "XX_" Then ActiveSheet.Shapes(lx).Delete
    Next
    
End Sub
 
Upvote 0
Thanks Phil. This works almost perfect. How can I set the focus so that when then macro runs, the arrow/box is inserted into the center of the current view-able area of excel?
 
Upvote 0
It seems to be working that way for me already. That is what the ActiveWindow.Width and ActiveWindow.Height parts of the code is determining. I took "center of whatever the screen is presently displayed" to mean the center of the active window in Excel. What do you mean by that phrase?

The box/arrow could also appear in the upper left corner of the selected cell if that was desirable.
 
Upvote 0
I'm not sure of the pixel resolution, but the sheet/"report" is columns a:q and rows 1 - 250. Users will be scolled to various points vertically within the report when they insert an arrow/box. when i'm scrolled midway down through the report, and try to insert the arrow or box, it inserts to a static location at the top of the report every time.
 
Upvote 0
the arrow begins in L12 actually, no matter what part of the report I have on the screen.
 
Upvote 0
It doesn't have to be perfectly centered to the user's visible screen, just somewhere in the general area, so that they are not having to scroll up 3 or 4 "printable" pages up, and dragging it down. I appreciate the help.
 
Upvote 0
This should put the arrow and box in the center of the viewed range:

Code:
Option Explicit

Sub Add_Arrow()

    Dim sName As String
    Dim sngXStart As Single
    Dim sngYStart As Single
    Dim lTopRow As Long, lBottomRow As Long, lLeftCol As Long, lRightCol As Long
    Dim vScreenParameters As Variant
    Dim rngCenterCell As Range

    vScreenParameters = ReturnScreenValues
    lTopRow = vScreenParameters(0)
    lBottomRow = vScreenParameters(1)
    lLeftCol = vScreenParameters(2)
    lRightCol = vScreenParameters(3)
    Set rngCenterCell = Cells(CLng(lTopRow + (lBottomRow - lTopRow) / 2), CLng(lLeftCol + (lRightCol - lLeftCol) / 2))
    
    Const SngXOffset As Single = 100
    Const SngYOffset As Single = 100
    sngXStart = rngCenterCell.Left - 70
    sngYStart = rngCenterCell.Top - 70
    
    ActiveSheet.Shapes.AddLine(sngXStart, sngYStart, sngXStart + SngXOffset, sngYStart + SngYOffset).Select
    sName = "XX_AR_" & Format(Now(), "HHMMSS.MS")
    Selection.Name = sName
    With ActiveSheet.Shapes(sName)
        With .Line
            .EndArrowheadStyle = msoArrowheadOpen
            .EndArrowheadLength = msoArrowheadLengthMedium
            .EndArrowheadWidth = msoArrowheadWidthMedium
            .Weight = 2
            .ForeColor.RGB = RGB(0, 0, 0)
        End With
        With .Shadow
            .Visible = True
            .Type = 23
        End With
    End With
    
    Set rngCenterCell = Nothing

End Sub

Sub Add_Box()

    Dim sName As String
    Dim lx As Long
    Dim lTopRow As Long, lBottomRow As Long, lLeftCol As Long, lRightCol As Long
    Dim vScreenParameters As Variant
    Dim rngCenterCell As Range

    vScreenParameters = ReturnScreenValues
    lTopRow = vScreenParameters(0)
    lBottomRow = vScreenParameters(1)
    lLeftCol = vScreenParameters(2)
    lRightCol = vScreenParameters(3)
    Set rngCenterCell = Cells(CLng(lTopRow + (lBottomRow - lTopRow) / 2), CLng(lLeftCol + (lRightCol - lLeftCol) / 2))
    
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, rngCenterCell.Left - 100, rngCenterCell.Top - 25, 200, 50).Select
    sName = "XX_TB_" & Format(Now(), "HHMMSS.MS")
    Selection.Name = sName
    
    With ActiveSheet.Shapes(sName)
        With .Line
            .Visible = msoTrue
            .ForeColor.RGB = RGB(0, 0, 0)
            .BackColor.RGB = RGB(0, 0, 0)
            .Weight = 1.5
        End With
        With .Fill
            .Visible = msoTrue
            .ForeColor.RGB = RGB(0, 0, 0)
            .BackColor.RGB = RGB(0, 0, 0)
        End With
        With .TextFrame.Characters
            .Text = "Your Text Here"
            .Font.ColorIndex = 2
            .Font.Size = 18
        End With
        With .Shadow
            .Visible = True
            .Type = 23 '46 types
        End With
    End With

    Set rngCenterCell = Nothing

End Sub

Sub DeleteTheseShapes()

    Dim lx As Long
    
    For lx = ActiveSheet.Shapes.Count To 1 Step -1
        If Left(ActiveSheet.Shapes(lx).Name, 3) = "XX_" Then ActiveSheet.Shapes(lx).Delete
    Next
    
End Sub

Function ReturnScreenValues() As Variant
    'Return an array containing (TopRow, BottomRow, LeftColumn, RightColumn)
    Dim vSplit1 As Variant
    Dim vSplit2 As Variant
    Dim lTopRow As Long, lBottomRow As Long, lLeftCol As Long, lRightCol As Long
    
    vSplit1 = Split(ActiveWindow.VisibleRange.Address(True, True, xlR1C1), ":")
    vSplit2 = Split(vSplit1(0), "C")
    lTopRow = CLng(Mid(vSplit2(0), 2, 100))
    lLeftCol = CLng(vSplit2(1))
    vSplit2 = Split(vSplit1(1), "C")
    lBottomRow = CLng(Mid(vSplit2(0), 2, 100))
    lRightCol = CLng(vSplit2(1))
    ReturnScreenValues = Array(lTopRow, lBottomRow, lLeftCol, lRightCol)
End Function
 
Upvote 0

Forum statistics

Threads
1,213,534
Messages
6,114,188
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top