Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Bilder gruppieren

Betrifft: Bilder gruppieren von: stef26
Geschrieben am: 09.08.2014 10:55:55

Hallo liebe Forumsmitglieder,
ich bräuchte mal eure Unterstützung.

Ich habe in einem Tabellenblatt einige Bilder.
Ich möchte, das der User mit der Maus in der Tabelle einen Bereich selektiert
und dann mit einem Button alle Bilder/Grafiken/Gruppierungen die im Bereich sich befinden nochmals Gruppiert.

Leider bringt er mir da immer eine Fehlermeldung, und da mein VBA sich im Anfangsstadium befindet komme ich da leider nicht weiter.

Hier meine Beispiel Datei:
https://www.herber.de/bbs/user/91987.xlsm

Vielleicht könnt ihr mir dabei weiterhelfen ?

Liebe Grüße
Stefan

  

Betrifft: AW: Bilder gruppieren von: Beverly
Geschrieben am: 09.08.2014 11:36:06

Hi Stefan,

versuche es auf diesem Weg:

    If UBound(arrShapes()) > 0 Then
      ActiveSheet.Shapes.Range(arrShapes()).Select
      Selection.Group
   End If

GrußformelBeverly's Excel - Inn


  

Betrifft: AW: Bilder gruppieren von: stef26
Geschrieben am: 09.08.2014 13:17:10

Hallo Danke für die schnelle Hilfe,
nur leider funktioniert es nicht.

Gruß
Stefan


  

Betrifft: AW: Bilder gruppieren von: Beverly
Geschrieben am: 09.08.2014 13:33:07

Hi Stefan,

also bei mir schon (5 mal in deiner Mappe getestet).


GrußformelBeverly's Excel - Inn


  

Betrifft: AW: Bilder gruppieren von: stef26
Geschrieben am: 09.08.2014 14:15:32

Hallo Karin,
danke für deine Hilfe.
Das Makro gruppiert nun wie du schon gesagt hast (danke :-) ) aber kannst du mir sagen warum Excel nicht alles gruppiert ???
Was mir nicht klar ist, wie er die Selektion macht.
Ich selektiere den kompletten Bereich (sogar weit darüber hinaus),
das Makro gruppiert aber nicht alle???

:-)
Stefan


  

Betrifft: AW: Bilder gruppieren von: Beverly
Geschrieben am: 09.08.2014 18:57:50

Hi Stefan,

die Elemente, die nicht mit gruppiert werden, liegen bereits als gruppierte Elemente vor. Weshalb sie aber per VBA nicht nocheinmal mit gruppiert werden (können), obwohl sie ebenfalls alle im Arry enthalten sind, ist mir unbekannt. Eine Lösung habe ich leider nicht.


GrußformelBeverly's Excel - Inn


  

Betrifft: AW: Bilder gruppieren von: stef26
Geschrieben am: 09.08.2014 19:47:23

ok
trotzdem vielen Danke für deine Hilfe.
Du hast mich trotzdem ein Stück weitergebracht.

Danke

:-)
Stefan


  

Betrifft: AW: Bilder gruppieren von: Mullit
Geschrieben am: 09.08.2014 23:11:06

Hallo,

hier mal ein Bsp. für das Selektieren mit der Maus, die Namen der GroupObjekte müssen unterscheidbar sein (s.o.)...

Und es ist ratsam, sich den Artikel über Option Explicit durchzulesen....

Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef pArray() As Any) As Long

Public Sub prcGroupShapes()
 Dim objShape As Shape
 Dim objCell As Range
 Dim avntShpNames() As Variant
 Dim ialngIndex As Long
  On Error GoTo Sub_Err
  For Each objCell In Selection
     For Each objShape In ActiveSheet.Shapes
        With objShape
            If Not .Name = "Grafik 110" Then
              If Not Intersect(.TopLeftCell, objCell) Is Nothing Then
                ialngIndex = ialngIndex + 1
                Redim Preserve avntShpNames(ialngIndex - 1) As Variant
                avntShpNames(ialngIndex - 1) = .Name
              End If
             End If
        End With
     Next
   Next
   If Not CBool(SafeArrayGetDim(avntShpNames)) Then
     MsgBox "Es wurden keine Shapes selektiert.", vbExclamation
   ElseIf Ubound(avntShpNames) < 1 Then
     MsgBox "Mindestens 2 Shapes müssen im Selektionsbereich liegen", vbExclamation
   Else
     ActiveSheet.Shapes.Range(avntShpNames).Group
   End If
Sub_Err:
   If Err.Number <> 0 Then _
     MsgBox "Ausgewählter Bereich muß ein Zellbereich sein!", vbExclamation
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 12
Gruß,


  

Betrifft: AW: Bilder gruppieren von: Mullit
Geschrieben am: 10.08.2014 00:27:49

Hallo,

ohne On Error ist's noch besser und die interne Schleife kann vorzeitig beendet werden:

Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef pArray() As Any) As Long

Public Sub prcGroupShapes()
 Dim objShape As Shape
 Dim objCell As Range
 Dim avntShpNames() As Variant
 Dim ialngIndex As Long
 If TypeOf Selection Is Range Then
   For Each objCell In Selection
      For Each objShape In ActiveSheet.Shapes
         With objShape
             If Not .Name = "Grafik 110" Then
               If Not Intersect(.TopLeftCell, objCell) Is Nothing Then
                 ialngIndex = ialngIndex + 1
                 Redim Preserve avntShpNames(ialngIndex - 1) As Variant
                 avntShpNames(ialngIndex - 1) = .Name
                 Exit For
               End If
             End If
         End With
      Next
   Next
   If Not CBool(SafeArrayGetDim(avntShpNames)) Then
     MsgBox "Es wurden keine Shapes selektiert.", vbExclamation
   ElseIf Ubound(avntShpNames) < 1 Then
     MsgBox "Mindestens 2 Shapes müssen im Selektionsbereich liegen", vbExclamation
   Else
     ActiveSheet.Shapes.Range(avntShpNames).Group
   End If
 Else
   MsgBox "Ausgewählter Bereich muß ein Zellbereich sein!", vbExclamation
 End If
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 12

Gruß,


  

Betrifft: AW: Bilder gruppieren von: stef26
Geschrieben am: 10.08.2014 01:01:48

Guten Abend zur später Stunde
werde morgen deinen Code mal bei mir in meinem OrginalTool testen

Besten Dank für deine sehr umfangreihen Bemühungen !!!!!


Liebe Grüße und gute Nacht
Stefan


  

Betrifft: AW: Bilder gruppieren von: Mullit
Geschrieben am: 10.08.2014 01:10:25

Hallo,

null Problemo,
gleich noch eine Korrektur zur Nacht: Exit For muß doch raus, da sich mehrere Objekte in einem Zellbereich befinden können:

Also dieser Part dann wie oben:

'...
 If Not Intersect(.TopLeftCell, objCell) Is Nothing Then
   ialngIndex = ialngIndex + 1
   ReDim Preserve avntShpNames(ialngIndex - 1) As Variant
   avntShpNames(ialngIndex - 1) = .Name
 End If
'...

Gruß,


  

Betrifft: AW: Bilder gruppieren von: stef26
Geschrieben am: 10.08.2014 01:40:42

Hallo (doch nochmal)
würde es dir was ausmachen mir den gesamten Code nochmal zu senden, da ich gerade auf dem Schlauch stehe, was du mit den update meinst. Sorry.

Teste aber erst morgen (gähhn)

Liebe Grüße
zzzzzzzzz


  

Betrifft: AW: Bilder gruppieren von: Mullit
Geschrieben am: 10.08.2014 03:14:44

Hallo,

null Problemo:

Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef pArray() As Any) As Long

Public Sub prcGroupShapes()
 Dim objShape As Shape
 Dim objCell As Range
 Dim avntShpNames() As Variant
 Dim ialngIndex As Long
 If TypeOf Selection Is Range Then
   For Each objCell In Selection
      For Each objShape In ActiveSheet.Shapes
         With objShape
             If Not .Name = "Grafik 110" Then
               If Not Intersect(.TopLeftCell, objCell) Is Nothing Then
                 ialngIndex = ialngIndex + 1
                 Redim Preserve avntShpNames(ialngIndex - 1) As Variant
                 avntShpNames(ialngIndex - 1) = .Name
               End If
             End If
         End With
      Next
   Next
   If Not CBool(SafeArrayGetDim(avntShpNames)) Then
     MsgBox "Es wurden keine Shapes selektiert.", vbExclamation
   ElseIf Ubound(avntShpNames) < 1 Then
     MsgBox "Mindestens 2 Shapes müssen im Selektionsbereich liegen", vbExclamation
   Else
     ActiveSheet.Shapes.Range(avntShpNames).Group
   End If
 Else
   MsgBox "Ausgewählter Bereich muß ein Zellbereich sein!", vbExclamation
 End If
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

Aber nu':

Gruß,


  

Betrifft: AW: Bilder gruppieren von: stef26
Geschrieben am: 10.08.2014 09:02:12

Guten Morgen,
konnte es schon gar nicht mehr erwarten deinen Code zu testen.
Und ich muss gestehen, besser hätte man das nicht machen können.

Hut ab und vielen herzlichen Dank für deine Hilfe (bis spät in die Nacht)

Liebe Grüße
Stefan


  

Betrifft: AW: Bilder gruppieren von: Beverly
Geschrieben am: 10.08.2014 10:09:58

Hi,

dein Code macht auch nichts anderes als mein Code und bringt - ebenso wie meiner - an genau derselben Stelle einen Laufzeitfehler '1004': Anwendungs- oder Objektdefinierter Fehler, und zwar hier:

     ActiveSheet.Shapes.Range(avntShpNames).Group
Wenn man dann - wie in meinem Beitrag beschrieben - diesen Teil so umschreibt:
     ActiveSheet.Shapes.Range(avntShpNames).Select
     Selection.Group
kommt zwar auch kein Laufzeitehler mehr, aber es sind nach wie vor nicht alle Shapes in die Gruppierung mit einbezogen.

In der angehängten Mappe habe ich mal den Bereich gelb formatiert, der markiert war und die Shapes, die sich nach Ausführung deines Codes (mit Änderung wie oben angemerkt, damit er überhaupt durchläuft) in der Gruppierung befinden, grün gefüllt zur Unterscheidung von denen, die nicht mit in der Gruppierung sind, obwohl sie sich komplett im gelben Bereich befinden. Und das sind Shapes, die bereits gruppiert waren. Dein Code nimmt also - genau wie meiner - nur die Shapes, die nicht bereits als Gruppierung vorlagen.

https://www.herber.de/bbs/user/91996.xlsm

Gestestet mit Excel2010.


GrußformelBeverly's Excel - Inn


  

Betrifft: AW: Bilder gruppieren von: Mullit
Geschrieben am: 10.08.2014 11:36:02

Hallo Beverly + Stefan,

@ Stefan:

prima;

@Beverly:
nee nicht ganz...

zunächst mal bitte meinen Code nicht umschreiben, der läuft schon genauso wie er soll:

Du hast meine anderen Posts nicht gelesen:

hier mal ein Bsp. für das Selektieren mit der Maus, die Namen der GroupObjekte müssen unterscheidbar sein (s.o.)...

Das Problem: Stefan hat jeweils 2 Groupobjekte mit den gleichen Namen belegt:
EbeneAF-M1 und F-M3 Führungsschiene GL-450 1,035m 14 S2 S2 und Rollbahn  RR-400 1,135m
EbeneAF-M1 und F-M3 Führungsschiene GL-450 1,035m 14 S2 S2 und Rollbahn  RR-400 1,135m

EbeneAF-M1 und F-M3  1,035m 15 S2 S2 und Rollbahn  RR-400 1,135m
EbeneAF-M1 und F-M3  1,035m 15 S2 S2 und Rollbahn  RR-400 1,135m
Die Namen müssen aber im Variant-Array unterscheidbar sein >>> Benennt man die Groupobjekte um, läuft der Code fehlerfrei und alle Shapes werden gruppiert, zudem kann man die Objekte auch per Maus selektieren, da das der Wunsch war, ist select überflüssig...

Gut, das Umbenennen könnte man auch noch im Code übernehmen...

Gruß, Mullit


  

Betrifft: AW: Bilder gruppieren von: Beverly
Geschrieben am: 10.08.2014 14:20:26

Hi,

Frage: wie soll ich das Ergebnis deines Codes testen, wenn er bei mir auf einen Fehler läuft (s. auch meinen vorhergehenden Beitrag) und nur mit der Änderung überhaupt erst durchläuft? Deine Bitte ist also ein wenig unangebracht.
Und wenn man die Shapes direkt selektiert (das hätte ich deinem Beitrag jetzt so entnommen), dann kommt die MsgBox, dass ein Zellbereich selektiert sein muss (was auch logisch aus deinem Code hervorgeht).

Auch wenn man das Shape mit dem doppelten Namen umbenennt, werden die bereits gruppierten Shapes nicht mitgenommen.

Das Shape "EbeneARohrStandard (9) - Länge:1,7" mit gruppiert, obwohl es nicht komplett im gelb markierten Bereich liegt - das ist in meinem Code berücksichtigt.



GrußformelBeverly's Excel - Inn


  

Betrifft: AW: Bilder gruppieren von: Mullit
Geschrieben am: 10.08.2014 16:20:05

Hallo Beverly,

holymoly, scheint doch schwieriger zu sein....

Zunächst mal wie es aussieht erhält Stefan bisher keine Fehler....

Ist zwar nicht ganz so kriegsentscheidend, aber meine Bitte ist in diesem Fall vollkommen angebracht, denn hättest Du meinen vorherigen Beitrag gelesen und den Hinweis befolgt, dann würde der Code in keinen Fehler laufen und eine Änderung ist nicht nötig:

Ich kann ja gerne mein Zitat wiederholen, wenn es zur Verständniserweiterung beiträgt:

hier mal ein Bsp. für das Selektieren mit der Maus, 
die Namen der GroupObjekte müssen unterscheidbar sein (s.o.)...

Wenn alle Shapes unterschiedliche Namen haben und Du selektierst eine Zellbereich (nicht die Shapes direkt!!!) um die zu gruppierenden Shapes, dann werden alle Shapes, die in diesem Zielbereich liegen gruppiert und zwar ohne Runtime-Error!!!

Das Selecten passiert mit der Maus, der Code gruppiert direkt!!

Darum ist dies
Auch wenn man das Shape mit dem doppelten Namen umbenennt, werden die bereits gruppierten Shapes nicht mitgenommen.

leider falsch....

Es gibt übrigens in dem Bsp. wie oben geschrieben 2 Shapes mit doppelten Namen, Du mußt schon beide umbenennen...

Jetzt klarer??

Gruß, Mullit


  

Betrifft: AW: Bilder gruppieren von: Beverly
Geschrieben am: 10.08.2014 16:48:38

Hi,

Zitat: "Zunächst mal wie es aussieht erhält Stefan bisher keine Fehler...."

Richtig - wenn ALLE Shapes unterschiedliche Namen haben, dann läuft auch der Code aus Stefans Eröffnungsbeitrag ohne Fehler.

Übrigens: du solltest dir mal deinen Oberlehrerhaften Schreibstil abgewöhnen - macht keinen guten Eindruck...



GrußformelBeverly's Excel - Inn


  

Betrifft: AW: Bilder gruppieren von: Mullit
Geschrieben am: 10.08.2014 17:20:52

Hallo,

Richtig - wenn ALLE Shapes unterschiedliche Namen haben, 
dann läuft auch der Code aus Stefans Eröffnungsbeitrag ohne Fehler.

Hab' auch nichts anderes behauptet...

Übrigens: du solltest dir mal abgewöhnen, mir vorzuschreiben, welchen Schreibstil ich zu pflegen habe - macht keinen guten Eindruck...

Zudem schienst du etwas Nachhilfe nötig zu haben, aber macht nichts, wird schon werden...

Gruß,


  

Betrifft: AW: Bilder gruppieren von: Beverly
Geschrieben am: 10.08.2014 17:29:58

Hi,

Zitat:
"Zudem schienst du etwas Nachhilfe nötig zu haben, aber macht nichts, wird schon werden..."

Möge sich jeder selbst ein Urteil über deinen Schreibstil bilden...


GrußformelBeverly's Excel - Inn


  

Betrifft: AW: Bilder gruppieren von: Mullit
Geschrieben am: 11.08.2014 00:24:42

Möge sich jeder selbst ein Urteil über deinen Schreibstil bilden...

dito...


  

Betrifft: AW: Bilder gruppieren von: stef26
Geschrieben am: 10.08.2014 11:39:38

Hallo an Alle die bei meinem Problem so eifrig mitgeholfen haben.
Vielen Danke dafür.
So wie es aussieht hab ich nur noch ein Problem, wenn der User eine vorhandene Grafik kopiert und nicht aus der Bibliothek (hier wird hochgezählt) zieht.
Denn dann sind die Namen gleich und dann funktioniert das Makro leider nicht mehr.
Das Gruppieren wird gemacht um schneller eine Skizze erstellen zu können. Z.B. werden 2 Rollbahnen mit einer Kiste gruppiert und dann kopiert. Nach dem kopieren wird wieder entgruppiert, da die Grafik einen speziellen Namen hat (hinter der das Material steht) und über einen späteren Macro alle Bilder und somit in alle einzelnen Materialien zerlegt wird.

Vielleicht sollte ich dazu ein neues Thema aufmachen, denn das eigentliche Thema mit dem Gruppieren funktioniert ja. (nur wenn Namen gleich sind nicht , oder kann man eine Abfrage gleicher Namen machen und dann sollten diese gleich sein einen Index hinzufügen?)

Zusammengefasst:
Werden z.B. 5 Objekte gruppiert, wie kann man einen KopieButton erstellen, so dass die Gruppierten Objekte eine Art Index(z.B._1) erhalten, so dass diese nach dem entgruppieren nicht gleich sind ?



Ich glaub jetzt wird es langsam so kompliziert (ich hoffe ihr versteht meine komplizierte Art was zu erklären)

Liebe Grüße
Stefan


  

Betrifft: AW: Bilder gruppieren von: Mullit
Geschrieben am: 10.08.2014 16:35:55

Hallo Stefan,

da die Erklärungen jetzt schon doppelte Codelänge erreichen, hier gleich mal ein Umbenenner in den Code mit eingebaut:

Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef pArray() As Any) As Long

Public Sub prcGroupShapes()
 Dim blnInit As Boolean
 Dim objShape As Shape, objShapeGem As Shape
 Dim objCell As Range
 Dim avntShpNames() As Variant
 Dim ialngIndex As Long
 Dim lngCount As Long
 If TypeOf Selection Is Range Then
   For Each objCell In Selection
      For Each objShape In ActiveSheet.Shapes
         lngCount = 0
         If blnInit Then blnInit = Not blnInit
         With objShape
             If Not .Name = "Grafik 110" Then
               For Each objShapeGem In ActiveSheet.Shapes
                  If .Name = objShapeGem.Name Then
                    If blnInit Then
                     lngCount = lngCount + 1
                      With objShapeGem
                          .Name = .Name & "_" & lngCount
                       End With
                    End If
                    If Not blnInit Then blnInit = Not blnInit
                  End If
               Next
               If Not Intersect(.TopLeftCell, objCell) Is Nothing Then
                 ialngIndex = ialngIndex + 1
                 Redim Preserve avntShpNames(ialngIndex - 1) As Variant
                 avntShpNames(ialngIndex - 1) = .Name
               End If
             End If
         End With
      Next
   Next
   If Not CBool(SafeArrayGetDim(avntShpNames)) Then
     MsgBox "Es wurden keine Shapes selektiert.", vbExclamation
   ElseIf Ubound(avntShpNames) < 1 Then
     MsgBox "Mindestens 2 Shapes müssen im Selektionsbereich liegen", vbExclamation
   Else
     ActiveSheet.Shapes.Range(avntShpNames).Group
   End If
 Else
   MsgBox "Ausgewählter Bereich muß ein Zellbereich sein!", vbExclamation
 End If
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 12

Gruß, Mullit


  

Betrifft: AW: Bilder gruppieren von: stef26
Geschrieben am: 10.08.2014 16:39:06

Hallo Beverly hallo Mullit,
sorry dass ich euch aktuell nicht mehr folgen kann.
Da ihr euch beide schon so viele Mühe mit mir gegeben habt wäre eine kurze Zusammenfassung für mich sehr hilfreich.
So wie ich es verstanden habe ist mein Problem, dass ich gleiche Namen von Shapes verwende und diese anscheinend irgendwie Probleme bereiten. Ist das richtig ?
Mullit meinte, dass man das mit einem Index vor dem Gruppieren lösen könnte?

Ich glaub ich brauch zum guter Schluss doch nochmal Hilfe, wie man das mit dem Index machen kann.

Wer von euch beiden das komplette Programm mal haben möchte (6MB) dem würde ich dies mal zukommen lassen, vielleicht hilft das für etwas Klarheit zu sorgen. Ihr müsstet mir halt sagen wie man 6MB irgendwo ablegen kann.

Liebe Grüße
Stefan


  

Betrifft: AW: Bilder gruppieren von: stef26
Geschrieben am: 10.08.2014 16:51:57

Hallo Mullit,
ich hab gesehen, dass du während ich geschrieben habe mir einen update geschickt hast.
Vielen Dank dafür.
Hab diesen in meiner Datei reingemacht und ihn versucht zu testen. Allerdings läuft er auf einen Fehler.

Würde es dir helfen, wenn ich dir mal die Orginal (6MB) zukommen lasse ?

Liebe Grüße
Stefan


  

Betrifft: AW: Bilder gruppieren von: Mullit
Geschrieben am: 10.08.2014 17:37:40

Hallo Stefan,

lad doch nochmal ein Bsp.-Mappe mit dem relevanten Teil hier hoch plus Fehlerbeschreibung in der Mappe oder hier, ich seh dann schon, wo der Code buggt, in Deiner alten Testmappe läuft er fehlerlos...

Gruß, Mullit


  

Betrifft: AW: Bilder gruppieren von: stef26
Geschrieben am: 10.08.2014 18:07:14

Hallo Mullit,
das ist lieb von dir. Aber ich hab nur ne Version die 6MB groß ist.
Die Version mit 300kb (hier glaub ich das Max) hab ich reingeladen und da schreibst du läufts fehlerfrei.
Gibt es hier im Forum die Möglichkeit 6MB rein zu laden ?

Gruß
Stefan


  

Betrifft: AW: Bilder gruppieren von: Mullit
Geschrieben am: 10.08.2014 18:44:12

Hallo Stefan,

da wird's natürlich schwieriger;

laut Uploadregularien fürchte ich nein, dann müsstest Du es doch mit einem Filehoster versuchen, die Ergebnisse sollten aber hier wiedergegeben werden.

Da kenn' ich mich zwar auch weniger mit aus, aber in OL wurde file-upload.net als zuverlässig genannt.

Ich kann da zwar reinschauen, aber ob ich da zu einem Ergebnis komme, kann ich Dir auch nicht garantieren...

Füg' in die Mappe nochmal eine Beschreibung ein, was die Prozedur machen soll.

Gruß, Mullit


  

Betrifft: AW: Bilder gruppieren von: stef26
Geschrieben am: 10.08.2014 19:42:27

Hallo Mullit,
hab mal die Daten auf OneDrive gelegt.
https://onedrive.live.com/redir?resid=FFA421954C49778A!579&authkey=!ADB2WeJhDFctWeM&ithint=folder%2c
so kannst du mal auf der Orginal mal nachsehen...
Danach wieder hier im Forum für alle, so wie gewünscht.

Beschreibung ist in Word.
Hier hab ich auch gleich zusammengefast, wo noch die Probleme des Tools liegen.

Grundsätzlich:
über das Tool wird versucht ein Regal/Wagen zu skizzieren (kein Anspruch auf 3D) hab es nur wegen der Übersicht so gestaltet. Teilelager im Rechten Bereich. Im unteren Bereich sind alle Themen die die Ansicht betreffen. Hier kann man Sachen ein/ausbleden.
Ist ein Wagen/Regal gezeichnet lässt man sich die Stückliste(BOM) incl. Preise und Bearbeitungszeit errechnen. Danach kann man noch eine Optimierung für die beste Schnittlängenberechnung machen, um möglichst wenig Verschnitt zu haben (möchte man den Wagen selber Bauen)
Ansonsten könnte man noch aus SAP sich ne Stückliste für die Beschriftung einladen.

Probleme hab ich mit dem in Word beschriebenen Sachen.

Ich hoffe du findest dich zurecht...

Liebe Grüße
Stefan


  

Betrifft: AW: Bilder gruppieren von: Mullit
Geschrieben am: 11.08.2014 00:15:57

Hallo Stefan,

Hab' mir jetzt nur den Gruppiercode vorgenommen:

Du scheinst da unsichtbare Shapes in Deiner Mappe zu haben, daraus resultierte der Laufzeitfehler..

Der angepasste Code lief zwar so ein paarmal fehlerfrei durch, allerdings ist die Testmappe kaum bearbeitbar, da zeitweise die Zellen und Objekte nicht auswählbar sind, auch die Codeverarbeitung scheint ungewöhnlich viel Zeit in Anspruch zu nehmen...

Da wirst Du noch grundlegendes ändern müssen (Eventmakros scheinen dem Codeablauf ins Gehege zu kommen) und mußt selbst noch mal ran...

Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef pArray() As Any) As Long

Public Sub prcGroupShapes()
 Dim blnInit As Boolean
 Dim objShape As Shape, objShapeGem As Shape
 Dim objCell As Range
 Dim avntShpNames() As Variant
 Dim ialngIndex As Long
 Dim lngCount As Long
 If TypeOf Selection Is Range Then
   For Each objShape In ActiveSheet.Shapes
      lngCount = 0
      If blnInit Then blnInit = Not blnInit
      With objShape
          If Not .Name = "Grafik 110" Then
            For Each objShapeGem In ActiveSheet.Shapes
               If .Name = objShapeGem.Name Then
                 If blnInit Then
                    lngCount = lngCount + 1
                    With objShapeGem
                        .Name = .Name & "_" & lngCount
                    End With
                  End If
                  If Not blnInit Then blnInit = Not blnInit
                End If
            Next
            For Each objCell In Selection
               If .Visible Then
                 If Not Intersect(.TopLeftCell, objCell) Is Nothing Then
                   ialngIndex = ialngIndex + 1
                   Redim Preserve avntShpNames(ialngIndex - 1) As Variant
                   avntShpNames(ialngIndex - 1) = .Name
                 End If
               End If
            Next
          End If
      End With
   Next
   If Not CBool(SafeArrayGetDim(avntShpNames)) Then
     MsgBox "Es wurden keine Shapes selektiert.", vbExclamation
   ElseIf Ubound(avntShpNames) < 1 Then
     MsgBox "Mindestens 2 Shapes müssen im Selektionsbereich liegen", vbExclamation
   Else
     ActiveSheet.Shapes.Range(avntShpNames).Group
   End If
 Else
   MsgBox "Ausgewählter Bereich muß ein Zellbereich sein!", vbExclamation
 End If
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 12

Gruß, Mullit


  

Betrifft: AW: Bilder gruppieren von: Stef26
Geschrieben am: 11.08.2014 17:58:13

Alles klar Mullit,
vielen Dank für deine Hilfe !!!
Werde mir mal die Eventmakros mal genauer ansehen.

Ich hätte doch noch eine kleine Bitte, falls du mal hier im Forum unterwegs bist könntest du dir bitte meinen 2ten Beitrag mal ansehen, der liegt mir noch schwerer im Magen.
Hier möchte ich die Verbinder der beiden vorderen Rohre in den Vordergrund bringen.
Die Auswahl treffe ich über die Position der beiden Rohre.
Doch leider macht mir das Macro nicht alle Verbinder(haben alle S4 im Namen) in den Vordergrund.
Das Komische daran, er macht immer wieder andere (S4) in den Vordergrund ???

For Each shaShape In ActiveSheet.Shapes
        If shaShape.Left < x1 + 10 + Sheets("Skizze").Range("B22") And _
            shaShape.Left > x1 - 10 + Sheets("Skizze").Range("B22") And Not shaShape.Name Like " _
*Rohr*" And shaShape.Name Like "*S4*" Then
            If shaShape.Visible Then
               ReDim Preserve arrShapes(0 To lngShape)
               arrShapes(lngShape) = shaShape.Name
               lngShape = lngShape + 1
            End If
        End If
    Next shaShape
    If UBound(arrShapes()) > 0 Then ActiveSheet.Shapes.Range(arrShapes()).ZOrder msoBringToFront


Liebe Grüße und nochmal herzlichen DANK für deine Hilfe

Stefan


  

Betrifft: AW: Bilder gruppieren von: Mullit
Geschrieben am: 14.08.2014 12:35:30

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


  

Betrifft: AW: Bilder gruppieren von: stef26
Geschrieben am: 14.08.2014 18:38:33

Hallo Mullit,
könntest du mir kurz beschreiben, wie der Code arbeitet, da meine VB Kenntnisse doch sehr mager sind...

Da hast du ja jede Menge Grips reingesteckt, und ich würde schon gerne versuchen diesen zu verstehen...

Danke für die viele Arbeit die du da investiert hast

Liebe Grüsse
Stefan


  

Betrifft: AW: Bilder gruppieren von: Mullit
Geschrieben am: 15.08.2014 22:20:00

Hallo Stefan,

kein Problem:
der Code war dazu gedacht, die Gruppierungskoordinaten der Shapes dynamisch zu erstellen:
Die Shapes werden mit dem linken Mausklick (jedem wird zunächst das Makro prcShapeControl zugwiesen) in den Zeichenbereich gezogen und dann automatisch einer Collection hinzugefügt. Das passiert in der Callback-Procedure des Timers TimerProc.

Gleichzeitig wird das Shape dupliziert und bei Abbruch der Pseudo-Drag-and-Drop-Aktion wieder gelöscht.
Die Umbennnungen passieren bei mir in der TimerProc mit der Replaceanweisung; hab' ich bisher nur mit den Verbindern getestet...

Die Apianweisungen - die Declare Blöcke am Programmanfang - steuern hierbei das Pseudo-Drag-and-Dropverhalten.

Mit einem Button, dem prcZOrder zugewiesen wird, kann man dann die Shapes gruppieren und in den Vordergrund holen, die Gruppierung auflösen mit prcUngroup.

Die Koordinaten des Zeichenbereichs sind in fncBlnArea festgelegt...

Wurde bisher nur mit Deiner reduzierten Testmappe + Verbindern als Entwurf getestet, aufgrund der hohen Shapeanzahl in Deiner Originalmappe wäre der Einbau sicherlich doch recht komplex....

Gruß, Mullit


  

Betrifft: AW: Bilder gruppieren von: stef26
Geschrieben am: 16.08.2014 07:29:06

Hallo Mullit,
besten Dank. Ich werde schaun, dass ich so viel wie möglich übernehmen kann.

Vielen Dank nochmal für deine Unterstützung.

Liebe Grüsse
Stefan


  

Betrifft: AW: Bilder gruppieren von: Mullit
Geschrieben am: 10.08.2014 19:23:58

Hallo Stefan,

übrigens noch als Anhang, die objCell-Schleife war schlecht gesetzt, so läuft der Code schon mal schneller:

Option Explicit

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" ( _
    ByRef pArray() As Any) As Long

Public Sub prcGroupShapes()
 Dim blnInit As Boolean
 Dim objShape As Shape, objShapeGem As Shape
 Dim objCell As Range
 Dim avntShpNames() As Variant
 Dim ialngIndex As Long
 Dim lngCount As Long
 If TypeOf Selection Is Range Then
   For Each objShape In ActiveSheet.Shapes
      lngCount = 0
      If blnInit Then blnInit = Not blnInit
      With objShape
          If Not .Name = "Grafik 110" Then
            For Each objShapeGem In ActiveSheet.Shapes
               If .Name = objShapeGem.Name Then
                 If blnInit Then
                    lngCount = lngCount + 1
                    With objShapeGem
                        .Name = .Name & "_" & lngCount
                    End With
                  End If
                  If Not blnInit Then blnInit = Not blnInit
                End If
            Next
            For Each objCell In Selection
               If Not Intersect(.TopLeftCell, objCell) Is Nothing Then
                 ialngIndex = ialngIndex + 1
                 Redim Preserve avntShpNames(ialngIndex - 1) As Variant
                 avntShpNames(ialngIndex - 1) = .Name
               End If
            Next
          End If
      End With
   Next
   If Not CBool(SafeArrayGetDim(avntShpNames)) Then
     MsgBox "Es wurden keine Shapes selektiert.", vbExclamation
   ElseIf Ubound(avntShpNames) < 1 Then
     MsgBox "Mindestens 2 Shapes müssen im Selektionsbereich liegen", vbExclamation
   Else
     ActiveSheet.Shapes.Range(avntShpNames).Group
   End If
 Else
   MsgBox "Ausgewählter Bereich muß ein Zellbereich sein!", vbExclamation
 End If
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 12

Gruß, Mullit


 

Beiträge aus den Excel-Beispielen zum Thema "Bilder gruppieren"