desenare dreptunghiuri

dip
Mesaje: 168
Membru din: Sâm Feb 06, 2010 11:09 pm
Localitate: Brasov

desenare dreptunghiuri

Mesaj de dip » Mie Sep 19, 2018 2:06 pm

Buna ziua,
In fisierul atasat este scrisa o macrocomanda care deseneaza dreptunghiuri in functie de coordonatele X si Y din tabel.
1.Cum se rescrie macrocomanda folosind o instructiune for...next, ca sa treaca de la o inregistrare la alta, fara a fi nevoit sa scriu cod pentru fiecare rand (in realitate tabelul are zeci de inregistrari)?
2.Macrocomanda sa coloreze diferit dreptunghiul in functie de atributul din ultima coloana (pentru A o culoare, pentru B alta culoare).
Multumesc anticipat.

Cod: Selectaţi tot

Sub TRASEAZA()
'

    Sheets("grafic").Select
    Cells.Select
    Range("D1").Activate
    Selection.EntireRow.Hidden = False
    ActiveSheet.DrawingObjects.Select
    Selection.Delete
    Range("C3").Select
    
    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Range("C3").Value, Range("D3").Value, 90, 30).Select
    Application.CutCopyMode = False
    Selection.Formula = "=$B$3"
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    Selection.ShapeRange.TextFrame2.MarginLeft = 0
    Selection.ShapeRange.TextFrame2.MarginRight = 0
    Selection.ShapeRange.TextFrame2.MarginTop = 0
    Selection.ShapeRange.TextFrame2.MarginBottom = 0
    Selection.ShapeRange.Line.Weight = 2
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(20, 240, 20)
    
    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Range("C4").Value, Range("D4").Value, 90, 30).Select
    Application.CutCopyMode = False
    Selection.Formula = "=$B$4"
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    Selection.ShapeRange.TextFrame2.MarginLeft = 0
    Selection.ShapeRange.TextFrame2.MarginRight = 0
    Selection.ShapeRange.TextFrame2.MarginTop = 0
    Selection.ShapeRange.TextFrame2.MarginBottom = 0
    Selection.ShapeRange.Line.Weight = 2
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(20, 240, 20)
    
    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Range("C5").Value, Range("D5").Value, 90, 30).Select
    Application.CutCopyMode = False
    Selection.Formula = "=$B$5"
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    Selection.ShapeRange.TextFrame2.MarginLeft = 0
    Selection.ShapeRange.TextFrame2.MarginRight = 0
    Selection.ShapeRange.TextFrame2.MarginTop = 0
    Selection.ShapeRange.TextFrame2.MarginBottom = 0
    Selection.ShapeRange.Line.Weight = 2
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(20, 240, 20)
    
    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Range("C6").Value, Range("D6").Value, 90, 30).Select
    Application.CutCopyMode = False
    Selection.Formula = "=$B$6"
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    Selection.ShapeRange.TextFrame2.MarginLeft = 0
    Selection.ShapeRange.TextFrame2.MarginRight = 0
    Selection.ShapeRange.TextFrame2.MarginTop = 0
    Selection.ShapeRange.TextFrame2.MarginBottom = 0
    Selection.ShapeRange.Line.Weight = 2
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(20, 240, 20)
    
    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Range("C7").Value, Range("D7").Value, 90, 30).Select
    Application.CutCopyMode = False
    Selection.Formula = "=$B$7"
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    Selection.ShapeRange.TextFrame2.MarginLeft = 0
    Selection.ShapeRange.TextFrame2.MarginRight = 0
    Selection.ShapeRange.TextFrame2.MarginTop = 0
    Selection.ShapeRange.TextFrame2.MarginBottom = 0
    Selection.ShapeRange.Line.Weight = 2
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(20, 240, 20)

    Range("B2").Select
    MsgBox ("Gata!")
    
End Sub
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.

dip
Mesaje: 168
Membru din: Sâm Feb 06, 2010 11:09 pm
Localitate: Brasov

Re: desenare dreptunghiuri

Mesaj de dip » Mie Sep 19, 2018 9:48 pm

Cred c-am rezolvat:

Cod: Selectaţi tot

Sub deseneaza()
'

    Sheets("grafic").Select
    Cells.Select
    Range("D1").Activate
    Selection.EntireRow.Hidden = False
    ActiveSheet.DrawingObjects.Select
    Selection.Delete
    Range("C3").Select
    
For i = 3 To 210
    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Range("C" & i).Value, Range("D" & i).Value, 90, 10).Select
    Application.CutCopyMode = False
    Selection.Formula = "=$E$" & i
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    Selection.ShapeRange.TextFrame2.MarginLeft = 0
    Selection.ShapeRange.TextFrame2.MarginRight = 0
    Selection.ShapeRange.TextFrame2.MarginTop = 0
    Selection.ShapeRange.TextFrame2.MarginBottom = 0
    Selection.ShapeRange.Line.Weight = 2
    Selection.ShapeRange.Fill.ForeColor.SchemeColor = Range("F" & i).Value
Next

    Range("B2").Select
    MsgBox ("Gata!")
    
End Sub
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.

Dr.Windows
Site Admin
Site Admin
Mesaje: 4519
Membru din: Vin Iul 31, 2009 7:32 am

Re: desenare dreptunghiuri

Mesaj de Dr.Windows » Mie Sep 19, 2018 9:54 pm

Nu am verificat codul postat de tine dar probabil ca este corect, sau mai exact functional, pentru ca pot exista mai multe solutii.

Eu prefer varianta urmatoare: Pentru a putea executa un cod intr-o structura repetitiva, trebuie sa ma conving ca functioneaza cel putin 1 data. Asta inseamna ca as putea crea o procedura cu parametrii - astea se pot apela apoi "repetitiv".

Atunci am creat o procedura care deseneaza formele:

Cod: Selectaţi tot

Sub DeseneazaForma(CoordX As Double, CoordY As Double, strText As String, AtributCuloare As Double)
    Dim shp As Shape
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, CoordX, CoordY, 90, 30)
    Application.CutCopyMode = False
    shp.TextFrame.Characters.Text = strText
    shp.TextFrame.Characters.Font.ColorIndex = 0
    shp.TextFrame2.VerticalAnchor = msoAnchorMiddle
    shp.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    shp.TextFrame2.MarginLeft = 0
    shp.TextFrame2.MarginRight = 0
    shp.TextFrame2.MarginTop = 0
    shp.TextFrame2.MarginBottom = 0
    shp.Line.Weight = 2
    shp.Fill.ForeColor.RGB = AtributCuloare
End Sub

Asa pot testa procedura "independent" si apoi o pot include intr-o structura repetitiva cum este for... next

Cod: Selectaţi tot

Sub DeseneazaToateFormele()
    For r = 3 To 7
        DeseneazaForma Range("C" & r).Value, Range("D" & r).Value, Range("B" & r).Value, Range("E" & r).Value
    Next r
End Sub

Mai trebuiue doar poate ajutstat parametrul pentru culoare, unde eu am folosit codul culorilor (rgbYellow=65535, rgbRed=255, etc)
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.

dip
Mesaje: 168
Membru din: Sâm Feb 06, 2010 11:09 pm
Localitate: Brasov

Re: desenare dreptunghiuri

Mesaj de dip » Joi Sep 20, 2018 9:27 am

Mulţumesc, mai profesionist aşa!(rămâne să mă lămuresc cu exprimarea culorii printr-un singur număr întreg)

TudyBTH
Moderator
Moderator
Mesaje: 904
Membru din: Joi Feb 11, 2016 2:12 pm
Localitate: Cluj Napoca

Re: desenare dreptunghiuri

Mesaj de TudyBTH » Joi Sep 20, 2018 1:07 pm

Am invatat sa inotam in apa, ca pestii
Am invatat sa zburam in aer, ca pasarile
A ramas doar sa invatam sa traim pe Pamant, ca Oamenii.

Dr.Windows
Site Admin
Site Admin
Mesaje: 4519
Membru din: Vin Iul 31, 2009 7:32 am

Re: desenare dreptunghiuri

Mesaj de Dr.Windows » Sâm Sep 22, 2018 5:42 pm

Din pacate nu exista proprietatea ColorIndex pentru ForeColor.

Ce s-ar putea face in schimb, sa inlocuiesti in cod linia:

Cod: Selectaţi tot

shp.Fill.ForeColor.RGB = AtributCuloare
cu

Cod: Selectaţi tot

shp.Fill.ForeColor.SchemeColor=AtributCuloare

Situatie in care poti folosi pentru valorile AtributCuloare valorile intre 1 si 8. Poti incerca cu mai multe, dar de la 9 (care este NEGRU) in sus, Incepe sa reia aceleasi culori.

Sau, daca nu sunt suficiente cele 8 culori, poti folosi 3 coloane pentru atributul de culoare si atunci poti utiliza functia RGB (si linia initiala de cod) pentru a recompune culoarea folosind cele 3 culori de baza.

Dr.Windows
Site Admin
Site Admin
Mesaje: 4519
Membru din: Vin Iul 31, 2009 7:32 am

Re: desenare dreptunghiuri

Mesaj de Dr.Windows » Sâm Sep 22, 2018 5:56 pm

Sau... de "distractie"... poti folosi pe coloana Atribut doar o culoare de fundal care va fi preluata si pentru culoarea formei.
Situatie in care se modifica procedura care va crea formele:

Cod: Selectaţi tot

Sub DeseneazaForma2(CoordX As Double, CoordY As Double, strText As String, AtributCuloare As Range)
    Dim shp As Shape
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, CoordX, CoordY, 90, 30)
    Application.CutCopyMode = False
    shp.TextFrame.Characters.Text = strText
    shp.TextFrame.Characters.Font.ColorIndex = 0
    shp.TextFrame2.VerticalAnchor = msoAnchorMiddle
    shp.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    shp.TextFrame2.MarginLeft = 0
    shp.TextFrame2.MarginRight = 0
    shp.TextFrame2.MarginTop = 0
    shp.TextFrame2.MarginBottom = 0
    shp.Line.Weight = 2
    shp.Fill.ForeColor.RGB = AtributCuloare.Interior.Color
End Sub
si evident si "apelul" in bucla:

Cod: Selectaţi tot

Sub DeseneazaToateFormele2()
    For r = 3 To 7
        DeseneazaForma2 Range("C" & r).Value, Range("D" & r).Value, Range("B" & r).Value, Range("E" & r)
    Next r
End Sub
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.

dip
Mesaje: 168
Membru din: Sâm Feb 06, 2010 11:09 pm
Localitate: Brasov

Re: desenare dreptunghiuri

Mesaj de dip » Dum Sep 23, 2018 6:17 am

Imi trebuie niste culori mai deschise, o sa folosesc SchemeColor, am observat ca permite si alte nuante de culori in afara de cele 8 (pentru numere pana la 81).

dip
Mesaje: 168
Membru din: Sâm Feb 06, 2010 11:09 pm
Localitate: Brasov

Re: desenare dreptunghiuri

Mesaj de dip » Mie Oct 03, 2018 3:09 pm

Subiectul l-am deschis pentru a realiza fisierul atasat. Pe scurs (detalii mai multe sunt in fisier), macrocomenzile din fisier transpun niste date (despre trenuri in circulatie) dintr-o forma tabelara intr-o forma grafica.
Problema ramasa de rezolvat (daca se poate rezolva): trenurile care sunt in statii apropiate si pe acelasi sens sa fie desenate decalat pe verticala ca sa nu se suprapuna (si sa nu mai fiu nevoit sa le mut manual de fiecare data. Daca sunt in aceeasi statie problema e rezolvata cu o coloana ajutatoare DL in foaia GRAFIC).
Nu aveţi permisiunea de a vizualiza fişierele ataşate acestui mesaj.

Scrie răspuns

Înapoi la “Visual Basic for Application (VBA) cu Excel - Intrebari tehnice”