Apache OpenOffice: Foro oficial de la comunidad

Código: Seleccionar todo

Sub Resalta
'Asignar una macro al evento «Al cambiar selección» de la hoja llamando a la subrutina/función ResaltarXY

 ResaltarXY("RangoT")  '→ Un rango con nombre
' ResaltarXY("C7:N77")  '→ dirección de rango de celdas
' ResaltarXY("")		'→ Cadena vacía → hasta última celda con datos
' ResaltarXY()			'→ ausente → hasta última celda con datos
End Sub

'______________________________________________________________
Sub ResaltarXY(Optional nRango)
'Parámetros: nombre de un rango "MiNombreDeRango" o "A1:AA50000" o "Hoja.A1:$G$55"
'Resalta fila y columna en el rango, cuando se selecciona una de sus celdas
'Requisitos: han de crearse dos rectángulos en la hoja del rango
'si no se le pasa como nombre de rango/"" asume el área con datos de la hoja
'Poner en «Mis Macros» para que pueda ser llamada desde cualquier hoja

On Error GoTo Salir
Dim oDoc As Object
Dim oControlador As Object
Dim oCursor As Object
Dim oSel As Object
Dim oDP As Object
Dim shape1 As Object
Dim shape2 As Object
Dim pos
Dim size
Dim Ancho
Dim Alto
Dim RResalt
Dim FilaSel
Dim ColSel
Dim oDib As Object
Dim i As Integer
Dim ETQ As String
	ETQ= "BarraResaltar"


	oDoc = ThisComponent
	oControlador = oDoc.CurrentController
	oSel = oControlador.Selection
	
	If Not (oSel.ImplementationName = "ScCellObj") Then 'Si la seleccion no es una celda nos vamos
		GoTo Fin
	End If

	oDP = oSel.getSpreadSheet().getDrawPage()
	
'si la celda seleccionada no está en rango → quitar dibujos del resalte solamente y salir
	ColSel = oSel.getRangeAddress.StartColumn
	FilaSel = oSel.getRangeAddress.StartRow

	If IsMissing(nRango) or nRango="" Then
		oCursor = oSel.getSpreadSheet.createCursorByRange(oSel)
		oCursor.gotoEndOfUsedArea( False )
	 	nRango= Replace(oCursor.AbsoluteName, ".",  ".A1:")
	End If
	RResalt = oControlador.ActiveSheet.getCellRangeByName(nRango)		
	If ColSel > RResalt.getRangeAddress.EndColumn Or ColSel < RResalt.getRangeAddress.StartColumn Or _
		FilaSel > RResalt.getRangeAddress.EndRow Or FilaSel < RResalt.getRangeAddress.StartRow Then
		For i= (oDP.getCount - 1) To 0 Step -1
			oDib = oDP.getByIndex(i)
			If oDib.Name = ETQ & "Columna" Or oDib.Name = ETQ & "Fila" Then
				oDP.Remove(oDib)
			End If
		Next
		GoTo Fin
	Else
		'Estamos en el área → crear dibujos si no están creados	
		Dim index1, index2 As Integer 
		For i=0 To oDP.getCount - 1
			oDib = oDP.getByIndex(i)
			If  oDib.Name  = ETQ & "Columna" Then
				index1 = i
			ElseIf  oDib.Name  = ETQ & "Fila" Then
				index2 = i	
			End If
		Next
		If index2 <1 Then	
			DibForma(5000, 300, ETQ & "Columna")
			DibForma(500, 3000, ETQ & "Fila")
		End If	
	End If

	oCursor = RResalt.getSpreadSheet.createCursorByRange(RResalt)
	Ancho = oCursor.Size.Width
	Alto = oCursor.Size.Height	
	oCursor.gotoEndOfUsedArea( False )
 
	shape1 = oDP.getByIndex(oDP.getCount - 1) ' esto supone que no se deben crear dibujos ...
	shape2 = oDP.getByIndex(oDP.getCount - 2) ' ... con celda seleccionada en area de resaltado
	
	pos = oSel.Position
	size = oSel.Size
	size.Width = Ancho

	pos.X = RResalt.Position.X
	shape1.setPosition(pos)
	shape1.setSize(size)
	
	pos = oSel.Position
	size = oSel.Size	
	size.Height = Alto
	
	pos.Y =  RResalt.Position.Y
	shape2.setPosition(pos)
	shape2.setSize(size)
Fin:
	Exit Sub
Salir:
	MsgBox " Ummmm ... error!" & Chr(13) & "¿Es correcto el nombre del rango?",, "Aviso"
End Sub  

'--------------------------------------------------------------------------------
 Sub DibForma(Ancho As Long, Alto As Long, nDib As String, Optional TipoForma As String)
 'Crea un dibujo en la hoja activa desde la que es llamada
 'Poner en «Mis macros» para que sea accesible siempre.
 Dim oPaginaDibujo As Object
 Dim oForma As Object
 Dim oTam As New com.sun.star.awt.Size

     oPaginaDibujo = ThisComponent.getCurrentController.getActiveSheet.getDrawPage()
     If IsMissing(TipoForma) Then TipoForma = "RectangleShape"
     oForma = ThisComponent.createInstance("com.sun.star.drawing." & TipoForma) 'RectangleShape")

     oTam.Width= Ancho
     oTam.Height= Alto

     With oForma
	.LineStyle = com.sun.star.drawing.LineStyle.NONE
	.FillColor = RGB( 75,75,75 )
	.FillTransparence = 85
        .setSize (oTam)	
        .LayerID = 1
	.Name = nDib
     End With

     oPaginaDibujo.Add( oForma )

 End Sub