Apache OpenOffice: Foro oficial de la comunidad

Código: Seleccionar todo

Sub ResaltarXY(Optional nRango, Optional Back As Integer)
'Parámetros: nombre de un rango "MiNombreDeRango" o "A1:AA50000" o "Hoja.A1:$G$55"
'Resalta fila y columna solo en el rango operativo si se se selecciona una de sus celdas
'Si no se le pasa un nombre de rango o este es "" 
'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
'>>Back=2 → los resaltes se situan delante del fondo celdas y de las formas que no son ocultan anotaciones de celda
'>>Back=1 → absolutamente detras de todo, incluso de celdas coloreadas : si no lo están es la más conveniente ;) 
'>>Back=0 → se situan delante del fondo de celda y detras de todas-todas las forma :) pero son seleccionables a golpe de raton. :(
'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"
If IsMissing(Back) Then Back = 2 

	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	
		For i= (oDP.getCount - 1) To 0 Step -1
			oDib = oDP.getByIndex(i)
			If oDib.Name = ETQ & "Columna" Or oDib.Name = ETQ & "Fila" Then
				GoTo Seguir
			End If
		Next
 Dim oForma As Object
 Dim oTam As New com.sun.star.awt.Size
		For i=0 To 1

		     oTam.Width= 5000 - (4700*i)
		     oTam.Height= 300 + (4700*i)
			oForma = ThisComponent.createInstance("com.sun.star.drawing.RectangleShape")
			With oForma
				If i=1 Then 
					.Name = ETQ & "Fila"
'				Else
'					.Name = ETQ & "Columna"
				End If
				.setSize (oTam)	
				.MoveProtect = True
				.LineStyle = com.sun.star.drawing.LineStyle.NONE
				.FillColor = RGB( 75,75,75 )      '<<<<<<<<<<  color  <<<<<<<<<<
				.FillTransparence = 85			'<<<<<<<<<<  transparencia <<<
				.LayerID = Back
				.ZOrder = 0
			End With
		     oDP.Add(oForma)
		Next
	End If

Seguir:
	oCursor = RResalt.getSpreadSheet.createCursorByRange(RResalt)
	Ancho = oCursor.Size.Width
	Alto = oCursor.Size.Height	
	oCursor.gotoEndOfUsedArea(False)

	Dim index1, index2 As Integer 
	For i=0 To oDP.getCount - 1
		oDib = oDP.getByIndex(i)
		If  oDib.Name  = ETQ & "Fila" Then
			index1 = i
'		ElseIf  oDib.Name  = ETQ & "Columna" Then
'			index2 = i	
		End If
	Next

	shape1 = oDP.getByIndex(index1) 
'	shape2 = oDP.getByIndex(index2)
	
	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  

Código: Seleccionar todo

Option Explicit

'-------------------------------------------------
Sub ResaltXY 
'	ResaltadoXY() 'resaltaría con valores por defecto
Dim TC, CC, TF, CF As Double
	TC=70
	CC=RGB(200,0,0)
	TF=80
	CF=RGB(0,200,0)
	ResaltadoXY("",TC,CC,TF,CF)
End Sub
'-------------------------------------------------
Sub ResartaRango3
	ResaltadoXY("Rango3",99) 'Dib.Columna imperceptible
End Sub
'-------------------------------------------------
Sub ResaltaRRango
	ResaltadoXY("RRango")
End Sub

'==================== Subrutina llamada por las macros asignadas a evento hoja "al cambiar selección"  =========================
Sub ResaltadoXY(Optional nRango, Optional TranspColum As Integer, Optional CorColum As Double, Optional TranspFila As Integer, Optional CorFila As Double, Optional Back As Integer)
'Parámetros: nombre de un rango "MiNombreDeRango" o "A1:AA50000" o "Hoja.A1:$G$55"
'Resalta fila y columna solo en el rango operativo si se selecciona una de sus celdas
'Si no se le pasa un nombre de rango o este es "" 
'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
'>>Back=2 → los resaltes se situan delante del fondo celdas y de las formas que no son ocultan anotaciones de celda
'>>Back=1 → absolutamente detras de todo, incluso de celdas coloreadas : si no lo están es la más conveniente ;) 
'>>Back=0 → se situan delante del fondo de celda y detras de todas-todas las forma :) pero son seleccionables a golpe de raton. :(
'TranspColum[Fila] y CorColum[Fila] → transparencia (0=opaco 100=invisible) y color para Columna y Fila
'Poner en «Mis Macros» para que pueda ser llamada desde cualquier hoja

On Error GoTo ErrEscape
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"
'Valores por defecto si no se indican otros	
If IsMissing(Back) Then Back = 2 
If IsMissing(TranspColum) Then TranspColum = 85
If IsMissing(CorColum) Then CorColum =  RGB( 75,75,75 )
If IsMissing(TranspFila) Then TranspFila = 85
If IsMissing(CorFila) Then CorFila = RGB( 75,75,75 )

	oDoc = ThisComponent
	oControlador = oDoc.CurrentController
	oSel = oControlador.Selection
	
	If Not (oSel.ImplementationName = "ScCellObj") And Not (oSel.ImplementationName = "ScCellRangeObj") 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	
		For i= (oDP.getCount - 1) To 0 Step -1
			oDib = oDP.getByIndex(i)
			If oDib.Name = ETQ & "Columna" Or oDib.Name = ETQ & "Fila" Then
				GoTo Seguir
			End If
		Next
 Dim oForma As Object
 Dim oTam As New com.sun.star.awt.Size
		For i=0 To 1

		     oTam.Width= 5000 - (4700*i)
		     oTam.Height= 300 + (4700*i)
			oForma = ThisComponent.createInstance("com.sun.star.drawing.RectangleShape")
			With oForma
				If i=1 Then 
					.Name = ETQ & "Fila"
					.FillTransparence = TranspColum	'<<<<<<<<<<  transparencia <<<
					.FillColor = CorColum			'<<<<<<<<<<  color  <<<<<<<<<<
				Else
					.Name = ETQ & "Columna"
					.FillTransparence = TranspFila	'<<<<<<<<<<  transparencia <<<
					.FillColor = CorFila		   	'<<<<<<<<<<  color  <<<<<<<<<<
				End If
				.setSize (oTam)	
				.MoveProtect = True
				.LineStyle = com.sun.star.drawing.LineStyle.NONE
				.LayerID = Back
				.ZOrder = 0
			End With
		     oDP.Add(oForma)
		Next
	End If

Seguir:
	oCursor = RResalt.getSpreadSheet.createCursorByRange(RResalt)
	Ancho = oCursor.Size.Width
	Alto = oCursor.Size.Height	
	oCursor.gotoEndOfUsedArea(False)

	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

	shape1 = oDP.getByIndex(index1) 
	shape2 = oDP.getByIndex(index2)
	
	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
ErrEscape:
     Select Case Err
         Case 0
         Case 1
         MsgBox " Ummmm ... error!" & Chr(13) & Chr(13) & "¿Es correcto el nombre del rango" & nRango & "?", 48, "Aviso"
         Case Else
             MsgBox "Ocurrió el error numero: " & Err & Chr(13) & Error & _
             Chr(13) & "Linea " & Erl
     End Select
     On Error Goto 0
End Sub  

Código: Seleccionar todo

Sub ResaltXY
'   ResaltadoXY() 'resaltaría con valores por defecto
Dim TC, CC, TF, CF As Double
   TC=70
   CC=RGB(200,0,0)
   TF=80
   CF=RGB(0,200,0)
   ResaltadoXY("",TC,CC,TF,CF)
End Sub