Saako excelin piirtämään?

Katselehan niitä Lisää/Muodot -valikon juttuja sillä silmällä illan hämärryttyä.

Kyllä pystyy piirtämään kuvioilla sekä viivoilla täysin parametrisesti ja lisäämään teksturit kanssa.
Itse olen tehnyt parit kalusteiden suunnitteluohjelmat, joissa piirretään parametreillä.
Lisätään esim. komeron aukkoihin erilaisia objekteja kuten hyllyjä, laatikoita, koreja ja erilaisia settejä yms ja ohjelma tekee myös tarvittavat CNC koodit komeronosille. Eli täysi paketti tilauksesta tuotantoon... ;-)

Keep EXCELing
@Kunde

Laitoin malliksi hieman muitakin juttuja, mitä voi hyödyntää. On toki paljon muitakin vielä. Itsellä oli tarve lisätä paljon attribuuttitietoa (mm poraukset) ja Excelissä ei semmoista ole objekteilla mutta aika kivuttomasti se tollainkin meni...
Tein myöhemmin sitten treeviewllä yksinkertaisen rakennepuun, missä osia pystyy muokkaaman vapaasti.
APIlla sitten lomakkeellaoli helpompaa fiksailla kaikkea ja näkee piirron kanssa samalla, mutta ihan toimiva juttu ja todistaa sen, että EXCEL taipuu moniin juttuihin, mihin sitä ei le alunperin edes tarkoitettu ;-)

Sub Suorakaide(X As Double, Y As Double, Leveys As Double, Korkeus As Double)
Dim a
Dim xlShp As Shape
Worksheets(1).Activate

'soluun kiinnitettynä
Set xlShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, ActiveSheet.Range("C10").Left, ActiveSheet.Range("c10").Top, Leveys, Korkeus)
'vasemmasta yläkulmasta lähtien
'Set xlShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, X, Y, Leveys, Korkeus)

With xlShp
.Name = "Kundenmalli"
'tässä voi lisätä atribuuttitietoja vaihtoehtoinen teksti attribuuttiin, josta voi lukea sitten kätevästi tuotteen tietoja tai indoa
.AlternativeText = .Name & "," & Korkeus & "," & Leveys & ",Tammi"
'tässä voi kätevästi näyttää tuotteen tiedot hyperlinkillä kun hiirellä siirtyy kuvion päälle
a = Split(.AlternativeText, ",")
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Shapes(.Name), Address:="", ScreenTip:="Osan nimi: " & a(0) & vbNewLine & "Korkeus: " & a(1) & vbNewLine & "Leveys: " & a(2) & vbNewLine & "Väri: " & a(3)

'tässä voi lisätä materiaalin tai värin
' .Fill.UserPicture ThisWorkbook.Path & "\" & "Tammi.jpg"
.Line.Visible = msoTrue
.Line.Weight = 0
End With
'viiva
Set xlShp = ActiveSheet.Shapes.AddLine(ActiveSheet.Shapes("Kundenmalli").Left ActiveSheet.Shapes("Kundenmalli").Width, ActiveSheet.Shapes("Kundenmalli").Top ActiveSheet.Shapes("Kundenmalli").Height, 500, 500)
xlShp.Select
xlShp.Name = "Viiva"

End Sub
Sub Koe()
'tiedot voi hakea solustakin
'Suorakaide Range("A1"), Range)"B1"), Range("C1"), Range("D1")
Suorakaide 100, 100, 100, 500
End Sub

Keep EXCELing
@Kunde

Oikeastihan vektorille annetaan suuntakulma ja pituus
Voin tehdä makron tommoselle jos haluat... ;-)
Jos haluat jotain muutakin, niin kerro ja lisätään sitten makroon


Function Viiva1(x As Double, y As Double) As Double
Dim xlShp As Shape
Set xlShp = ActiveSheet.Shapes.AddLine(ActiveSheet.Range("P18").Left, ActiveSheet.Range("P18").Top, x, y)
xlShp.Line.BeginArrowheadStyle = msoArrowheadNone
xlShp.Line.EndArrowheadStyle = msoArrowheadStealth
End Function

ActiveSheet.Shapes("Kundenmalli").Delete

Keep EXCEling
@Kunde

tavalliseen moduuliin...
Option Explicit

Sub Poista()
Dim Shp As Shape
On Error Resume Next
For Each Shp In ActiveSheet.Shapes
Shp.Delete
Next Shp
End Sub

Sub PiirräVektori()
Poista
Dim Vektori1 As New ClsVektori
With Vektori1
'jos käytät muuta kuin Vektoriluokan oletusta aloituspisteelle, niin hipsaa allaolevat 2 riviä...
' .x1 = ActiveSheet.Range("P18").Left
' .y1 = ActiveSheet.Range("P18").Top
' pituus
.Pituus = Range("A1").Value
' kulma
.Kulma = Range("A2").Value
' skalaari
.Skalaari = 10
.Nimi = "Vektori1"
.Piirrä
End With
End Sub
lisää luokka moduuli ja nimeä se ClsVektori ja lisää allaoleva koodi sinne
Oletuksia voi lisätä ja ominaisuuksia lisäillä tarpeen mukaan

Option Explicit
Public x1 As Double
Public y1 As Double
Public Kulma As Double
Public Pituus As Double
Public Skalaari As Double
Public Viivanväri As Integer
Public Viivanpaksuus As Double
Public Nimi As String
Public Pi As Double
Private Sub Class_Initialize()
' oletusarvoja
x1 = 200
y1 = 200
Kulma = 0
Pituus = 10
Skalaari = 1
Pi = 3.14159265358979
Viivanväri = 8
Viivanpaksuus = 1
End Sub

Private Function Rad(Asteet As Double) As Double
Rad = Asteet * Pi / 180
End Function
Function x2() As Double
x2 = x1 Pituus * Sin(Rad(Kulma)) * Skalaari
End Function

Function y2() As Double
y2 = y1 - Pituus * Cos(Rad(Kulma)) * Skalaari
End Function
Sub Piirrä()
With ActiveSheet.Shapes.AddLine(x1, y1, x2, y2)
.Name = Nimi
.Line.EndArrowheadStyle = msoArrowheadStealth
.Line.BeginArrowheadStyle = msoArrowheadNone
.Line.ForeColor.SchemeColor = Viivanväri
.Line.Weight = Viivanpaksuus
End With
End Sub

Keep EXCELing
@Kunde

Riippuu siitä miten olet koodin tehnyt.
Jos et halua poistaa jo tehtyä vektoreita hipsaa moduulin koodissa poista funktion kutsu tai nimeä nimeä vektorit siten, että niitä on helppo hallita, lisäämällä eteen vaikka jonkun erikoismerkin (esimerkkikoodissa @- merkki eteen)...
Funktiot voi käsitellä useampia vektoreita kerrallaan. En tiedä mitä haluat tehdä ja minkälainen on taulukkosi, joten koodi vain ihan peruspiirtoon. Jos haluat laskea vektoreita yhteen laskea vektoreiden välisiä kulmia yms. , niin clsVektori moduulissa vaan lisätään ominaisuuksia vektoreille ja hiukkasen matematiikkaa... ;-)

Sub Poista()
Dim Shp As Shape
On Error Resume Next
For Each Shp In ActiveSheet.Shapes
If Not Shp.Name Like "@*" Then Shp.Delete
Next Shp
End Sub

Keep EXCELing
@Kunde

lähetä taulukko hmetso(at)hotmail.com ja mallia mitä haluat, niin voin vilkaista ja kertoa tarkemmin