hexagon logo
Register Sign in
  • Replies 3 replies
  • Subscribers 21 subscribers
  • Views 66 views
  • Users 0 members are here
Options
Related

Excel Balloon or Bubble Creator

Dave Hocum
Attach is a Excel Balloon or Bubble Creator that I used before Discus.

Bubble Print.zip
  • Here is the VBA Code for Module1 
    Option Base 1
Dim intCounter As Integer
--------------------------------------------------------------------------------------
Sub CreateLabel10()
Dim objshape As Object
    'Retrieve and set starting label
    SetStartingLabelNbr
    
    'Create new shape
    ActiveSheet.Shapes.AddShape(msoShapeOval, 305, 3#, 25.5, 25.5).Select
    Set objshape = Selection
    Selection.ShapeRange.TextFrame.MarginLeft = 0#
    Selection.ShapeRange.TextFrame.MarginRight = 0#
    Selection.ShapeRange.TextFrame.MarginTop = 0#
    Selection.ShapeRange.TextFrame.MarginBottom = 0#
    Selection.ShapeRange.Fill.Transparency = 1
    Selection.ShapeRange.Line.Transparency = 0#
    'Format the shape
    objshape.Characters.Text = intCounter
    With objshape.Characters(Start:=1, Length:=Len(intCounter)).Font
        .Name = "Arial"
        .FontStyle = "Regular"
        .Size = 10
        .ColorIndex = 3
    End With
    'increase shape size for number of digits
    With objshape.ShapeRange
    objshape.Characters.Text = intCounter
'Added (objshape.Characters.Text = intCounter)Above
        .Line.ForeColor.SchemeColor = 10
'Added (.LockAspectRatio = msoFalse)Below
        '.LockAspectRatio = msoTrue
        .LockAspectRatio = msoFalse
        '.Height = 15.25
        If intCounter < 10 Then .Width = 15.5
        If intCounter >= 10 And intCounter < 100 Then .Width = 21.5
        If intCounter >= 100 And intCounter < 1000 Then .Width = 25.25
'Added (If intCounter >= 100 And intCounter < 1000 Then .Width = 26.25)Above
        If intCounter >= 1000 Then .Width = 36.25
        If intCounter < 10 Then .Height = 15.5
        If intCounter >= 10 And intCounter < 100 Then .Height = 15.5
        If intCounter >= 100 And intCounter < 1000 Then .Height = 15.5
'Added (If intCounter >= 100 And intCounter < 1000 Then .Height = 15.25)Above
        If intCounter >= 1000 Then .Height = 15.5
    End With
Selection.HorizontalAlignment = xlCenter
    'increment shape number and store in text box
    intCounter = intCounter + 1
    ActiveSheet.TextBox1.Text = intCounter
End Sub
--------------------------------------------------------------------------------------------

Sub CreateLabel12()
Dim objshape As Object
    'Retrieve and set starting label
    SetStartingLabelNbr
    
    'Create new shape
    ActiveSheet.Shapes.AddShape(msoShapeOval, 305, 3#, 25.5, 25.5).Select
    Set objshape = Selection
    Selection.ShapeRange.TextFrame.MarginLeft = 0#
    Selection.ShapeRange.TextFrame.MarginRight = 0#
    Selection.ShapeRange.TextFrame.MarginTop = 0#
    Selection.ShapeRange.TextFrame.MarginBottom = 0#
    Selection.ShapeRange.Fill.Transparency = 1
    Selection.ShapeRange.Line.Transparency = 0#
    'Format the shape
    objshape.Characters.Text = intCounter
    With objshape.Characters(Start:=1, Length:=Len(intCounter)).Font
        .Name = "Arial"
        .FontStyle = "Regular"
        .Size = 12
        .ColorIndex = 3
    End With
    'increase shape size for number of digits
    With objshape.ShapeRange
    objshape.Characters.Text = intCounter
'Added (objshape.Characters.Text = intCounter)Above
        .Line.ForeColor.SchemeColor = 10
'Added (.LockAspectRatio = msoFalse)Below
        '.LockAspectRatio = msoTrue
        .LockAspectRatio = msoFalse
        '.Height = 15.25
        If intCounter < 10 Then .Width = 19.5
        If intCounter >= 10 And intCounter < 100 Then .Width = 23.5
        If intCounter >= 100 And intCounter < 1000 Then .Width = 29.25
'Added (If intCounter >= 100 And intCounter < 1000 Then .Width = 26.25)Above
        If intCounter >= 1000 Then .Width = 40.25
        If intCounter < 10 Then .Height = 19.5
        If intCounter >= 10 And intCounter < 100 Then .Height = 19.5
        If intCounter >= 100 And intCounter < 1000 Then .Height = 19.5
'Added (If intCounter >= 100 And intCounter < 1000 Then .Height = 15.25)Above
        If intCounter >= 1000 Then .Height = 19.5
    End With
Selection.HorizontalAlignment = xlCenter
    'increment shape number and store in text box
    intCounter = intCounter + 1
    ActiveSheet.TextBox1.Text = intCounter
End Sub
-----------------------------------------------------------------------------------------------------------------------------

Sub CreateLabel8()
Dim objshape As Object
    'Retrieve and set starting label
    SetStartingLabelNbr
    
    'Create new shape
    ActiveSheet.Shapes.AddShape(msoShapeOval, 305, 3#, 25.5, 25.5).Select
    Set objshape = Selection
    Selection.ShapeRange.TextFrame.MarginLeft = 0#
    Selection.ShapeRange.TextFrame.MarginRight = 0#
    Selection.ShapeRange.TextFrame.MarginTop = 0#
    Selection.ShapeRange.TextFrame.MarginBottom = 0#
    Selection.ShapeRange.Fill.Transparency = 1
    Selection.ShapeRange.Line.Transparency = 0#
    'Format the shape
    objshape.Characters.Text = intCounter
    With objshape.Characters(Start:=1, Length:=Len(intCounter)).Font
        .Name = "Arial"
        .FontStyle = "Regular"
        .Size = 8
        .ColorIndex = 3
    End With
    'increase shape size for number of digits
    With objshape.ShapeRange
    objshape.Characters.Text = intCounter
'Added (objshape.Characters.Text = intCounter)Above
        .Line.ForeColor.SchemeColor = 10
'Added (.LockAspectRatio = msoFalse)Below
        '.LockAspectRatio = msoTrue
        .LockAspectRatio = msoFalse
        '.Height = 15.25
        If intCounter < 10 Then .Width = 12.5
        If intCounter >= 10 And intCounter < 100 Then .Width = 16.5
        If intCounter >= 100 And intCounter < 1000 Then .Width = 21.25
'Added (If intCounter >= 100 And intCounter < 1000 Then .Width = 26.25)Above
        If intCounter >= 1000 Then .Width = 26.25
        If intCounter < 10 Then .Height = 12.5
        If intCounter >= 10 And intCounter < 100 Then .Height = 12.5
        If intCounter >= 100 And intCounter < 1000 Then .Height = 12.5
'Added (If intCounter >= 100 And intCounter < 1000 Then .Height = 15.25)Above
        If intCounter >= 1000 Then .Height = 12.5
    End With
Selection.HorizontalAlignment = xlCenter
    'increment shape number and store in text box
    intCounter = intCounter + 1
    ActiveSheet.TextBox1.Text = intCounter
End Sub
--------------------------------------------------------------------------------------------------------

Sub CreateLabel5()
Dim objshape As Object
    'Retrieve and set starting label
    SetStartingLabelNbr
    
    'Create new shape
    ActiveSheet.Shapes.AddShape(msoShapeOval, 305, 3#, 25.5, 25.5).Select
    Set objshape = Selection
    Selection.ShapeRange.TextFrame.MarginLeft = 0#
    Selection.ShapeRange.TextFrame.MarginRight = 0#
    Selection.ShapeRange.TextFrame.MarginTop = 0#
    Selection.ShapeRange.TextFrame.MarginBottom = 0#
    Selection.ShapeRange.Fill.Transparency = 1
    Selection.ShapeRange.Line.Transparency = 0#
    'Format the shape
    objshape.Characters.Text = intCounter
    With objshape.Characters(Start:=1, Length:=Len(intCounter)).Font
        .Name = "Arial"
        .FontStyle = "Regular"
        .Size = 5
        .ColorIndex = 3
    End With
    'increase shape size for number of digits
    With objshape.ShapeRange
    objshape.Characters.Text = intCounter
'Added (objshape.Characters.Text = intCounter)Above
        .Line.ForeColor.SchemeColor = 10
'Added (.LockAspectRatio = msoFalse)Below
        '.LockAspectRatio = msoTrue
        .LockAspectRatio = msoFalse
        '.Height = 15.25
        If intCounter < 10 Then .Width = 9.5
        If intCounter >= 10 And intCounter < 100 Then .Width = 12.5
        If intCounter >= 100 And intCounter < 1000 Then .Width = 13.25
'Added (If intCounter >= 100 And intCounter < 1000 Then .Width = 26.25)Above
        If intCounter >= 1000 Then .Width = 18.25
        If intCounter < 10 Then .Height = 9.5
        If intCounter >= 10 And intCounter < 100 Then .Height = 9.5
        If intCounter >= 100 And intCounter < 1000 Then .Height = 9.5
'Added (If intCounter >= 100 And intCounter < 1000 Then .Height = 15.25)Above
        If intCounter >= 1000 Then .Height = 9.5
    End With
Selection.HorizontalAlignment = xlCenter
    'increment shape number and store in text box
    intCounter = intCounter + 1
    ActiveSheet.TextBox1.Text = intCounter
End Sub
  • Here is the VBA Code for Module1 continue 

    -------------------------------------------------------------------------------------------------

Sub CreateLabel3()
Dim objshape As Object
    'Retrieve and set starting label
    SetStartingLabelNbr
    
    'Create new shape
    ActiveSheet.Shapes.AddShape(msoShapeOval, 305, 3#, 25.5, 25.5).Select
    Set objshape = Selection
    Selection.ShapeRange.TextFrame.MarginLeft = 0#
    Selection.ShapeRange.TextFrame.MarginRight = 0#
    Selection.ShapeRange.TextFrame.MarginTop = 0#
    Selection.ShapeRange.TextFrame.MarginBottom = 0#
    Selection.ShapeRange.Fill.Transparency = 1
    Selection.ShapeRange.Line.Transparency = 0#
    'Format the shape
    objshape.Characters.Text = intCounter
    With objshape.Characters(Start:=1, Length:=Len(intCounter)).Font
        .Name = "Arial"
        .FontStyle = "Regular"
        .Size = 3
        .ColorIndex = 3
    End With
    'increase shape size for number of digits
    With objshape.ShapeRange
    objshape.Characters.Text = intCounter
'Added (objshape.Characters.Text = intCounter)Above
        .Line.ForeColor.SchemeColor = 10
'Added (.LockAspectRatio = msoFalse)Below
        '.LockAspectRatio = msoTrue
        .LockAspectRatio = msoFalse
        '.Height = 15.25
        If intCounter < 10 Then .Width = 6.5
        If intCounter >= 10 And intCounter < 100 Then .Width = 8.5
        If intCounter >= 100 And intCounter < 1000 Then .Width = 10.25
'Added (If intCounter >= 100 And intCounter < 1000 Then .Width = 26.25)Above
        If intCounter >= 1000 Then .Width = 12.25
        If intCounter < 10 Then .Height = 6.5
        If intCounter >= 10 And intCounter < 100 Then .Height = 6.5
        If intCounter >= 100 And intCounter < 1000 Then .Height = 6.5
'Added (If intCounter >= 100 And intCounter < 1000 Then .Height = 15.25)Above
        If intCounter >= 1000 Then .Height = 6.5
    End With
Selection.HorizontalAlignment = xlCenter
    'increment shape number and store in text box
    intCounter = intCounter + 1
    ActiveSheet.TextBox1.Text = intCounter
End Sub
------------------------------------------------------------------------------------------------

Sub GroupShapes()
Dim arShapes() As Variant
Dim objRange As Object
Dim i As Integer
    i = 1
    
    'Count the ovals on the page
    For Each sh In ActiveSheet.Shapes
        If sh.Type = 1 Then
            i = i + 1
        End If
    Next
    
    'set array size to the number of ovals
    ReDim arShapes(1 To i - 1)
    
    i = 1
    
    'create array of oval names
    For Each sh In ActiveSheet.Shapes
        If sh.Type = 1 Then
            arShapes(i) = sh.Name
            i = i + 1
        End If
    Next
    
    'Create range of oval shapes
    Set objRange = ActiveSheet.Shapes.Range(arShapes)
    
    'Select ovals
    objRange.Select
    'Group ovals
    objRange.Group
End Sub
© 2024 Hexagon AB and/or its subsidiaries. Privacy Policy | Cloud Services Agreement