AW: Bilder gruppieren
14.08.2014 12:35:30
Mullit
Hallo Stefan,
konnte ja leider nicht so viel bewirken, aber die Shapes in Deiner Mappe scheinen leider die Bearbeitung zu beeinflussen.
XL 2010 stürzte mir mehrmals ab...
Aber ich hab' hier noch mal ein Ansatz angehängt,
um die Shapes dynamisch einzufügen, müsste aber noch weiterentwickelt werden...
Option Explicit
Private Declare Function SetTimer Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" ( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
Private Declare Sub mouse_event Lib "user32.dll" ( _
ByVal dwFlags As Long, _
ByVal dx As Long, _
ByVal dy As Long, _
ByVal cButtons As Long, _
ByVal dwExtraInfo As Long)
Private Declare Function GetAsyncKeyState Lib "user32.dll" ( _
ByVal vKey As Long) As Integer
Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
ByRef pArray() As Any) As Long
Private Const MOUSEEVENTF_LEFTDOWN As Long = &H2
Private Const MOUSEEVENTF_LEFTUP As Long = &H4
Private Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Private Const MOUSEEVENTF_RIGHTUP As Long = &H10
Private Const VK_LBUTTON As Long = &H1
Private lblnInArea As Boolean
Private lablnLBtnDown(1 To 2) As Boolean
Private lshpShape As Shape
Private lshpDuplicate As Shape
Private lcolShapes As Collection
Public Sub prcShapeControl()
Dim shpGroupItem As Shape
Dim blnExit As Boolean
ActiveSheet.Unprotect
Call prcProgSpeed(blnSpeed:=True)
Set lshpShape = ActiveSheet.Shapes(Application.Caller)
If Not fncBlnArea(prshpShape:=lshpShape) Then
Set lshpDuplicate = lshpShape.Duplicate
With lshpDuplicate
.Left = lshpShape.Left
.Top = lshpShape.Top
End With
Else
On Error Resume Next
For Each shpGroupItem In ActiveSheet.GroupObjects("NewGroup").ShapeRange.GroupItems
If Err Then
Err.Clear
blnExit = Not blnExit
End If
If Not blnExit Then
If shpGroupItem.Name = lshpShape.Name Then
lablnLBtnDown(1) = Not lablnLBtnDown(1)
lablnLBtnDown(2) = Not lablnLBtnDown(2)
Exit For
End If
End If
Next
On Error GoTo 0
If Not lablnLBtnDown(1) Then
If Not lblnInArea Then _
lblnInArea = Not lblnInArea
End If
End If
mouse_event MOUSEEVENTF_RIGHTDOWN, 0&, 0&, 0&, 0&
Call prcStartTimer
End Sub
Private Sub prcStartTimer()
SetTimer Application.hwnd, 0&, 10&, AddressOf TimerProc
End Sub
Private Sub prcStopTimer()
KillTimer Application.hwnd, 0&
End Sub
Private Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long)
Dim shpGroupItem As Shape
Dim blnNoDelete As Boolean
Dim blnExit As Boolean
If Not CBool(GetAsyncKeyState(VK_LBUTTON)) Then
Call prcStopTimer
mouse_event MOUSEEVENTF_RIGHTUP, 0&, 0&, 0&, 0&
If Not lablnLBtnDown(1) Then
With lshpShape
If fncBlnArea(prshpShape:=lshpShape) And Not lblnInArea Then
If Not CBool(ObjPtr(lcolShapes)) Then _
Set lcolShapes = New Collection
lshpDuplicate.Name = Replace(Expression:=lshpDuplicate.Name, _
Find:=Mid$(String:=lshpDuplicate.Name, _
Start:=InStr(1, lshpDuplicate.Name, "_", vbTextCompare)), _
Replace:="_" & (CLng(Mid$(String:=.Name, _
Start:=InStr(1, .Name, "_", vbTextCompare) + 1)) + 1), _
Compare:=vbTextCompare)
lcolShapes.Add lshpShape, .Name
ElseIf Not fncBlnArea(prshpShape:=lshpShape) And lblnInArea Then
lblnInArea = Not lblnInArea
.Delete
On Error Resume Next
lcolShapes.Remove .Name
On Error GoTo 0
ElseIf Not fncBlnArea(prshpShape:=lshpShape) And Not lblnInArea Then
On Error Resume Next
For Each shpGroupItem In ActiveSheet.GroupObjects("NewGroup").ShapeRange.GroupItems
If Err Then
Err.Clear
blnExit = Not blnExit
End If
If Not blnExit Then
If shpGroupItem.Name = lshpShape.Name Then
If Not blnNoDelete Then _
blnNoDelete = Not blnNoDelete
On Error Resume Next
lcolShapes.Remove .Name
On Error GoTo 0
End If
End If
Next
On Error GoTo 0
If Not blnNoDelete Then
.Delete
On Error Resume Next
lcolShapes.Remove .Name
On Error GoTo 0
End If
End If
End With
ElseIf lablnLBtnDown(2) Then
lablnLBtnDown(1) = Not lablnLBtnDown(1)
lablnLBtnDown(2) = Not lablnLBtnDown(2)
End If
Set lshpShape = Nothing
Set lshpDuplicate = Nothing
Call prcProtect
Call prcProgSpeed(blnSpeed:=False)
End If
End Sub
Private Function fncBlnArea(prshpShape As Shape) As Boolean
With prshpShape
fncBlnArea = .Top > ActiveSheet.Rows(1).Top And _
.Left > ActiveSheet.Columns(4).Left And _
.Left + .Width < ActiveSheet.Columns(13).Left + _
ActiveSheet.Columns(13).Width And _
.Top + .Height < ActiveSheet.Rows(22).Top + _
ActiveSheet.Rows(22).Height
End With
End Function
Public Sub prcZOrder()
Static sblnZOrderTop As Boolean
Static savntArray() As Variant
Dim ialngIndex As Long
Dim blnAddElem As Boolean
Dim shpShape As Shape
ActiveSheet.Unprotect
If CBool(SafeArrayGetDim(savntArray)) Then
If Ubound(savntArray) + 1 <= lcolShapes.Count Then _
blnAddElem = Not blnAddElem
ElseIf CBool(ObjPtr(lcolShapes)) Then
blnAddElem = Not blnAddElem
End If
If blnAddElem Then
On Error Resume Next
With ActiveSheet.GroupObjects("NewGroup").ShapeRange
If Not sblnZOrderTop Then _
.ZOrder msoBringToFront
.Ungroup
End With
On Error GoTo 0
For Each shpShape In lcolShapes
ialngIndex = ialngIndex + 1
Redim Preserve savntArray(ialngIndex - 1) As Variant
savntArray(ialngIndex - 1) = shpShape.Name
Next
If Ubound(savntArray) > 0 Then _
ActiveSheet.Shapes.Range(savntArray).Group.Name = "NewGroup"
End If
On Error Resume Next
With ActiveSheet.GroupObjects("NewGroup").ShapeRange
If Not sblnZOrderTop Then _
.ZOrder msoBringToFront _
Else: .ZOrder msoSendToBack
End With
On Error GoTo 0
sblnZOrderTop = Not sblnZOrderTop
Call prcProtect
End Sub
Public Sub prcUngroup()
On Error Resume Next
ActiveSheet.GroupObjects("NewGroup").Ungroup
End Sub
Private Sub prcProtect()
ActiveSheet.Protect Contents:=False, Scenarios:=False, UserInterfaceOnly:=True, _
AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True, _
AllowInsertingColumns:=True, AllowInsertingRows:=True, AllowInsertingHyperlinks:=True, _
AllowDeletingColumns:=True, AllowDeletingRows:=True, AllowSorting:=True, _
AllowFiltering:=True, AllowUsingPivotTables:=True
End Sub
Private Sub prcProgSpeed(blnSpeed As Boolean)
Dim lngCalc As Long
With Application
If blnSpeed Then
.ScreenUpdating = False
lngCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
Else
.ScreenUpdating = True
.Calculation = lngCalc
.EnableEvents = True
End If
End With
End Sub
VBA/HTML - CodeConverter für Office-Foren
AddIn für Excel/Word 2000-2010 - komplett in VBA geschrieben von Lukas Mosimann
Projektbetreuung durch mumpel
Code erstellt und getestet in Office 14
Gruß, Mullit