==== ArrangeObjects ==== Macro para CorelDraw que permite: - Ordenar todos los objetos del dibujo en forma de cuadrícula, con un ancho dado (los objetos se solapan). Sub ''organizaobjetos (columnas)''. - Ordenar todos los objetos en forma de abanico (los objetos se solapan). Sub ''abanicoobjetos(columnas. filas)''. - Desordenar todos los objetos, creando una imagen caótica. Sub ''desordenaobjetos()''. Esta macro produce mejores resultados si los objetos son imágenes en miniatura. Yo lo empleé con las imágenes en miniatura de las portadas de los periódicos de un día. Attribute VB_Name = "ArrangeObjects" Option Explicit ' ' Arranges al objects in a rectangular ruler shape, ' cols objects width. ' ' Organiza todos los objetos en forma de cuadrícula ' con cols objetos de ancho. ' Sub organizaobjetos(cols As Integer) 'anchoX: visible object width. saltoY: visible object height. Dim anchoX As Double, saltoY As Double 'next object X and Y coordinates. Dim nuevoX As Double, nuevoY As Double 'object reference Dim cosa As Layer If cols = 0 Then cols = 10 anchoX = ActiveDocument.SizeWidth / cols saltoY = ActiveDocument.SizeHeight / 9 nuevoX = 0: nuevoY = 0 For Each cosa In ActiveDocument.Layers 'cosa.Move cosa.PositionX - NuevoX, cosa.PositionY - NuevoY 'cosa.SetPosition NuevoX + (cosa.SizeWidth / 2), nuevoy + (cosa.SizeHeight / 2) 'You can't move anything to the same position If (cosa.PositionX <> nuevoX) Or (cosa.PositionY <> nuevoY) Then cosa.SetPosition nuevoX, nuevoY End If nuevoX = nuevoX + anchoX If nuevoX >= ActiveDocument.SizeWidth Then nuevoX = 0 nuevoY = nuevoY + saltoY If nuevoY > ActiveDocument.SizeHeight Then nuevoY = 0 End If End If Next End Sub 'Arranges objects in a fan shape ' rows and cols determine the number of fans ' (original aim was displaying 100 objects). ' 'Reubica objetos en forma de abanico ' rows y cols (filas y columnas) determinan el número ' de abanicos (la idea inicial era recolocar 100 objetos) ' Sub AbanicoObjetos(cols As Integer, rows As Integer) Dim cosa As Layer 'Object layer. Dim anchoX As Long 'widthX Dim altoY As Long 'heightY Dim nuevoX As Long 'new X after movement Dim nuevoY As Long 'new Y after movement Dim anguloMin As Double 'Min angle. Dim anguloMax As Double 'Max angle. Dim anguloDelta As Double 'Angle Difference between objects. Dim angulo As Double 'Current angle Dim Visibility As Boolean 'Visible object? anguloMax = 0 anguloMin = 360 - 15 anguloDelta = -15 anchoX = ActiveDocument.SizeWidth / cols altoY = ActiveDocument.SizeHeight / rows nuevoX = anchoX / 2 nuevoY = altoY / 2 angulo = anguloMin Visibility = True 'normalize angles... If anguloMax < 0 Then anguloMax = (anguloMax Mod 360) + 360 If anguloMax > 360 Then anguloMax = anguloMax Mod 360 If anguloMin < 0 Then anguloMin = (anguloMin Mod 360) + 360 If anguloMin > 360 Then anguloMin = anguloMin Mod 360 'if delta is positive, max should be bigger than min, ' and vice versa. If Sgn(anguloMax - anguloMin) <> Sgn(anguloDelta) Then 'swap anguloMax, anguloMin angulo = anguloMax anguloMax = anguloMin anguloMin = angulo End If For Each cosa In ActiveDocument.Layers 'debug 'cosa.Visible = True If (Int(cosa.PositionX) <> Int(nuevoX)) Or (Int(cosa.PositionY) <> Int(nuevoY)) Then cosa.SetPosition nuevoX, nuevoY End If If angulo < 0 Then angulo = (angulo Mod 360) + 360 If angulo > 360 Then angulo = angulo Mod 360 'You can't rotate something to the same angle. If angulo <> 0 Then ang = angulo / 10 'Layer.Rotate angle is specified in 'tens of degrees (ang=1 means 10 degrees) cosa.Rotate ang, _ cosa.PositionX, _ (ActiveDocument.SizeHeight - cosa.PositionY) 'RotationY is counted from bottom to top 'but positionY is counted from top to bottom. End If DoEvents ' cosa.SetPosition nuevoX, nuevoY angulo = angulo + anguloDelta 'this tests if we've reached the end. 'SGN is used to be aware of angulodelta sign. If Sgn(anguloMax - angulo) <> Sgn(anguloDelta) Then angulo = anguloMin nuevoX = nuevoX + anchoX If nuevoX >= ActiveDocument.SizeWidth Then nuevoX = anchoX / 2 nuevoY = nuevoY + altoY If nuevoY > ActiveDocument.SizeHeight Then nuevoY = altoY / 2 Visibility = False End If End If End If If Visibility = False Then cosa.Visible = False Else cosa.Visible = True End If Next End Sub 'Unarranges a bunch of photos placed in different object layers. ' You'd probably had to move some photos from bottom-right to top-left. 'Desordena un grupo de fotos colocadas en distintas capas de objeto. ' Probablemente tendrá que mover después algunas fotos ' de la zona inferior derecha a la superior izquierda. Sub DesordenaObjetos() 'cosa= object layer. Dim cosa As Layer 'origen=source. Destino=destination. Dim origen As Integer, destino As Integer For Each cosa In ActiveDocument.Layers cosa.Rotate Int(Rnd * 360), Int(Rnd * ActiveDocument.SizeWidth), Int(Rnd * ActiveDocument.SizeHeight) cosa.SetPosition Int(Rnd * ActiveDocument.SizeWidth), Int(Rnd * ActiveDocument.SizeHeight) Next ' 'Try to rearrange layers. This is not the best approach, since 'when we change z-order we also change layer index. ' 'A matrix should be used for true randomization instead. ' For origen = ActiveDocument.Layers.Count To 1 Step -1 destino = Int(Rnd(ActiveDocument.Layers.Count - 1) + 1) If origen <> destino Then ActiveDocument.Layers(origen).OrderFrontOf ActiveDocument.Layers(destino) End If Next End Sub Sub prueba() Dim cosa As Layer Dim anchoX As Long, altoY As Long Dim nuevoX As Long, nuevoY As Long With ActiveDocument.Layers(1) Debug.Print .PositionX, .PositionY ActiveDocument.Layers("Objeto 2").LayerGroup.GetPosition nuevoX, nuevoY .Rotate 0, 0, 0 '.PositionX, .PositionY Debug.Print .PositionX, .PositionY End With End Sub 'Hide all objects (for debug purposes) 'Oculta todo (para depurar) Sub hideallobjects() Dim cosa As Layer For Each cosa In ActiveDocument.Layers cosa.Visible = False Next End Sub