Excel Bug mit ungroup
10.11.2003 13:03:02
Roger
ich hatte hier schon mal gepostet, dass Diagramme Nach einer Gruppierung defekt sind bzw nach dem ungruppieren die ganze Mappe defekt ist. Ich habe nun mal dieses feature in kurzen Code zusammengefasst. Nehme ich 2 Textboxen und gruppiere und ungruppiere sie 4096 mal, ist die Mappe defekt. Speichere ich sie nun, kommt die Meldung "Kann Datei nicht lesen". So meine lieben MVPs, Excel ist schon toll, aber dieses Feature ist nicht schön. Gibt es eine Excel Version, mit der das Funktioniert? Packt den Code in ein Modul und öffnet eine leere Mappe. Aktiviert die leere Mappe und startet "StarteTest". Nach der Aktion öffnet mal die erzeugten Mappen, oder versucht es wenigstens. Der Code:
Option Explicit
Private Const NameGruppe As String = "Diag"
Private Const Box1 As String = "Box1"
Private Const Box2 As String = "Box2"
Private Function AddTextbox(strPriName As String) As Shape
Dim RetValue As Shape
Set RetValue = ActiveWorkbook.Sheets(1).Shapes.AddTextbox(1, 10, 20, 50, 10)
With RetValue
.Name = strPriName
.TextFrame.Characters.Text = strPriName
End With
Set AddTextbox = RetValue
Set RetValue = Nothing
End Function
Public Sub StarteTest()
Dim objBox1 As Shape
Dim objBox2 As Shape
Dim i As Integer
Set objBox1 = AddTextbox(Box1)
Set objBox2 = AddTextbox(Box2)
objBox2.Top = 30
GruppiereDiagrammElemente
For i = 1 To 4100
If i >= 4095 And i <= 4098 Then
' Bitte einen beliebigen Pfad eingeben, der auch vorhanden ist
ActiveWorkbook.SaveCopyAs ("C:\A" & i & ".xls")
End If
UnGruppiereDiagrammElemente
GruppiereDiagrammElemente
Next
Set objBox1 = Nothing
Set objBox2 = Nothing
End Sub
Private Sub GruppiereDiagrammElemente()
Dim objShape As Shape
On Error Resume Next
Set objShape = ActiveWorkbook.Sheets(1).Shapes(NameGruppe)
If objShape Is Nothing Then
ActiveWorkbook.Sheets(1).Shapes.Range(Array(Box1, Box2)).Group.Name = NameGruppe
Set objShape = ActiveWorkbook.Sheets(1).Shapes(NameGruppe)
End If
If Not (objShape Is Nothing) Then
objShape.Placement = xlFreeFloating
objShape.ZOrder msoBringToFront
objShape.Select
End If
Set objShape = Nothing
End Sub
Private Sub UnGruppiereDiagrammElemente()
Dim ShapeObj As Shape
On Error Resume Next
Set ShapeObj = ActiveWorkbook.Sheets(1).Shapes(NameGruppe)
If Not (ShapeObj Is Nothing) Then
If ActiveWorkbook.Sheets(1).ProtectDrawingObjects Then
Call ActiveWorkbook.Sheets(1).Unprotect
End If
ShapeObj.Ungroup
End If
Set ShapeObj = Nothing
End Sub