• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

EXCEL VBA İLE GEOMETRİK DESEN ÇİZİLEBİLİR Mİ

U

unalmetin

Katılım
12 Kasım 2019
Mesajlar
7
Excel Vers. ve Dili
excel 2010 türkçe
Arkadaşlar herkese merhaba, bir sorum olacak .excel vba ile geometrik desenler çizdirebilir miyiz. selçuklu yıldızı desenine benzeyen desenler çizilebilir mi. Desen çapı, kol genişliği vs. ölçüleri bizden isteyecek ve deseni çizebilecek. Bilen arkadaşlar cevap verirlerse çok sevinirim. Şimdiden ilginize teşekkür ederim.
 
Kod: 
Sub DrawSelcukluStar()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
    
    Dim diameter As Double
    Dim armWidth As Double
    Dim centerX As Double
    Dim centerY As Double
  
    diameter = Application.InputBox("Desenin çapını girin:", Type:=1)
    armWidth = Application.InputBox("Kol genişliğini girin:", Type:=1)
    
    centerX = ws.Cells(1, 1).Width + diameter / 2
    centerY = ws.Cells(1, 1).Height + diameter / 2
  
    ws.Shapes.SelectAll
    Selection.Delete
  
    Dim i As Integer
    Dim angle As Double
    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
    Dim outerRadius As Double, innerRadius As Double
    
    outerRadius = diameter / 2
    innerRadius = (outerRadius - armWidth) / 2
    
    For i = 0 To 7
        angle = i * 45 * WorksheetFunction.Pi / 180
        x1 = centerX + outerRadius * Cos(angle)
        y1 = centerY - outerRadius * Sin(angle)
        x2 = centerX + innerRadius * Cos(angle + 22.5 * WorksheetFunction.Pi / 180)
        y2 = centerY - innerRadius * Sin(angle + 22.5 * WorksheetFunction.Pi / 180)
      
        ws.Shapes.AddLine centerX, centerY, x1, y1
        ws.Shapes.AddLine x1, y1, x2, y2
    Next i
  
    ws.Shapes.AddShape msoShapeOval, centerX - innerRadius, centerY - innerRadius, 2 * innerRadius, 2 * innerRadius
    
End Sub

Bu kod, Selçuklu yıldızının sekiz köşesini çizer. Kullanıcıdan alınan çap ve kol genişliği bilgileri ile deseni çizer. VBA kodu temel geometrik hesaplamalar kullanarak her bir kolun başlangıç ve bitiş noktalarını belirler ve ardından bunları çizer.

İlk değer 250 yazdım sonraki değer 75 yazdım deseni çizdi.Denermisiniz
 
Merhaba.

Alternatif

Kod: 
Sub Yildiz_Ciz()
    Dim Cap As Integer
    Cap = InputBox("Çap belirtiniz.", vbExclamation)
    ActiveSheet.Shapes.AddShape(msoShape8pointStar, 50, 50, Cap, Cap).Select
End Sub
 
muhasebeciyiz' Alıntı:
Kod: 
Sub DrawSelcukluStar()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
   
    Dim diameter As Double
    Dim armWidth As Double
    Dim centerX As Double
    Dim centerY As Double
 
    diameter = Application.InputBox("Desenin çapını girin:", Type:=1)
    armWidth = Application.InputBox("Kol genişliğini girin:", Type:=1)
   
    centerX = ws.Cells(1, 1).Width + diameter / 2
    centerY = ws.Cells(1, 1).Height + diameter / 2
 
    ws.Shapes.SelectAll
    Selection.Delete
 
    Dim i As Integer
    Dim angle As Double
    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
    Dim outerRadius As Double, innerRadius As Double
   
    outerRadius = diameter / 2
    innerRadius = (outerRadius - armWidth) / 2
   
    For i = 0 To 7
        angle = i * 45 * WorksheetFunction.Pi / 180
        x1 = centerX + outerRadius * Cos(angle)
        y1 = centerY - outerRadius * Sin(angle)
        x2 = centerX + innerRadius * Cos(angle + 22.5 * WorksheetFunction.Pi / 180)
        y2 = centerY - innerRadius * Sin(angle + 22.5 * WorksheetFunction.Pi / 180)
     
        ws.Shapes.AddLine centerX, centerY, x1, y1
        ws.Shapes.AddLine x1, y1, x2, y2
    Next i
 
    ws.Shapes.AddShape msoShapeOval, centerX - innerRadius, centerY - innerRadius, 2 * innerRadius, 2 * innerRadius
   
End Sub

Bu kod, Selçuklu yıldızının sekiz köşesini çizer. Kullanıcıdan alınan çap ve kol genişliği bilgileri ile deseni çizer. VBA kodu temel geometrik hesaplamalar kullanarak her bir kolun başlangıç ve bitiş noktalarını belirler ve ardından bunları çizer.

İlk değer 250 yazdım sonraki değer 75 yazdım deseni çizdi. Denermisiniz
Genişletmek için tıkla ...
Sayın muhasebeciyiz arkadaşım cevabınız için çok teşekkür ederim. Bakacağım çizime
 
muhasebeciyiz' Alıntı:
Kod: 
Sub DrawSelcukluStar()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1)
   
    Dim diameter As Double
    Dim armWidth As Double
    Dim centerX As Double
    Dim centerY As Double
 
    diameter = Application.InputBox("Desenin çapını girin:", Type:=1)
    armWidth = Application.InputBox("Kol genişliğini girin:", Type:=1)
   
    centerX = ws.Cells(1, 1).Width + diameter / 2
    centerY = ws.Cells(1, 1).Height + diameter / 2
 
    ws.Shapes.SelectAll
    Selection.Delete
 
    Dim i As Integer
    Dim angle As Double
    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
    Dim outerRadius As Double, innerRadius As Double
   
    outerRadius = diameter / 2
    innerRadius = (outerRadius - armWidth) / 2
   
    For i = 0 To 7
        angle = i * 45 * WorksheetFunction.Pi / 180
        x1 = centerX + outerRadius * Cos(angle)
        y1 = centerY - outerRadius * Sin(angle)
        x2 = centerX + innerRadius * Cos(angle + 22.5 * WorksheetFunction.Pi / 180)
        y2 = centerY - innerRadius * Sin(angle + 22.5 * WorksheetFunction.Pi / 180)
     
        ws.Shapes.AddLine centerX, centerY, x1, y1
        ws.Shapes.AddLine x1, y1, x2, y2
    Next i
 
    ws.Shapes.AddShape msoShapeOval, centerX - innerRadius, centerY - innerRadius, 2 * innerRadius, 2 * innerRadius
   
End Sub

Bu kod, Selçuklu yıldızının sekiz köşesini çizer. Kullanıcıdan alınan çap ve kol genişliği bilgileri ile deseni çizer. VBA kodu temel geometrik hesaplamalar kullanarak her bir kolun başlangıç ve bitiş noktalarını belirler ve ardından bunları çizer.

İlk değer 250 yazdım sonraki değer 75 yazdım deseni çizdi. Denermisiniz
Genişletmek için tıkla ...
Sayın muhasebeciyiz Arkadaşım zaman ayırdığınız için çok teşekkür ederim. Evet çizim yapıyor. Fakat benim dediğim desen tam olarak bu değil. sayfaya resim linkini eklemeye çalışayım. https://resimlink.com/EjhsQe1B4t
 
Zihninize sağlık Korhan Hocam,
Harika bir çalışma. Bravo, tebrikler ...
 
Muzaffer Ali' Alıntı:
Buraya eklediğiniz resmi kulansanız olmaz mı?
Sadece en boy oranı ayarlaması yapılır ve daha hızlı bir sonuç elde edilir.
Genişletmek için tıkla ...
Muzaffer Ali hocam size ve diğer cevap yazan bütün arkadaşlarımıza teşekkür ederim cevaplarınız için. Ben VBA bilmediğim için bir proje düşünmüştüm. excel de desen çizdirip Autocad programına dxf olarak göndersin ya da direk Autocad içine çizebilsin şeklinde düşünüyordum. Verilen cevaplardan her türlü çizimin excel vba ile çizilebileceğini anladım.
 
Son düzenleme:
Sayın Korhan Ayhan Hocam,
Ben de hatırlamanız için yazmıştım. Konu 20 sene öncesine ait.
Saygılarımla
 
Windows gdi/gdiplus ile form üzerine veya virtual bitmap üzerine çizilerek diske kaydedilebilir. VBA uyarlamasını iki defa başlayıp zaman problemi nedeniyle devamını getiremedim. Umarım bir gün yine başlayıp devamını getiririm. Zira kapsamlı bir konu...

.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst