Page 1 of 2 12 LastLast
Results 1 to 10 of 14

Arrows & Text Boxes

This is a discussion on Arrows & Text Boxes within the Excel Questions forums, part of the Question Forums category; I have a workbook, each sheet is protected. Each sheet is a report, which includes inserted images. I would like ...

  1. #1
    New Member
    Join Date
    Aug 2012
    Posts
    22

    Default Arrows & Text Boxes

    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.



    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!

  2. #2
    Board Regular pbornemeier's Avatar
    Join Date
    May 2005
    Location
    Virginia Beach, VA USA
    Posts
    2,609

    Default Re: Arrows & Text Boxes

    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
    Phil

    - Use CODE tags to keep your code formatted. See: BB Tags
    - How to attach Screenshots
    - Try searching for your answer first, see how
    - Test and validate results for all code on a copy of your worksheet!! How do you use the code you just found?
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

  3. #3
    New Member
    Join Date
    Aug 2012
    Posts
    22

    Default Re: Arrows & Text Boxes

    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?

  4. #4
    Board Regular pbornemeier's Avatar
    Join Date
    May 2005
    Location
    Virginia Beach, VA USA
    Posts
    2,609

    Default Re: Arrows & Text Boxes

    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.
    Phil

    - Use CODE tags to keep your code formatted. See: BB Tags
    - How to attach Screenshots
    - Try searching for your answer first, see how
    - Test and validate results for all code on a copy of your worksheet!! How do you use the code you just found?
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

  5. #5
    New Member
    Join Date
    Aug 2012
    Posts
    22

    Default Re: Arrows & Text Boxes

    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.

  6. #6
    New Member
    Join Date
    Aug 2012
    Posts
    22

    Default Re: Arrows & Text Boxes

    the arrow begins in L12 actually, no matter what part of the report I have on the screen.

  7. #7
    New Member
    Join Date
    Aug 2012
    Posts
    22

    Default Re: Arrows & Text Boxes

    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.

  8. #8
    New Member
    Join Date
    Aug 2012
    Posts
    22

    Default Re: Arrows & Text Boxes

    Any ideas?

  9. #9
    Board Regular pbornemeier's Avatar
    Join Date
    May 2005
    Location
    Virginia Beach, VA USA
    Posts
    2,609

    Default Re: Arrows & Text Boxes

    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
    Phil

    - Use CODE tags to keep your code formatted. See: BB Tags
    - How to attach Screenshots
    - Try searching for your answer first, see how
    - Test and validate results for all code on a copy of your worksheet!! How do you use the code you just found?
    - Posting guidelines, forum rules and terms of use
    - Read the FAQs

  10. #10
    New Member
    Join Date
    Aug 2012
    Posts
    22

    Default Re: Arrows & Text Boxes

    I get an error with both macros.

Page 1 of 2 12 LastLast

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  


DMCA.com