Açı gösterimi

[Turguttnc]

Arkadaşlar selam,
Aşağıdaki sayfa kodu olarak oluşturulmuş makrodaki A2 girişini "InputBox" olarak değiştirmek istedim ama konulara hakim değilim.
Hücre girişi değil de Inputbox olarak , bir butona bağlı olarak çalıştırmamız gerekiyor.

Bir diğer konu da sayfa sürekli yatay sağa doğru ilerliyor fakat bu kod çalışında oluşan açı her zaman sayfa başında kalıyor.
Son dolu hücre yakınlarında görünür bir noktada oluşturmak da mümkün mü ?

Bir lise öğrencisinin trigonometrik hesaplarında görsel yardımı olan bir kod , yardımcı olursanız sevinirim.

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim sh As Shape, shLeft As Single, shTop As Single, shRadius As Single, Theta As Single
        
    ' Set parameters
    shLeft = 50
    shTop = 200
    shRadius = 300
    
    ' Read in Theta
    Theta = -45 ' Default setting
    On Error Resume Next
    Theta = Range("A2").Value * -1
    On Error GoTo 0

    ' Delete all existing shapes
    For Each sh In Shapes
         sh.Delete
    Next

    ' Draw current sshape
    With Shapes.AddShape(msoShapePie, shLeft, shTop, shRadius, shRadius)
        .Fill.Visible = msoFalse
        .Adjustments(1) = Theta
        .Adjustments(2) = 0
        .Line.Visible = msoTrue
        .LockAspectRatio = msoTrue
        .Line.ForeColor.RGB = RGB(35, 35, 35)
        .Line.Weight = 1
    End With

End Sub

 

[Muzaffer Ali]

Merhaba.

Sub SekilCiz()
    Dim sh As Shape, shLeft As Single, shTop As Single, shRadius As Single, Theta As Single
    Dim Deger As String
    
    ' Set parameters
    shLeft = 50
    shTop = 200
    shRadius = 300
    
    ' Read in Theta
    Theta = -45 ' Default setting

1:
    Deger = InputBox("Lütfen bir rakam giriniz.")
    If Not IsNumeric(Deger) Then
        MsgBox "Lütfen bir rakam giriniz."
        GoTo 1
    End If
    Theta = Deger * -1


    ' Delete all existing shapes
    For Each sh In Shapes
         sh.Delete
    Next

    ' Draw current sshape
    With Shapes.AddShape(msoShapePie, shLeft, shTop, shRadius, shRadius)
        .Fill.Visible = msoFalse
        .Adjustments(1) = Theta
        .Adjustments(2) = 0
        .Line.Visible = msoTrue
        .LockAspectRatio = msoTrue
        .Line.ForeColor.RGB = RGB(35, 35, 35)
        .Line.Weight = 1
    End With

End Sub

 

[Turguttnc]

Teşekkür ederim , fakat ;
For Each sh In Shapes satırında hata veriyor.

 

[Muzaffer Ali]

Bunu deneyin.

Sub SekilCiz()
    Dim sh As Shape, shLeft As Single, shTop As Single, shRadius As Single, Theta As Single
    Dim Deger As String
    
    ' Set parameters
    shLeft = 50
    shTop = 200
    shRadius = 300
    
    ' Read in Theta
    Theta = -45 ' Default setting

1:
    Deger = InputBox("Lütfen bir rakam giriniz.")
    If Not IsNumeric(Deger) Then
        MsgBox "Lütfen bir rakam giriniz."
        GoTo 1
    End If
    Theta = Deger * -1


    ' Delete all existing shapes
    If Shapes.Count > 0 Then
        For Each sh In Shapes
             sh.Delete
        Next
    End If
    
    ' Draw current sshape
    With Shapes.AddShape(msoShapePie, shLeft, shTop, shRadius, shRadius)
        .Fill.Visible = msoFalse
        .Adjustments(1) = Theta
        .Adjustments(2) = 0
        .Line.Visible = msoTrue
        .LockAspectRatio = msoTrue
        .Line.ForeColor.RGB = RGB(35, 35, 35)
        .Line.Weight = 1
    End With

End Sub

 

[Turguttnc]

Bunu deneyin.

Sub SekilCiz()
    Dim sh As Shape, shLeft As Single, shTop As Single, shRadius As Single, Theta As Single
    Dim Deger As String
   
    ' Set parameters
    shLeft = 50
    shTop = 200
    shRadius = 300
   
    ' Read in Theta
    Theta = -45 ' Default setting

1:
    Deger = InputBox("Lütfen bir rakam giriniz.")
    If Not IsNumeric(Deger) Then
        MsgBox "Lütfen bir rakam giriniz."
        GoTo 1
    End If
    Theta = Deger * -1


    ' Delete all existing shapes
    If Shapes.Count > 0 Then
        For Each sh In Shapes
             sh.Delete
        Next
    End If
   
    ' Draw current sshape
    With Shapes.AddShape(msoShapePie, shLeft, shTop, shRadius, shRadius)
        .Fill.Visible = msoFalse
        .Adjustments(1) = Theta
        .Adjustments(2) = 0
        .Line.Visible = msoTrue
        .LockAspectRatio = msoTrue
        .Line.ForeColor.RGB = RGB(35, 35, 35)
        .Line.Weight = 1
    End With

End Sub

Şimdi de
If Shapes.Count > 0 Then
Satırında sorun çıkarıyor.

 

[Muzaffer Ali]

Dosyanızı paylaşır mısınız kontrol edeyim.
Dosyanızı dosya.tc gibi bir sitede paylaşabilirsiniz.

 

[Turguttnc]

Dosyanızı paylaşır mısınız kontrol edeyim.
Dosyanızı dosya.tc gibi bir sitede paylaşabilirsiniz.

Dosyanın kendi boyutunu kabul etmediği için mevcut çalıştığı halin örneğini paylaştım.
Dediğim üzere A1 hücresine veri girilen şekil fakat hem hata veren kısmını hem de şekli sürekli mevcut konumda oluşturduğu için konum ayarlamasını yapamıyoruz.
Yani sayfa AB2 sütununa gelmiş ilerleyerek ama şekil hala paylaştığım dosyadaki konumda oluşuyor. Sayfa ilerlemesine paralel görünün yerde oluşmuyor ki yukarıda ilk mesajda bahsettiğim üzere bu da bir sorun.

https://dosya.co/hiy49gzlai8r/Açı.xlsm.html

 

[Muzaffer Ali]

Butona tıkladığınızda 2. satırın son hücresine göre şekil çizilecektir.
Farklı bir satıra göre konumlandırmak isterseniz aşağıdaki satırdaki 2 yerine istediğiniz satır numarasını yazabilirsiniz.

shLeft = Cells(2, Columns.Count).End(xlToLeft).Left

https://dosya.co/w1sm22xs43dv/Açı.xlsm.html

 

[Turguttnc]

Butona tıkladığınızda 2. satırın son hücresine göre şekil çizilecektir.
Farklı bir satıra göre konumlandırmak isterseniz aşağıdaki satırdaki 2 yerine istediğiniz satır numarasını yazabilirsiniz.

shLeft = Cells(2, Columns.Count).End(xlToLeft).Left

https://dosya.co/w1sm22xs43dv/Açı.xlsm.html

İlginiz için ve ayrıca bilgilendirme için de ayrıca çok teşekkür ederim .

İyi çalışmalar dilerim.