AW: Grafische Objekte kopieren
09.04.2012 15:06:35
fcs
Hallo Helmut,
ich hab das Makro mal so umgeschrieben, dass das Einfügen der Symbole über Parameter gesteuert wird.
Gruß
Franz
'Makros in einem allgemeinen Modul
Sub SymboleKopieren_Zeile_Abstand_fest()
'Symbole in Zeile kopieren mit destem Abstand zwischen Symbolen
Call SymboleKopieren(dblAbstand:=4, AbstandZelle:=2)
End Sub
Sub SymboleKopieren_Zeile_Abstand_Spalte()
'Symbole in Zeile kopieren, einfügen immer in nächste Spalte
Call SymboleKopieren(AbstandZelle:=2)
End Sub
Sub SymboleKopieren_Spalte_Abstand_Zeile()
'Symbole in Spalte kopieren, einfügen immer in nächste Zeile
Call SymboleKopieren(bolZeile:=False, AbstandZelle:=2)
End Sub
Sub SymboleKopieren_Spalte_Abstand_fest()
'Symbole in Spalte kopieren mit destem Abstand zwischen Symbolen
Call SymboleKopieren(bolZeile:=False, dblAbstand:=4, AbstandZelle:=2)
End Sub
Sub SymboleKopieren(Optional bolZeile As Boolean = True, _
Optional dblAbstand As Double = 0, _
Optional AbstandZelle As Double = 2)
' SymboleKopieren aus zu öffnender Datei und ab aktiver Zelle einfügen
' bolZeile: True --> Symbole in Zeile nebeneinander
' bolZeile: False --> Symbole in Spalte untereinander
' dblAbstand = 0 --> Symbol in Spalte/Zeile rechts/unterhalb des vorherigen Symbols
' >0 --> Symbol mit festem Abstand rechts/unterhalb des vorherigen Symbols
' AbstandZelle = Abstand des Symbols vom linken/oberem Rand der Zellen
Dim varAuswahl As Variant
Dim wbkZiel As Workbook, wbkQuelle As Workbook
Dim ZelleZiel As Range, objShape As Shape, objShape2 As Shape
Dim wksZiel As Worksheet, wksQuelle As Worksheet
Dim dblTop As Double, dblLeft As Double
If MsgBox("Symbole aus auszuwählender Datei ab der aktiven Zelle einfügen?", _
vbOKCancel + vbQuestion, "Symbole für Dateien kopieren") = vbNo Then GoTo Beenden
Set wksZiel = ActiveSheet
Set wbkZiel = ActiveWorkbook
Set ZelleZiel = ActiveCell
'Einfüge-Position für erstes Symbol
dblTop = ZelleZiel.Top + AbstandZelle
dblLeft = ZelleZiel.Left + AbstandZelle
'Datei mit eingebetteten Symbolen zum Öffnen auswählen
varAuswahl = Application.GetOpenFilename(FileFilter:="Excelfiles (*.xls*),.xls*")
If varAuswahl False Then
'Quelldatei öffnen
Set wbkQuelle = Application.Workbooks.Open(Filename:=varAuswahl, ReadOnly:=True)
'Blatt mit den Symbolen setzen
Set wksQuelle = wbkQuelle.Sheets(1)
For Each objShape In wksQuelle.Shapes
If objShape.Type = 7 Then 'msoEmbeddedOLEObject
objShape.Copy
wksZiel.Paste
With wksZiel
Set objShape2 = .Shapes(.Shapes.Count)
End With
With objShape2
.Top = dblTop
.Left = dblLeft
'Position des nächsten Symbols
If bolZeile = True Then 'anordnen in Zeile nebeneinander
dblTop = dblTop
If dblAbstand = 0 Then
'nächste Symbol in nächste Spalte rechts vom Symbol
Set ZelleZiel = wksZiel.Cells(ZelleZiel.Row, .BottomRightCell.Offset(0, 1).Column) _
dblLeft = ZelleZiel.Left + AbstandZelle
Else
'nächste Symbol mit festem Abstand rechts vom vorherigen Symbol
dblLeft = dblLeft + .Width + dblAbstand
End If
Else 'anordnen in Spalte untereinander
dblLeft = dblLeft
If dblAbstand = 0 Then
Set ZelleZiel = wksZiel.Cells(.BottomRightCell.Offset(1, 0).Row, _
ZelleZiel.Column)
dblTop = ZelleZiel.Top + AbstandZelle
Else
dblTop = dblTop + .Height + dblAbstand
End If
End If
End With
End If
Next
wbkQuelle.Close savechanges:=False
If bolZeile = True Then
If Not objShape2 Is Nothing Then
Set ZelleZiel = wksZiel.Cells(objShape2.BottomRightCell.Row + 1, _
ActiveCell.Column)
End If
Else
If Not objShape2 Is Nothing Then
Set ZelleZiel = wksZiel.Cells(objShape2.BottomRightCell.Offset(1, 0).Row, _
ZelleZiel.Column)
End If
End If
ZelleZiel.Select
End If
Beenden:
Set wbkZiel = Nothing: Set wbkQuelle = Nothing
Set ZelleZiel = Nothing: Set objShape = Nothing: Set objShape2 = Nothing
Set wksZiel = Nothing: Set wksQuelle = Nothing
End Sub