Excel 2010 Kommentar mit Bild - Seitenverhältnis Sperren

apple987123 · 22. Dezember 2011, 11:38

Hallo Leute
Ich habe ein kleines Problem, und zwar habe ich ein ein Excel-Sheet mit mehreren 1000 Kommentaren (zu viele um alles von Hand zu machen.) Nun haben alle Kommentare ein Bild als Hintergrund, aber das Seitenverhältniss sollte gesperrt sein. (Das wäre, wenn man es von Hand macht die Checkbox unter: Kommentar Formatieren -> Farben und Linien -> Das Farb Dropdown -> Fülleffekte -> Grafik -> Seitenverhältnis sperren.

Kann ich diese Checkbox irgendwie per VBA parameter setzten? Der Makro-Recorder hat mir leider auch nicht geholfen.

Vielen Dank für Hilfe
Apple987123

stefanhanz · 4. Juli 2016, 12:34

Guten Tag,

ich stehe vor dem gleichen Problem wie apple987123 vor 5 Jahren. Ich suche genau wie er VBA Parameter, mit denen ich die Wege automatisieren kann, da es sehr viele Kommentarfelder sind. Es wäre super, wenn da jemand helfen könnte!

Ansonsten: Ich arbeite an einer Excel-Tabelle, die Prüfgeräte auflistet. Dabei soll man ohne externe Fenster ein Bild des jeweiligen Gerätes sehen können. Bisher ist mir nur die Funktion mit dem Kommentarfeld und anschließender Hinterlegung des Hintergrundes mit einem Bild bekannt.

Wenn jemand eine andere/bessere Lösung kennt, mit der ich eine Miniatur-Vorschau eines Bildes in Excel anzeigen kann, wäre ich auch sehr dankbar! Denn wirklich sauber ist diese Lösung auch nicht gerade.

Danke für eure Hilfe,

Stefan

stefanhanz · 6. Juli 2016, 19:14

Hat keiner eine Idee?

Marcus Gräfe · 6. Juli 2016, 19:39

Ich habe auf die Schnelle das hier gefunden, hilft das evtl. weiter? mrexcel.com/forum/excel-questi…atio-comment-picture.html

Zoe4711 · 25. August 2021, 18:44

Wenn ein Makro aufgezeichnet wird, aber bestimmte Abläufe sich im Makro nicht wiederfinden, dann bedeutet das schlicht und ergreifend, dass es dafür keine VBA-Unterstützung gibt.

"Jay Freedman" schrieb:

office-forums.com/threads/lock…tio.1779129/#post-5533033

Unfortunately, you're correct. There are far too many cases of controls in
built-in dialogs that have no support in VBA. In each release the MVPs have
asked again to have this fixed, but so far without success.

(....)

--
Regards,
Jay Freedman
Microsoft Word MVP
Email cannot be acknowledged; please post all follow-ups to the newsgroup so all may benefit.

INOPIAE · 26. August 2021, 16:14

Zoe4711 schrieb:

Wenn ein Makro aufgezeichnet wird, aber bestimmte Abläufe sich im Makro nicht wiederfinden, dann bedeutet das schlicht und ergreifend, dass es dafür keine VBA-Unterstützung gibt.

Wer hat dich denn zu dieser Aussage bewegt?
Der Makrorecorder kommt nicht an alle Dinge dran, vieles kann man aber doch verändern.

Zoe4711 · 27. August 2021, 17:54

apple987123 schrieb:

Hallo Leute
Ich habe ein kleines Problem, und zwar habe ich ein ein Excel-Sheet mit mehreren 1000 Kommentaren (zu viele um alles von Hand zu machen.) Nun haben alle Kommentare ein Bild als Hintergrund, aber das Seitenverhältniss sollte gesperrt sein. (Das wäre, wenn man es von Hand macht die Checkbox unter: Kommentar Formatieren -> Farben und Linien -> Das Farb Dropdown -> Fülleffekte -> Grafik -> Seitenverhältnis sperren. vb-paradise.de/index.php/Attachment/13092/
Kann ich diese Checkbox irgendwie per VBA parameter setzten? Der Makro-Recorder hat mir leider auch nicht geholfen.

Vielen Dank für Hilfe
Apple987123

Wird ein Bild in ein Kommentar eingefügt, dann nimmt das Bild die Größe des Kommentars an. Danach ist das Bild bereits verzerrt.

Soll die Verzerrung des Bildes verhindert werden, ist folgende Vorgehensweise notwendig:

- Nach Auswahl des Bildes muss das Seitenverhältnis des Bildes berechnet werden
- Mit dem Seitenverhältnis des Bildes muss das Kommentar so verändert werden, dass seine Form das Seitenverhältnis des Bildes annimmt
- Wird das Bild in das Kommentar eingefügt - das das Seitenverhältnis des Bildes hat - wird das Bild nicht verzerrt
- Erst jetzt muss das Seitenverhältnis des Kommentars gesperrt werden.

Es ist nicht möglich das Seitenverhältnis des Bildes per VBA zu sperren, das in ein Kommentar eingefügt wird. Der Makrorecorder zeichnet das Setzen des Häkchens bei "Bildseitenverhältnis sperren" nicht auf.

Visual Basic-Quellcode

Sub insert_userpicture_in_comments()
'** Dimensionierung der Variablen
Dim rngZelle As Range
Dim strFilename As Variant
Dim strFilter As String
Dim ScaleValue As Single
Dim ScaleValue2 As Single
Dim objPic As IPictureDisp
Dim Source As String
Dim i As Integer
If ActiveSheet.Comments.Count = 0 Then
MsgBox "No comments in entire sheet"
Exit Sub
End If
'Dateiauswahl filtern
strFilter = "JPG Files (*.jpg), *.jpg" _
& ", GIF Files (*.gif), *.gif" _
& ", Bitmaps (*.bmp), *.bmp" _
& ", WMF Files (*.wmf), *.wmf"
' Dialogfenster zur Auswahl eines Bildes öffnen
strFilename = Application.GetOpenFilename(strFilter)
DoEvents
' Wenn kein Bild ausgewählt wurde, Prozedur beenden
If strFilename = False Then GoTo LabelA
Source = (CStr(strFilename))
DoEvents
' Set objPic = LoadPicture(Bild)
Set objPic = LoadPicture(Source)
DoEvents
With objPic
ScaleValue = .Width / .Height
End With
If MsgBox(ScaleValue, vbOKCancel) = vbCancel Then GoTo LabelA
Application.CutCopyMode = False
DoEvents
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'** Alle markierten rngZellen durchlaufen
For Each rngZelle In Selection.Cells
With rngZelle
If Not .Comment Is Nothing Then
'Insert The Image and Resize
With .Comment.Shape
.LockAspectRatio = msoFalse
.Width = 150
' .Width = ScaleValue * .Height
.Height = .Width / ScaleValue
.Fill.UserPicture strFilename
DoEvents
.LockAspectRatio = msoTrue
ScaleValue2 = .Width / .Height
i = i + 1
Debug.Print i; rngZelle.Address; ScaleValue; ScaleValue2
End With
End If
End With
Next rngZelle
LabelA:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
On Error GoTo 0
End Sub

Edit:

Achtung: Eine "lustige" Sache mit .LockAspectRatio = msoTrue ist die folgende:

Die Standardform eines Kommentars ist ein Rechteck. In jeder Ecke und in der Mitte jeder Seite ist ein kleiner Kreis zu sehen, an dem gezogen, sich die Form des Rechtecks verändern lässt.

Wenn .LockAspectRatio = msoTrue benutzt wird, ist das Seitenverhältnis nur gesperrt, wenn die Form des Kommentars an den Ecken gezogen wird.

Das Seitenverhältnis lässt sich jedoch ganz einfach zerstören, wenn die Form des Kommentars nach links/rechts oder oben/unten gezogen wird.

Jeder, der die Arbeitsmappe zusammen mit anderen benutzt, kann das Seitenverhältnis für die Hintergrundbilder beim Bearbeiten von Kommentaren ganz einfach zerstören. Wenn die Tabellen in der Arbeitsmappe eine große Anzahl von Kommentaren enthalten, ist es von Hand nicht mehr leistbar verzerrte Seitenverhältnisse zu korrigieren.

Da ist guter Rat teuer.

Zoe4711 · 12. September 2021, 10:57

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

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

Diese Lösung setzt voraus, dass die Seitenverhälltnisse aller Kommentare in einer Tabelle identisch sind, z. Bsp.: Vereinslogo wurde als Hintergrundbild eingefügt.

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 inakzeptabel lange dauert.

Visual Basic-Quellcode

Option Explicit
Dim ScaleValue1(1 To 100) As Double
Dim AktiveTabelle(1 To 100) As String
Dim c As Integer
Dim cmtc As Long
Dim u As Integer
Dim v As Integer
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim objComment As Comment
Dim ScaleValue2 As Double
cmtc = 0
u = 0
v = 0
For u = 1 To 100 '** bei wiederholtem sofortigen Wechsel zur selben Tabelle (mit nur einer anderen Tabelle dazwischen), _
wird die Tabelle nur einmal berücksichtigt, die anderen Kommentar-Seitenverhältnisse derselben Tabelle werden zu Null gesetzt _
und an Hand dessen übersprungen; so werden Mehrfach-Berechnungen vermieden.
For v = (u + 2) To 100
If AktiveTabelle(u) = AktiveTabelle(v) Then
ScaleValue1(v) = 0
End If
Next v
Next u
For c = 1 To c
If AktiveTabelle(c) = "" Then
GoTo LabelSkip2
ElseIf ScaleValue1(c) = 0 Then '** Tabellen deren Kommentar-Seitenverhältnis zu Null gesetzt wurde, werden übersprungen
GoTo LabelSkip1
End If
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each objComment In Worksheets(AktiveTabelle(c)).Comments
cmtc = cmtc + 1
'Resize
With objComment.Shape
.LockAspectRatio = msoFalse
.TextFrame.AutoSize = False
ScaleValue2 = .Height / .Width
Debug.Print cmtc; c; ScaleValue1(c); ScaleValue2; AktiveTabelle(c)
If ScaleValue2 <> ScaleValue1(c) Then
.Width = 150
.Height = .Width * ScaleValue1(c)
.LockAspectRatio = msoTrue
Debug.Print cmtc; c; ScaleValue1(c); ScaleValue2; .Width; .Height
End If
End With
Debug.Print cmtc; c; ScaleValue1(c); ScaleValue2; objComment.Shape.Width; objComment.Shape.Height
Next objComment
LabelSkip1:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
DoEvents
Next c
LabelSkip2:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
For c = 1 To c
Debug.Print c; ScaleValue1(c); AktiveTabelle(c)
Next
End Sub

Visual Basic-Quellcode

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim objComment As Comment
Dim ScaleValue2 As Double
cmtc = 0
u = 0
v = 0
For u = 1 To 100
For v = (u + 2) To 100
If AktiveTabelle(u) = AktiveTabelle(v) Then
ScaleValue1(v) = 0
End If
Next v
Next u
For c = 1 To c
If AktiveTabelle(c) = "" Then
GoTo LabelSkip2
ElseIf ScaleValue1(c) = 0 Then
GoTo LabelSkip1
End If
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each objComment In Worksheets(AktiveTabelle(c)).Comments
cmtc = cmtc + 1
'Resize
With objComment.Shape
.LockAspectRatio = msoFalse
.TextFrame.AutoSize = False
ScaleValue2 = .Height / .Width
Debug.Print cmtc; c; ScaleValue1(c); ScaleValue2; AktiveTabelle(c)
If ScaleValue2 <> ScaleValue1(c) Then
.Width = 150
.Height = .Width * ScaleValue1(c)
.LockAspectRatio = msoTrue
Debug.Print cmtc; c; ScaleValue1(c); ScaleValue2; .Width; .Height
End If
End With
Debug.Print cmtc; c; ScaleValue1(c); ScaleValue2; objComment.Shape.Width; objComment.Shape.Height
Next objComment
LabelSkip1:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
DoEvents
Next c
LabelSkip2:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
For c = 1 To c
Debug.Print c; ScaleValue1(c); AktiveTabelle(c)
Next
End Sub

Visual Basic-Quellcode

Private Sub Workbook_Open()
Dim objComment As Comment
Dim i As Integer
Dim SV As Double
i = 0
c = 0
c = c + 1
For Each objComment In ActiveSheet.Comments
i = i + 1
With objComment.Shape
SV = .Height / .Width
End With
If i = 1 Then GoTo LabelFinish
Next
LabelFinish:
ScaleValue1(c) = SV
AktiveTabelle(c) = ActiveSheet.Name
Debug.Print c; SV; ScaleValue1(c); AktiveTabelle(c)
End Sub

Visual Basic-Quellcode

Private Sub Workbook_SheetActivate(ByVal Sh As Object) '** Seitenverhältnis beim Tabellenwechsel wird ermittelt
Dim objComment As Comment
Dim i As Integer
Dim SV As Double
i = 0
c = c + 1
For Each objComment In ActiveSheet.Comments
i = i + 1
With objComment.Shape
SV = .Height / .Width
End With
If i = 1 Then GoTo LabelFinish
Next
LabelFinish:
ScaleValue1(c) = SV
AktiveTabelle(c) = ActiveSheet.Name
Debug.Print c; SV; ScaleValue1(c); AktiveTabelle(c)
End Sub

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

Visual Basic-Quellcode

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

comment size change revert back picture (1).xlsx als comment size change revert back picture (1).xlsm speichern, Schnipsel einfügen und ausprobieren.

Zoe4711 · 15. September 2021, 19:24

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.

Visual Basic-Quellcode

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

Visual Basic-Quellcode

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

Visual Basic-Quellcode

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

Visual Basic-Quellcode

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:

Visual Basic-Quellcode

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).xlsx als comments with pictures (max 5 Tabellen).xlsm speichern, Schnipsel einfügen und ausprobieren.

Excel 2010 Kommentar mit Bild - Seitenverhältnis Sperren

Excel 2010 Kommentar mit Bild - Seitenverhältnis Sperren

"Jay Freedman" schrieb:

Zoe4711 schrieb:

Eine "lustige" Sache mit .LockAspectRatio = msoTrue

apple987123 schrieb:

Visual Basic-Quellcode

Seitenverhältnis der Kommentare bewahren

Visual Basic-Quellcode

Visual Basic-Quellcode

Visual Basic-Quellcode

Visual Basic-Quellcode

Visual Basic-Quellcode

Arbeitsmappe mit max. 5 Tabellen, Kommentare mit unterschiedlichen Seitenverhältnissen, Seitenverhältnis der Kommentare bewahren

Visual Basic-Quellcode

Visual Basic-Quellcode

Visual Basic-Quellcode

Visual Basic-Quellcode

Visual Basic-Quellcode

Benutzer online 1

Ähnliche Themen

5 Benutzer haben hier geschrieben