calling excel genius - cell comment autosize??

[darro]

I have the code below, and it works perfectly on my Mac. But... on my PC it does not.

The cell comment does not resize horizontally when I enter text. So if I enter a long comment I get a comment box that extends far to the right to fit the contents in. Vertically it is fine, nothing cut off and no extra space.

Any ideas why this would be? Any ideas how I can force the text to wrap in the cell comment box?

Thanks in advance for your help. Code is below:

Sub AddCom()
Const USERNAME As String = "Greer:"
Dim strCommentName As String
Dim cmnt As String
Dim NoMore As Boolean
Dim Pos As Long
    
    cmnt = InputBox("Please enter a comment")
    strCommentName = cmnt & vbLf & Now
    On Error GoTo 0

    With activeCell
    
        If .Comment Is Nothing Then
        
            strCommentName = USERNAME & Chr(10) & strCommentName
        Else
    
            strCommentName = .Comment.Text & Chr(10) & vbLf & USERNAME & Chr(10) & strCommentName
            .Comment.Delete
        End If
     
        With .AddComment(strCommentName)
        
            .Visible = False
            .Shape.AutoShapeType = msoShapeRoundedRectangle
            
            Pos = 0
            Do
            
                Pos = InStr(Pos + 1, strCommentName, USERNAME)
                If Pos > 0 Then
                
                    With .Shape.TextFrame
                    
                        With .Characters(Pos, Len(USERNAME)).Font
                        
                            .Bold = True
                            .Italic = True
                            .ColorIndex = 3
                        End With
                    End With
                End If
            Loop Until Pos = 0
    
        End With
        
        .Comment.Shape.TextFrame.AutoSize = True
        .Comment.Visible = False
    End With
     
End Sub

 

[J Ericson]

Could you first autofit the textframe to account for height and then hard code the shape width?


Snippet from your orig code;

    With ActiveCell
 
        'Some additional Code is here
 
        .Comment.Shape.TextFrame.AutoSize = True
        .Comment.Shape.Width = 250
        .Comment.Visible = False
 
    End With

 

[darro]

All is good with it, the only problem is that it will start a new line in the middle of a word if the 20th character falls there. Any one got an idea how I can make it start a new line only when a new word starts near the 20 character?

Thanks

 

[darro]

Thanks for jumping in J,

I have tried that, on Mac it works fine, but on PC it does define the width but somehow overrides the autosize. So I end up with a limited in width comment but it cuts off the bottom of the text. No idea why.

So far the only way i have found of getting both things to work right is by defining a max line length, however that starts new lines in the middle of words which is not what I need.

Anyone know how to keep the max linelength but make it recognise the spaces and start new line accordingly?

 

[Tom Urtis]

Is this what you want?

Sub KommentRap()
Dim i%, j%, intCutoff%, intWords%
Dim myName$, strOldComment$, strInterimComment$, strInterimLine$, strNewComment$
i = 1: j = 1: intCutoff = 20
myName = "Greer:"
strNewComment = InputBox("Enter your comment text:", "Comment")
 
If strNewComment = "" Then Exit Sub
strInterimComment = "": strInterimLine = ""
 
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
 
With ActiveCell
If .Comment Is Nothing Then
strOldComment = ""
Else
strOldComment = .Comment.Text & vbLf & vbLf
.Comment.Delete
End If
 
Sheets.Add
With Range("A1")
.Value = strNewComment
.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, Space:=True, FieldInfo:=Array(Array(1, 1))
intWords = .CurrentRegion.Columns.count
End With
 
Do
Do
strInterimLine = strInterimLine & Cells(1, i).Value & " "
i = i + 1
j = i
Loop Until i > intWords Or Len(strInterimLine) + Len(Cells(1, i).Value) >= intCutoff
strInterimLine = strInterimLine & Chr(10)
strInterimComment = strInterimComment & strInterimLine
strInterimLine = ""
Loop While j <= intWords
 
strInterimComment = myName & vbLf & strInterimComment & Now
strNewComment = strOldComment & strInterimComment
 
ActiveSheet.Delete
.AddComment
With .Comment
.Visible = False
.Text Text:=strNewComment
.Shape.AutoShapeType = msoShapeRoundedRectangle
 
With .Shape.TextFrame
.AutoSize = True
.Characters.Font.Bold = False
.Characters.Font.ColorIndex = 1
 
For i = 1 To Len(strNewComment) - Len(myName) Step 1
If Mid(strNewComment, i, Len(myName)) = myName Then
With .Characters(i, Len(myName)).Font
.Bold = True
.Italic = True
.ColorIndex = 3
End With
End If
Next i
 
End With
End With
End With
 
.EnableEvents = True
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub

 

[darro]

Thanks Tom, that does work on Mac (unable to test it on PC just now) but it takes a while to run the macro and has visible screen flicker as it does it. Is there a way to speed it up maybe? What do you think?

Also, concerning the previous code from Mick, is it possible to make the max line length dependent on where a space appears in a string of text?

Thanks for all your help everyone, I feel like I'm very close to a solution now.

 

[Tom Urtis]

Are you sure about all that? Did you run the macro I posted or did you do anything to it? My screen did not flicker at all and the macro ran in an instant. In fact it does less than your original one does because it does not add a "non-text" comment entry when the InputBox is cancelled which yours does. Also, because you are using an inputbox, the new comment cannot be greater than 255 charactares, meaning the code would not take very long with such a small amount of text.

You wrote:
"...is it possible to make the max line length dependent on where a space appears in a string of text?"

Don't know what that means. Try framing the question with a few lines of example text, and at each line saying where the break should be in this case or that case.

 

[darro]

I didn't add anything to your code, and it definitely had some screen flicker.

As far as the max line length question is concerned I'm not sure how to frame it with the code as I have no idea how to go about it.

In Micks cod it limits the max line length in the cell comment to 20 characters. Regardless of where the 20 character limit falls it starts a new line of text. This could be in the middle of a word, which would then cut the word in half over the first and new line. What I want to know is if the max line length could be a fluid thing, so it would be limited to 20 characters only if the 20th character was a space, if it wasn't a space, the max line length would move to the space nearest to the 20th character.

Or I suppose it would be easier just to say that the max line length would be set as the nearest space to the 20th character.

Is that clear? Not sure if i have explained that well enough.

 

[darro]

I didn't add anything to your code, and it definitely had some screen flicker.

As far as the max line length question is concerned I'm not sure how to frame it with the code as I have no idea how to go about it.

In Micks code it limits the max line length in the cell comment to 20 characters. Regardless of where the 20 character limit falls it starts a new line of text. This could be in the middle of a word, which would then cut the word in half over the first and new line. What I want to know is if the max line length could be a fluid thing, so it would be limited to 20 characters only if the 20th character was a space, if it wasn't a space, the max line length would move to the space nearest to the 20th character.

Or I suppose it would be easier just to say that the max line length would be set as the nearest space to the 20th character.

Is that clear? Not sure if i have explained that well enough.

 

[John_w]

Don't you just need a simple word wrap routine? Here's a complete working example, based on your code:

Option Explicit

Sub AddCom()
Const USERNAME As String = "Greer:"
Dim strCommentName As String
Dim cmnt As String
Dim NoMore As Boolean
Dim Pos As Long
Dim i As Integer
Dim text As String
    
    Const maxLineLength As Long = 20

    cmnt = InputBox("Please enter a comment")
    
    cmnt = Word_Wrap(cmnt, maxLineLength)

    strCommentName = cmnt & vbLf & Now

    On Error GoTo 0

    With ActiveCell
    
        If .Comment Is Nothing Then
        
            strCommentName = USERNAME & Chr(10) & strCommentName
        Else
    
            strCommentName = .Comment.text & Chr(10) & vbLf & USERNAME & Chr(10) & strCommentName
            .Comment.Delete
        End If
     
        With .AddComment(strCommentName)
        
            .Visible = False
            .Shape.AutoShapeType = msoShapeRoundedRectangle
            
            Pos = 0
            Do
            
                Pos = InStr(Pos + 1, strCommentName, USERNAME)
                If Pos > 0 Then
                
                    With .Shape.TextFrame
                    
                        With .Characters(Pos, Len(USERNAME)).Font
                        
                            .Bold = True
                            .Italic = True
                            .ColorIndex = 3
                        End With
                    End With
                End If
            Loop Until Pos = 0
    
        End With
        
        .Comment.Shape.TextFrame.AutoSize = True
        .Comment.Visible = False
    End With
     
End Sub


Function Word_Wrap(text As String, maxLineLength As Integer) As String

Dim words() As String
Dim line As String
Dim word As Variant

Word_Wrap = ""

words = Split(text, " ")
line = ""

For Each word In words
    If Len(line & word) > maxLineLength Then
        If Word_Wrap = "" Then
            Word_Wrap = line
        Else
            Word_Wrap = Word_Wrap & vbLf & line
        End If
        line = word
    Else
        If line = "" Then
            line = word
        Else
            line = line & " " & word
        End If
    End If
Next

If line <> "" Then
    If Word_Wrap = "" Then
        Word_Wrap = line
    Else
        Word_Wrap = Word_Wrap & vbLf & line
    End If
End If

End Function

 

[darro]

Hi John, thanks for your help. I have tried your code and beneath is a snippet from it I get the message "sub or function not defined" and it highlights the part I have indicated. Any ideas? This is on Mac I will try on PC too though.

.Comment.Shape.TextFrame.AutoSize = True
        .Comment.Visible = False
    End With
     
End Sub


[COLOR=Orange]Function Word_Wrap(text As String, maxLineLength As Integer) As String[/COLOR]

Dim words() As String
Dim line As String
Dim word As Variant

Word_Wrap = ""

words = Split(text, " ")
line = ""

For Each word In words
If Len(line & word) > maxLineLength Then
If Word_Wrap = "" Then
Word_Wrap = line