Moderatori: Anthony47, Flash30005
ActiveSheet.Shapes("Line 1").Line.ForeColor.SchemeColor = 10
ActiveSheet.Shapes("Line 1").Line.ForeColor.SchemeColor = RGB (R,G,B)
Sub CONTA_SHAPES()
Dim QUANTE_FORME As Integer
Dim LISTA_SHAPES() 'questo sarà l'elenco delle forme presenti
QUANTE_FORME = ActiveSheet.Shapes.Count
'Questo ci fornisce il numero di forme presenti nel foglio
'Una volta noto il numero di forme, provvediamo a ridimensionare l'elenco alla bisogna:
ReDim LISTA_SHAPES(1 To QUANTE_FORME)
' (tante righe quante ne servono)
For F = 1 To QUANTE_FORME
LISTA_SHAPES(F) = ActiveSheet.Shapes(F).Name
Next
Stop
End Sub
RIGA_INIZIO = 1
'SUPPONIAMO CHE LA TABELLA INIZI IN CELLA E2 (METTO 1 PER RAGIONI DI "GESTIONE" DEL CICLO SEGUENTE)
COL_INIZIO = 5
For R = 1 To QUANTE_FORME
Cells(RIGA_INIZIO + R, COL_INIZIO).Formula = LISTA_SHAPES(R)
Next
Call CONTA_SHAPES
Sub CreaPianta()
'
'Azzera le Linee
On Error Resume Next
For Each Pict In ActiveSheet.Shapes
If Left(Pict.Name, 4) = "Line" Then Pict.Delete
Next Pict
On Error GoTo 0
'Crea le nuove linee
X0 = Range("zero").Value
Y0 = Range("zero").Offset(0, 1).Value
Magn = Range("scala").Value
Do
I = I + 1
With Range("zero")
If .Offset(I, 0) = "" Then Exit Do
ActiveSheet.Shapes.AddLine(X0 + .Offset(I, 0) * Magn, Y0 + .Offset(I, 1) * Magn, X0 + .Offset(I, 2) * Magn, Y0 + .Offset(I, 3) * Magn).Select
Selection.ShapeRange.Line.ForeColor.SchemeColor = .Offset(I, -1)
Selection.ShapeRange.Line.Weight = .Offset(I, -2)
End With
Loop
End Sub
Function MAPPA_SHAPES(NOME_OGGETTO)
Dim PUNTI()
'ActiveSheet.Shapes("Line 4").Select
Set P = ActiveSheet.Shapes(NOME_OGGETTO) 'Questo per brevità nel digitare il codice :-)
On Error Resume Next
'Soltanto gli oggetti "disegno a mano libera hanno un elenco dei punti!
' Oggetti: "validi":
' - Line
' - Freeform
QUANTI_PUNTI = P.Nodes.Count
ReDim PUNTI(1 To QUANTI_PUNTI, 1 To 2)
'....
MAPPA_SHAPES = PUNTI
On Error GoTo 0
Set P = Nothing
End Function
P
|
+- ...
...
|
+- Nodes
| +- Application
| | +- ...
| +- Count
| +- Creator
| |- Parent
| | +-
| +- Item 1
| | +- ...
| | +- Points
| | +- Points (1)
| | +- Points (1,1)
| | +- Points (1,2)
| +- Item 2
| | +- Points
| | +- Points (1)
| | +- Points (2,1)
| | +- Points (2,2)
| ecc.
For Each K in P.Nodes
PUNTI (K,1) = P.NODES(K).POINTS(1,1)
PUNTI (K,2) = P.NODES(K).POINTS(1,2)
Next
Function MAPPA_SHAPES(NOME_OGGETTO)
Dim PUNTI()
Set P = ActiveSheet.Shapes(NOME_OGGETTO) 'Questo per brevità nel digitare il codice :-)
P.Select
T = P.Type
On Error GoTo NO_PUNTI 'Soltanto gli oggetti "disegno a mano libera hanno un elenco dei punti!
' Oggetti: "validi":
' - Line
' - Freeform
QUANTI_PUNTI = P.Nodes.Count
ReDim PUNTI(1 To QUANTI_PUNTI, 1 To 2)
For K = 1 To QUANTI_PUNTI
'Stop
PT_COORD = P.Nodes(K).Points
PUNTI(K, 1) = PT_COORD(1, 1)
PUNTI(K, 2) = PT_COORD(1, 2)
Next
MAPPA_SHAPES = PUNTI
GoTo FINE
NO_PUNTI:
MAPPA_SHAPES = Null
FINE:
On Error GoTo 0
Set P = Nothing
End Function
Sub conta_shapes()
Dim QUANTE_FORME As Integer
Dim LISTA_SHAPES() 'questo sarà l'elenco delle forme presenti
QUANTE_FORME = ActiveSheet.Shapes.Count
'Questo ci fornisce il numero di forme presenti nel foglio
'Una volta noto il numero di forme, provvediamo a ridimensionare l'elenco alla bisogna:
ReDim LISTA_SHAPES(1 To QUANTE_FORME)
' (tante righe quante servono)
TROVATE = 0
For F = 1 To QUANTE_FORME
If ActiveSheet.Shapes(F).Type = msoLine Or ActiveSheet.Shapes(F).Type = msoFreeform Then
TROVATE = TROVATE + 1
LISTA_SHAPES(TROVATE) = ActiveSheet.Shapes(F).Name
End If
Next
'Stop
ReDim Preserve LISTA_SHAPES(1 To TROVATE)
RIGA_INIZIO = 1 'SUPPONIAMO CHE LA TABELLA INIZI IN CELLA E2 (METTO 1 PER RAGIONI DI "GESTIONE" DEL CICLO SEGUENTE)
COL_INIZIO = 5
For R = 1 To TROVATE
PUNTI = MAPPA_SHAPES(LISTA_SHAPES(R))
Cells(RIGA_INIZIO + R, COL_INIZIO).Formula = LISTA_SHAPES(R)
If IsArray(PUNTI) = True Then
' Stop
SPOST = 1 ' questo è un offset che fa in modo di stampare su un medesima riga del foglio
' di calcolo le coordinate x-y di tutti i punti.
For X = 1 To UBound(PUNTI, 1) 'Restituisce il numero di righe di PUNTI
For Q = 1 To UBound(PUNTI, 2) 'Restituisce il numero di colonne di PUNTI
Cells(RIGA_INIZIO + R, COL_INIZIO + SPOST).Formula = PUNTI(X, Q)
SPOST = SPOST + 1
Next
Next
End If
Next
End Sub
Sub ReverseMap()
Dim Nodo As ShapeNode
'
Forman = "pippolo" '<<<
'
For Each Nodo In Sheets("Foglio3").Shapes(Forman).Nodes
[K10].Offset(i, 0) = Nodo.Points(1, 1)
[K10].Offset(i, 1) = Nodo.Points(1, 2)
i = i + 1
Next Nodo
End Sub
Torna a Applicazioni Office Windows
Inserire add.in nella barra di avvio veloce in excel 2003 Autore: Ricky0185 |
Forum: Applicazioni Office Windows Risposte: 4 |
Excel: problema con date se devo unirle a testi Autore: valle1975 |
Forum: Applicazioni Office Windows Risposte: 5 |
confrontare e evidenziare 2 fogli excel Autore: niccia |
Forum: Applicazioni Office Windows Risposte: 7 |
[EXCEL] controllo corrispondenza tra valori con un vincolo Autore: sbs |
Forum: Applicazioni Office Windows Risposte: 9 |
Visitano il forum: Nessuno e 20 ospiti