Excel'de çizim yapma.(CM olarak)

[ottoman71]

Merhaba Arkadaşlar,

Excelde makro ile çizim yaptırabilirmiyiz.
Örneğin bir çizgi tanımladık. Bu çizgi bir birim uzunluğunda. Çiz butonuna tıkladığımızda kaç birim olduğunu soran bir inputbox çıkacak ve bu inputbox 5 yazdığımızda bize 5 birim uzunluğunda çizgi çizecek.

Başka bir şey çizdirecek olursak,

Dikdörtgeni ele alalım. Biraz önce tanımlamış olduğumuz 1 birim uzunluk üzerinden devam edelim; 5 birime 8 birimlik bir dikdörtgen çizdireceğiz.Yine inputbox çıkacak bize en ve boy soracak.

Yardımcı olursanız sevinirim.

İyi çalışmalar.

 

[hamitcan]

Sub CmOlarakSekilCizme()
    Dim g As Double, y As Double
    Dim myDocument As Worksheet
    Sayfa1.Rectangles.Delete
    g = InputBox("Ondalık Kısmında Nokta '.' Karakterini Kullanın", "Genişliği Cm Olarak Girin")
    y = InputBox("Ondalık Kısmında Nokta '.' Karakterini Kullanın", "Yüksekliği Cm Olarak Girin")
    Set myDocument = Worksheets(1)
    myDocument.Shapes.AddShape msoShapeRectangle, 0, 0, (g * 72 / 2.54), (y * 72 / 2.54)
End Sub

Not:1 piksel 72dpi çözünürlükte 2.54/72cm olarak alınmıştır.
Kaynak:http://www.autocadokulu.com/t8830-photoshop-piksel-ve-cm.html

 

[ottoman71]

Sub CmOlarakSekilCizme()
    Dim g As Double, y As Double
    Dim myDocument As Worksheet
    Sayfa1.Rectangles.Delete
    g = InputBox("Ondalık Kısmında Nokta '.' Karakterini Kullanın", "Genişliği Cm Olarak Girin")
    y = InputBox("Ondalık Kısmında Nokta '.' Karakterini Kullanın", "Yüksekliği Cm Olarak Girin")
    Set myDocument = Worksheets(1)
    myDocument.Shapes.AddShape msoShapeRectangle, 0, 0, (g * 72 / 2.54), (y * 72 / 2.54)
End Sub

Not:1 piksel 72dpi çözünürlükte 2.54/72cm olarak alınmıştır.
Kaynak:http://www.autocadokulu.com/t8830-photoshop-piksel-ve-cm.html

Teşekkur ederim. Çok makbule geçti.

 

[şiraz1]

sn hamitcan
bu kodun sonucunda oluşan şekillerin üzerine ınputbox değerlerini yazdırabilirmiyiz bu konuda bana yardımcı olurmusunuz

 

[hamitcan]

Sub CmOlarakSekilCizme()
    Dim g As Double, y As Double
    Dim myDocument As Worksheet
    Sayfa1.Rectangles.Delete
    g = InputBox("Ondalık Kısmında Nokta '.' Karakterini Kullanın", "Genişliği Cm Olarak Girin")
    y = InputBox("Ondalık Kısmında Nokta '.' Karakterini Kullanın", "Yüksekliği Cm Olarak Girin")
    Set myDocument = Worksheets(1)
    myDocument.Shapes.AddShape msoShapeRectangle, 0, 0, (g * 72 / 2.54), (y * 72 / 2.54)
    myDocument.Shapes(1).TextFrame.Characters.Text = "Genişlik :" & g & Chr(10) & "Yükseklik :" & y
End Sub

şeklinde deneyin.

 

[şiraz1]

ilgilendiğiniz için teşkkürler

ancak bi yerde eksiklik var örneğin ınputboxlar a değerleri giriyorum ancak daha önceden oluşturmuş olduğum şekillerden birisini değiştiriyor ve üzerlerine bu değerleri getiriyor ve aynı zamanda boş bir şekil yani üzerinde hiçbir ölçü değerleri olmayan şekil çıkartıyor ancak ben farklı farklı değerler girdiğimde birbirinden bağımsız üzerlerine yazması gerekiyor aslında amacım şöyle :ürünlerimizin balya boyutlarına göre şekiller oluşturuyorum ve bu oluşan şekilleri bir sefere mahsus kaydediyorum bu şekiller sayesinde yükleme planı oluşturuyorum bu iş benim işimi müthiş bi şekilde kolaylaştırıyor cad kullanmadan excellde bu işi halledebiliyorum lütfen yardımcı olurmusunuz bu arada bulduğunuz kod ile cadi ortadan kaldırdınız mükemmel tebrik ediyorum umarım anlatabilmişimdir

 

[hamitcan]

Bir dosya ekleyin.

 

[şiraz1]

Eklemey çalıştım inşallah ekleyebilmişimdir ekteki dosyada yükleme sayfasından bir buton yardımıyla yeniölçü eklemeye çalışıyorum ve eklediğim her yeni eklenen şekil ölçüler sayfasına geliyor fakat bahsettiğimiz en boy yazdırmayı yeni eklenene değil daha önceden eklenmiş olana yazıyor sorun bu? teşekkürler

 

[hamitcan]

Bir örnek ile açıklarsanız daha iyi olacak. Bir sayfadan diğer bir sayfaya şekil mi kopyalamak istiyorsunuz yoksa yeni bir şekil mi çıkartmak istiyorsunuz yada ölçüler sayfasında verilen ölçülere göre bir şekil mi oluşturmak istiyor sunuz ?

 

[şiraz1]

yükleme sayfasından yeni ölçü butonu ile birlikte girilen değerlere göre ölçüler sayfasına oluşturulan ölçünün gelmesini istiyorum ancak oluşturulan ölçünün üzerinde girdiğim değerlerin yazmasını istiyorum ör:en:100 boy:170 adet:250 vb. size gönderdiğim dosyada bunu yapmak istediğimde ölçüler dosyasında hep aynı şeklin üzerine bu değerleri getiriyor ve bunun yanında değerleri girilmiş ve şekli oluşmuş ancak üzerinde yazmasını istediğim bilgiler yok her yeni ölçüyü eklediğimde ayrı yani diğerinden bağımsız ve bir kere girdiğim değerler ayrı bi şekilde sabit kalsın istiyorum ölçüler sayfasında oluşturduğum şunu yapmaya çalışıorum ölçüler sayfasında sabit oluşturulmuş şekilleri yükleme sayfasına taşıyacağım yükleme sayfasındaki şekilleri tır olarak kabul edersek bir yükleme şekli ortaya çıkmış oluyor aslında daha faklı bir yolda izlenebilrdi eğer güzel fikirleriniz de varsa lütfen bekliyorum amacım mümkün olduğunca bu yükleme sayfasını en mükemmel hale getirmek istiyorum ki biz bu yüklemeleri her hafta değişik şekillerde yapıoruz ama önce yeni ölçü oluşturma konusundaki sıkıntımı giderebilirseniz minnettar kalırım şimdiden teşekkürler....

 

[hamitcan]

Sub CmOlarakSekilCizme2()
    Dim g As Double, y As Double
    Dim myDocument As Worksheet
'    Sayfa1.Rectangles.Delete
    g = InputBox("Ondalık Kısmında Nokta '.' Karakterini Kullanın", "Genişliği Cm Olarak Girin")
    y = InputBox("Ondalık Kısmında Nokta '.' Karakterini Kullanın", "Yüksekliği Cm Olarak Girin")
    Set myDocument = Worksheets(1)
    On Error Resume Next
    Z = myDocument.Shapes(myDocument.Shapes.Count).Width + myDocument.Shapes(myDocument.Shapes.Count).Left + 20
    myDocument.Shapes.AddShape msoShapeRectangle, Z, 0, (g * 72 / 2.54), (y * 72 / 2.54)
    myDocument.Shapes(myDocument.Shapes.Count).TextFrame.Characters.Text = "Genişlik :" & g & Chr(10) & "Yükseklik :" & y
End Sub

böyle deneyin.

 

[şiraz1]

Emeğine sağlık sizide çok uğraştırdım son bir istirhamım daha olacak tabi mümkünse yazı karakterleri ile ilgili ve bu yazıyı şeklin içinde hizalayabileceğim kodlarda varsa gerçekten harika olur çok teşekkür ediyorum saolun

 

[hamitcan]

Yazıları büyütmek mi yoksa sağa-sola hizalatmak mı istiyor sunuz ?

 

[hamitcan]

Yazıların boyutunu bu şekilde değiştirebiliyorsunuz ama eni dar olduğunda yazılar bozuluyor. Bu yüzden çok sağlıklı olmadı açıkcası.

Sub CmOlarakSekilCizme3()
    Dim g As Double, y As Double, z As Double
    Dim myDocument As Worksheet
    g = InputBox("Ondalık Kısmında Nokta '.' Karakterini Kullanın", "Genişliği Cm Olarak Girin")
    y = InputBox("Ondalık Kısmında Nokta '.' Karakterini Kullanın", "Yüksekliği Cm Olarak Girin")
    Set myDocument = Worksheets(1)
On Error Resume Next
With myDocument
    z = .Shapes(.Shapes.Count).Width + .Shapes(.Shapes.Count).Left + 20
        .Shapes.AddShape msoShapeRectangle, z, 0, (g * 72 / 2.54), (y * 72 / 2.54)
        .Shapes(.Shapes.Count).TextFrame.Characters.Text = "Gen :" & g & Chr(10) & "Yük :" & y
        [COLOR=RED].Shapes(.Shapes.Count).TextFrame.Characters.Font.Size = g * y + 4[/COLOR]
End With
End Sub

 

[şiraz1]

sn hamitcan
son yazdığınız kodu denedim olmadı galiba yazının boyutunu değiştirmek istiyorum ama aynı zamanda şekil içinde bunu sağa sola hizalamasıda gerekir.
TEŞEKKÜRLER

 

[hamitcan]

sn hamitcan
son yazdığınız kodu denedim olmadı galiba yazının boyutunu değiştirmek istiyorum ama aynı zamanda şekil içinde bunu sağa sola hizalamasıda gerekir.
TEŞEKKÜRLER

Sorun tam olarak ne, eğer sorun yazıların görünmemesi ise son satırı değiştirebiliriz. Eğer sorun sadece bu ise sağa-sola yaslamakla düzeleceğini düşünmüyorum.

 

[şiraz1]

yazı fontunu değiştirmek ör:tahoma 12 italik şeklinde

 

[hamitcan]

Yazı tipi değiştirilebilir, ama boyutunu şeklin büyüklüğüne göre değiştirmek daha doğru bence.

 

[şiraz1]

evet haklısınız boyutları ayarlayabildim yardımlarınızdan dolayı çok teşekkür ediyorum

 

[şiraz1]

şekiller arası boşlukları gidermek

sn hamitcan size gönderdiğim son eklentide daha önceden ölçüler sayfasında oluşturduğum şekilleri yükleme sayfasına taşıyorum bu şekiller arasındaki boşlukları teker teker gidermek yerine acaba bir makro yardımıyla yapabilirmiyiz? şimdiden teşekkürler