Bilder in Kommentaren: Seitenverhältnisse bewahren

[TxbyFmjy]

Diese Schnipsel gehören nicht in ein Modul, sondern unter Microsoft Exel Objekte in DieseArbeitsmappe.

Diese Lösung funktioniert auch, wenn die Arbeitsmappe bis zu max. 5 Tabellen enthält und auch dann, wenn zwischen Tabellen mehrfach hin- und hergewechselt wird.

Diese Lösung funktioniert auch, wenn die Seitenverhälltnisse aller Kommentare in einer Tabelle unterschiedlich sind., z. Bsp.: wenn in jedem Kommentar ein anderes Hintergrundbild eingefügt wird.

Diese Lösung bringt jedoch leider auch ein Problem mit sich, wenn die Tabelle Hunderte oder über Tausend Kommentare enthält, weil dann das Speichern der Datei für Benutzer*innen gefühlt "inakzeptabel lange" dauert.

Randbedingungen:

• Arbeitsmappe mit max. 5 Tabellen
  
• Kommentare mit unterschiedlichen Seitenverhältnissen
  
• Seitenverhältnisse der Kommentare werden bewahrt
  
• Hintergrundbilder in Kommentaren bleiben verzerrungsfrei
  

Code:

Option Explicit
Option Base 1
Private ws As Worksheet
Dim cmtamount(5) As Integer
Dim SV1() As Double
Dim SV2() As Double
Dim SV3() As Double
Dim SV4() As Double
Dim SV5() As Double
Dim AktiveTabelle(1 To 100) As String
Dim AktiveTabelle2(1 To 1) As String
Dim c1 As Integer
Dim c2 As Integer
Dim c3 As Integer
Dim c4 As Integer
Dim c5 As Integer
Dim cmtc As Long
Dim i As Integer
Dim j As Integer

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim objComment As Comment
Dim ScaleValue2 As Double
c3 = c1
cmtc = 0
    If ActiveSheet.Comments.Count = 0 Then
     MsgBox "No comments in entire sheet"
    End If
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For c1 = 1 To c3
cmtc = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Select Case c1
Case 1
For Each objComment In Worksheets(AktiveTabelle(c1)).Comments
cmtc = cmtc + 1
'Resize
        With objComment.Shape
            .LockAspectRatio = msoFalse
            .TextFrame.AutoSize = False
        ScaleValue2 = .Height / .Width
        Debug.Print cmtc; c1; SV1(cmtc); ScaleValue2; AktiveTabelle(c1)
        If ScaleValue2 <> SV1(cmtc) Then
        .Width = 150
        .Height = .Width * SV1(cmtc)
            .LockAspectRatio = msoTrue
        Debug.Print cmtc; c1; SV1(cmtc); ScaleValue2; .Width; .Height
        End If
        End With
        Debug.Print cmtc; c1; SV1(cmtc); ScaleValue2; objComment.Shape.Width; objComment.Shape.Height
Next objComment
Case 2
For Each objComment In Worksheets(AktiveTabelle(c1)).Comments
cmtc = cmtc + 1
'Resize
        With objComment.Shape
            .LockAspectRatio = msoFalse
            .TextFrame.AutoSize = False
        ScaleValue2 = .Height / .Width
        Debug.Print cmtc; c1; SV2(cmtc); ScaleValue2; AktiveTabelle(c1)
        If ScaleValue2 <> SV2(cmtc) Then
        .Width = 150
        .Height = .Width * SV2(cmtc)
            .LockAspectRatio = msoTrue
        Debug.Print cmtc; c1; SV2(cmtc); ScaleValue2; .Width; .Height
        End If
        End With
        Debug.Print cmtc; c1; SV2(cmtc); ScaleValue2; objComment.Shape.Width; objComment.Shape.Height
Next objComment
Case 3
For Each objComment In Worksheets(AktiveTabelle(c1)).Comments
cmtc = cmtc + 1
'Resize
        With objComment.Shape
            .LockAspectRatio = msoFalse
            .TextFrame.AutoSize = False
        ScaleValue2 = .Height / .Width
        Debug.Print cmtc; c1; SV3(cmtc); ScaleValue2; AktiveTabelle(c1)
        If ScaleValue2 <> SV3(cmtc) Then
        .Width = 150
        .Height = .Width * SV3(cmtc)
            .LockAspectRatio = msoTrue
        Debug.Print cmtc; c1; SV3(cmtc); ScaleValue2; .Width; .Height
        End If
        End With
        Debug.Print cmtc; c1; SV3(cmtc); ScaleValue2; objComment.Shape.Width; objComment.Shape.Height
Next objComment
Case 4
For Each objComment In Worksheets(AktiveTabelle(c1)).Comments
cmtc = cmtc + 1
'Resize
        With objComment.Shape
            .LockAspectRatio = msoFalse
            .TextFrame.AutoSize = False
        ScaleValue2 = .Height / .Width
        Debug.Print cmtc; c1; SV4(cmtc); ScaleValue2; AktiveTabelle(c1)
        If ScaleValue2 <> SV4(cmtc) Then
        .Width = 150
        .Height = .Width * SV4(cmtc)
            .LockAspectRatio = msoTrue
        Debug.Print cmtc; c1; SV4(cmtc); ScaleValue2; .Width; .Height
        End If
        End With
        Debug.Print cmtc; c1; SV4(cmtc); ScaleValue2; objComment.Shape.Width; objComment.Shape.Height
Next objComment
Case 5
For Each objComment In Worksheets(AktiveTabelle(c1)).Comments
cmtc = cmtc + 1
'Resize
        With objComment.Shape
            .LockAspectRatio = msoFalse
            .TextFrame.AutoSize = False
        ScaleValue2 = .Height / .Width
        Debug.Print cmtc; c1; SV5(cmtc); ScaleValue2; AktiveTabelle(c1)
        If ScaleValue2 <> SV5(cmtc) Then
        .Width = 150
        .Height = .Width * SV5(cmtc)
            .LockAspectRatio = msoTrue
        Debug.Print cmtc; c1; SV5(cmtc); ScaleValue2; .Width; .Height
        End If
        End With
        Debug.Print cmtc; c1; SV5(cmtc); ScaleValue2; objComment.Shape.Width; objComment.Shape.Height
Next objComment
Case Else
End Select
DoEvents
Next c1
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
For c1 = 1 To c3
Select Case c1
Case 1
For j = 1 To cmtamount(c1)
Debug.Print j; SV1(j); c1; AktiveTabelle(c1); cmtamount(c1); ActiveSheet.Comments.Count; ActiveSheet.Name
Next
Case 2
For j = 1 To cmtamount(c1)
Debug.Print j; SV2(j); c1; AktiveTabelle(c1); cmtamount(c1); ActiveSheet.Comments.Count; ActiveSheet.Name
Next
Case 3
For j = 1 To cmtamount(c1)
Debug.Print j; SV3(j); c1; AktiveTabelle(c1); cmtamount(c1); ActiveSheet.Comments.Count; ActiveSheet.Name
Next
Case 4
For j = 1 To cmtamount(c1)
Debug.Print j; SV4(j); c1; AktiveTabelle(c1); cmtamount(c1); ActiveSheet.Comments.Count; ActiveSheet.Name
Next
Case 5
For j = 1 To cmtamount(c1)
Debug.Print j; SV5(j); c1; AktiveTabelle(c1); cmtamount(c1); ActiveSheet.Comments.Count; ActiveSheet.Name
Next
Case Else
End Select
Next
c1 = c1 - 1
End Sub

Code:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim objComment As Comment
Dim ScaleValue2 As Double
c4 = c2
cmtc = 0
    If ActiveSheet.Comments.Count = 0 Then
     MsgBox "No comments in entire sheet"
    End If
For c2 = 1 To c4
cmtc = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Select Case c2
Case 1
For Each objComment In Worksheets(AktiveTabelle(c2)).Comments
cmtc = cmtc + 1
'Resize
        With objComment.Shape
            .LockAspectRatio = msoFalse
            .TextFrame.AutoSize = False
        ScaleValue2 = .Height / .Width
        Debug.Print cmtc; c2; SV1(cmtc); ScaleValue2; AktiveTabelle(c2)
        If ScaleValue2 <> SV1(cmtc) Then
        .Width = 150
        .Height = .Width * SV1(cmtc)
            .LockAspectRatio = msoTrue
        Debug.Print cmtc; c2; SV1(cmtc); ScaleValue2; .Width; .Height
        End If
        End With
        Debug.Print cmtc; c2; SV1(cmtc); ScaleValue2; objComment.Shape.Width; objComment.Shape.Height
Next objComment
Case 2
For Each objComment In Worksheets(AktiveTabelle(c2)).Comments
cmtc = cmtc + 1
'Resize
        With objComment.Shape
            .LockAspectRatio = msoFalse
            .TextFrame.AutoSize = False
        ScaleValue2 = .Height / .Width
        Debug.Print cmtc; c2; SV2(cmtc); ScaleValue2; AktiveTabelle(c2)
        If ScaleValue2 <> SV2(cmtc) Then
        .Width = 150
        .Height = .Width * SV2(cmtc)
            .LockAspectRatio = msoTrue
        Debug.Print cmtc; c2; SV2(cmtc); ScaleValue2; .Width; .Height
        End If
        End With
        Debug.Print cmtc; c2; SV2(cmtc); ScaleValue2; objComment.Shape.Width; objComment.Shape.Height
Next objComment
Case 3
For Each objComment In Worksheets(AktiveTabelle(c2)).Comments
cmtc = cmtc + 1
'Resize
        With objComment.Shape
            .LockAspectRatio = msoFalse
            .TextFrame.AutoSize = False
        ScaleValue2 = .Height / .Width
        Debug.Print cmtc; c2; SV3(cmtc); ScaleValue2; AktiveTabelle(c2)
        If ScaleValue2 <> SV3(cmtc) Then
        .Width = 150
        .Height = .Width * SV3(cmtc)
            .LockAspectRatio = msoTrue
        Debug.Print cmtc; c2; SV3(cmtc); ScaleValue2; .Width; .Height
        End If
        End With
        Debug.Print cmtc; c2; SV3(cmtc); ScaleValue2; objComment.Shape.Width; objComment.Shape.Height
Next objComment
Case 4
For Each objComment In Worksheets(AktiveTabelle(c2)).Comments
cmtc = cmtc + 1
'Resize
        With objComment.Shape
            .LockAspectRatio = msoFalse
            .TextFrame.AutoSize = False
        ScaleValue2 = .Height / .Width
        Debug.Print cmtc; c2; SV4(cmtc); ScaleValue2; AktiveTabelle(c2)
        If ScaleValue2 <> SV4(cmtc) Then
        .Width = 150
        .Height = .Width * SV4(cmtc)
            .LockAspectRatio = msoTrue
        Debug.Print cmtc; c2; SV4(cmtc); ScaleValue2; .Width; .Height
        End If
        End With
        Debug.Print cmtc; c2; SV4(cmtc); ScaleValue2; objComment.Shape.Width; objComment.Shape.Height
Next objComment
Case 5
For Each objComment In Worksheets(AktiveTabelle(c2)).Comments
cmtc = cmtc + 1
'Resize
        With objComment.Shape
            .LockAspectRatio = msoFalse
            .TextFrame.AutoSize = False
        ScaleValue2 = .Height / .Width
        Debug.Print cmtc; c2; SV5(cmtc); ScaleValue2; AktiveTabelle(c2)
        If ScaleValue2 <> SV5(cmtc) Then
        .Width = 150
        .Height = .Width * SV5(cmtc)
            .LockAspectRatio = msoTrue
        Debug.Print cmtc; c2; SV5(cmtc); ScaleValue2; .Width; .Height
        End If
        End With
        Debug.Print cmtc; c2; SV5(cmtc); ScaleValue2; objComment.Shape.Width; objComment.Shape.Height
Next objComment
Case Else
End Select
DoEvents
Next c2
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
For c2 = 1 To c4
Select Case c2
Case 1
For j = 1 To cmtamount(c2)
Debug.Print j; SV1(j); c2; AktiveTabelle(c2); cmtamount(c2); ActiveSheet.Comments.Count; ActiveSheet.Name
Next
Case 2
For j = 1 To cmtamount(c2)
Debug.Print j; SV2(j); c2; AktiveTabelle(c2); cmtamount(c2); ActiveSheet.Comments.Count; ActiveSheet.Name
Next
Case 3
For j = 1 To cmtamount(c2)
Debug.Print j; SV3(j); c2; AktiveTabelle(c2); cmtamount(c2); ActiveSheet.Comments.Count; ActiveSheet.Name
Next
Case 4
For j = 1 To cmtamount(c2)
Debug.Print j; SV4(j); c2; AktiveTabelle(c2); cmtamount(c2); ActiveSheet.Comments.Count; ActiveSheet.Name
Next
Case 5
For j = 1 To cmtamount(c2)
Debug.Print j; SV5(j); c2; AktiveTabelle(c2); cmtamount(c2); ActiveSheet.Comments.Count; ActiveSheet.Name
Next
Case Else
End Select
Next
c2 = c2 - 1
End Sub

Code:

Private Sub Workbook_Open()
Dim objComment As Comment
    If ActiveSheet.Comments.Count = 0 Then
     MsgBox "No comments in entire sheet"
     Exit Sub
    End If
i = 0
c1 = 0
c1 = c1 + 1
c2 = 0
c2 = c2 + 1
ReDim Preserve SV1(1 To ActiveSheet.Comments.Count)
cmtamount(1) = ActiveSheet.Comments.Count
AktiveTabelle(c1) = ActiveSheet.Name
AktiveTabelle(c2) = ActiveSheet.Name
For Each objComment In ActiveSheet.Comments
i = i + 1
With objComment.Shape
SV1(i) = .Height / .Width
End With
Debug.Print i; SV1(i); c1; AktiveTabelle(c1); cmtamount(c1); ActiveSheet.Comments.Count; ActiveSheet.Name
Next
End Sub

Code:

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim objComment As Comment
        If ActiveSheet.Comments.Count = 0 Then
         c5 = 1
         AktiveTabelle2(c5) = ActiveSheet.Name
         Debug.Print AktiveTabelle2(c5)
     MsgBox "No comments in entire sheet"
     Exit Sub
    End If
i = 0
c1 = c1 + 1
c2 = c2 + 1
AktiveTabelle(c1) = ActiveSheet.Name
AktiveTabelle(c2) = ActiveSheet.Name
If c5 = 1 Then
If c1 = 2 Then
If AktiveTabelle(c1) = AktiveTabelle(c1 - 1) Then
c5 = 0
c1 = c1 - 1
c2 = c2 - 1
Exit Sub
End If
End If
If c1 = 3 Then
If AktiveTabelle(c1) = AktiveTabelle(c1 - 1) Then
c5 = 0
c1 = c1 - 1
c2 = c2 - 1
Exit Sub
End If
End If
If c1 = 4 Then
If AktiveTabelle(c1) = AktiveTabelle(c1 - 1) Then
c5 = 0
c1 = c1 - 1
c2 = c2 - 1
Exit Sub
End If
End If
If c1 = 5 Then
If AktiveTabelle(c1) = AktiveTabelle(c1 - 1) Then
c5 = 0
c1 = c1 - 1
c2 = c2 - 1
Exit Sub
End If
End If
End If
If c1 > 2 Then
'On Error Resume Next
If AktiveTabelle(c1) = AktiveTabelle(c1 - 1) Then
c1 = c1 - 1
c2 = c2 - 1
GoTo LabelEnd
ElseIf AktiveTabelle(c1) = AktiveTabelle(c1 - 2) Then
c1 = c1 - 1
c2 = c2 - 1
GoTo LabelEnd
End If
End If
If c1 > 3 Then
If AktiveTabelle(c1) = AktiveTabelle(c1 - 3) Then
c1 = c1 - 1
c2 = c2 - 1
GoTo LabelEnd
End If
End If
If c1 > 4 Then
If AktiveTabelle(c1) = AktiveTabelle(c1 - 4) Then
c1 = c1 - 1
c2 = c2 - 1
GoTo LabelEnd
End If
End If
If c1 = 5 Then
If AktiveTabelle(c1) = AktiveTabelle(c1 - 4) Then
c1 = c1 - 1
c2 = c2 - 1
GoTo LabelEnd
End If
End If
On Error GoTo 0
If c1 = 1 Then
ReDim Preserve SV1(1 To ActiveSheet.Comments.Count)
cmtamount(1) = ActiveSheet.Comments.Count
For Each objComment In ActiveSheet.Comments
i = i + 1
With objComment.Shape
SV1(i) = .Height / .Width
End With
Debug.Print i; SV1(i); c1; AktiveTabelle(c1); cmtamount(c1); ActiveSheet.Comments.Count; ActiveSheet.Name
Next
ElseIf c1 = 2 Then
ReDim Preserve SV2(1 To ActiveSheet.Comments.Count)
cmtamount(2) = ActiveSheet.Comments.Count
For Each objComment In ActiveSheet.Comments
i = i + 1
With objComment.Shape
SV2(i) = .Height / .Width
End With
Debug.Print i; SV2(i); c1; AktiveTabelle(c1); cmtamount(c1); ActiveSheet.Comments.Count; ActiveSheet.Name
Next
ElseIf c1 = 3 Then
ReDim Preserve SV3(1 To ActiveSheet.Comments.Count)
cmtamount(3) = ActiveSheet.Comments.Count
AktiveTabelle(c1) = ActiveSheet.Name
AktiveTabelle(c2) = ActiveSheet.Name
For Each objComment In ActiveSheet.Comments
i = i + 1
With objComment.Shape
SV3(i) = .Height / .Width
End With
Debug.Print i; SV3(i); c1; AktiveTabelle(c1); cmtamount(c1); ActiveSheet.Comments.Count; ActiveSheet.Name
Next
ElseIf c1 = 4 Then
ReDim Preserve SV4(1 To ActiveSheet.Comments.Count)
cmtamount(4) = ActiveSheet.Comments.Count
AktiveTabelle(c1) = ActiveSheet.Name
AktiveTabelle(c2) = ActiveSheet.Name
For Each objComment In ActiveSheet.Comments
i = i + 1
With objComment.Shape
SV4(i) = .Height / .Width
End With
Debug.Print i; SV4(i); c1; AktiveTabelle(c1); cmtamount(c1); ActiveSheet.Comments.Count; ActiveSheet.Name
Next
ElseIf c1 = 5 Then
ReDim Preserve SV5(1 To ActiveSheet.Comments.Count)
cmtamount(5) = ActiveSheet.Comments.Count
AktiveTabelle(c1) = ActiveSheet.Name
AktiveTabelle(c2) = ActiveSheet.Name
For Each objComment In ActiveSheet.Comments
i = i + 1
With objComment.Shape
SV5(i) = .Height / .Width
End With
Debug.Print i; SV5(i); c1; AktiveTabelle(c1); cmtamount(c1); ActiveSheet.Comments.Count; ActiveSheet.Name
Next
LabelEnd:
On Error GoTo 0
End If
End Sub

Ins Modul1 gehört zum Durcheinanderbringen aller Kommentare folgendes Schnipsel:

Code:

Option Explicit
Private Sub comments_mathematical_exact_arrangement()
    Dim objComment As Comment
    Dim i As Long
    Dim j As Double
    Dim z As Double
    i = 0
        If ActiveSheet.Comments.Count = 0 Then
         MsgBox "No comments in entire sheet"
         Exit Sub
        End If
        ' Alle Kommentare des aktuellen Arbeitsblatts durchlaufen
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
        For Each objComment In ActiveSheet.Comments
                i = i + 1
                z = Rnd
                If z <= 0.1 Then
                    j = i * z ^ 1
                    ElseIf z <= 0.2 Then j = i * z ^ 2
                    ElseIf z <= 0.3 Then j = i * z ^ 3
                    ElseIf z <= 0.4 Then j = i * z ^ 4
                    ElseIf z <= 0.5 Then j = i * z ^ 5
                    ElseIf z <= 0.6 Then j = i * z ^ 6
                    ElseIf z <= 0.7 Then j = i * z ^ 7
                    ElseIf z <= 0.8 Then j = i * z ^ 8
                    ElseIf z <= 0.9 Then j = i * z ^ 9
                    ElseIf z <= 1 Then j = i * z ^ 10
                End If
            With objComment
           
                .Shape.TextFrame.AutoSize = True
           
                If j <= 10 Then
                    .Shape.Top = .Parent.Top + (.Parent.Height * (j / 10))
                    .Shape.Left = .Parent.Left + (.Parent.Width * (j / 10))
                ElseIf j <= 100 Then
                    .Shape.Top = .Parent.Top + (.Parent.Height * (j / 10))
                    .Shape.Left = .Parent.Left + (.Parent.Width * (j / 100))
                 ElseIf j <= 1000 Then
                    .Shape.Top = .Parent.Top + (.Parent.Height * (j / 10))
                    .Shape.Left = .Parent.Left + (.Parent.Width * (j / 1000))
                ElseIf j <= 10000 Then
                    .Shape.Top = .Parent.Top + (.Parent.Height * (j / 100))
                    .Shape.Left = .Parent.Left + (.Parent.Width * (j / 100))
                End If
            End With
        Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
    On Error GoTo 0
End Sub

  comments with pictures (max 5 Tabellen).xlsm (Größe: 1,5 MB / Downloads: 0)

[RPP63]

Bist Du nicht derjenige, der in älteren Threads als Besserwisser auftrat und auf berechtigte Kritik irgendwelche klugen Links eingestellt hat?
Lebe mit den inakzeptablen Mankos oder höre schlicht auf die Ratschläge, die Dir mehrfach gegeben wurden!

Für so etwas ist Excel schlicht nicht geeignet, dafür gibt es Datenbanken.

Aber ich ahne bereits, was als Antwort kommt.

Nur vorsorglich:
Ich werde hier nicht länger mitdiskutieren.

[schauan]

Hallo Ralf,

es wurde doch gar keine Frage gestellt oder hab ich was übersehen ?

[RPP63]

Dann warte mal den bald folgenden fünften Monolog ab, André!

[TxbyFmjy]

Dann warte mal den bald folgenden fünften Monolog ab, André!

Hast du das schon einmal ausprobiert?

Es wurde doch gar keine Frage gestellt oder hab ich was übersehen ?

[TxbyFmjy]

Bist Du nicht derjenige, der in älteren Threads als Besserwisser auftrat und auf berechtigte Kritik irgendwelche klugen Links eingestellt hat?
Lebe mit den inakzeptablen Mankos oder höre schlicht auf die Ratschläge, die Dir mehrfach gegeben wurden!

Nein, ich bin derjenige, der irreführende Tipps erhalten hat.

Zusammenfassung irreführender Tipps

Eine funktionierende Lösung ist allemal besser als irreführende Tipps und heiße Luft.

In der Arbeitsmappe comments with pictures (max 5 Tabellen).xlsm haben vier Tabellen 1243 Kommentare, die im Test in allen vier Tabellen geändert wurden. Das ist im Alltag ein eher unwahrschienliches Szenario. Im Alltag ist es wahrscheinlich, dass, wenn eine solche Arbeitsmappe geöffnet wird, in einer, vielleicht zwei Tabellen ein paar Kommentare verändert werden. Im Alltag werden die Makros auch die diversen debug.print, die für die Entwicklung erforderlich waren, nicht enthalten. Das verringert die Mankos auf alle Fälle.

Nur vorsorglich:
Ich werde hier nicht länger mitdiskutieren.

Herzlichen Dank, dass ich mich nicht mit deinen irreführenden Tipps und deiner heißen Luft beschäftigen muss. Welchen Nährwert sollte es haben, wenn jemand, der die fertige Lösung nicht einmal heruntergeladen und ausprobiert hat, mitdiskutieren würde?