Forum

Excel'de Piyano ...
 
Bildirimler
Hepsini Temizle

Excel'de Piyano Çalmak

3 Yazılar
2 Üyeler
0 Reactions
1,050 Görüntüleme
(@Anonim)
Gönderiler: 0
Konu başlatıcı
 
Excel'de Piyano çalabilir ve kendi bestelerinizi yapabilirsiniz...  

 
[img] [/img]
 
■ Piyanomuzu hazırlamak için gereken kodlar:

Declare Function GetTickCount& Lib "kernel32" ()
Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub sil()
    Dim Sh As Worksheet, sha As Shape: Set Sh = ActiveSheet
    For Each sha In Sh.Shapes
    If sha.name Like "Button_*" Then sha.Delete
    Next sha
End Sub
Sub olustur()
    mr = "qazwsxedcrfvtgbyhnujmik,ol.p;/['"
    sil
    pos = 70: Application.ScreenUpdating = False
    For i = 1 To Len(mr)
    letter = Mid(mr, i, 1)
    'Select Case (i + 9) Mod 12
    Select Case i Mod 12
    Case 2, 4, 7, 9, 11
    Siyah pos + 1 - Range("a:a").Width / 2, letter
    Case Else
    Beyaz pos, letter
    pos = pos + Range("b:b").Width + 2
    End Select
    Next
    [a1].Select
End Sub

Sub Siyah(ByVal X As Long, ByVal name As String)
    With aralik([a1:a9], vbBlack, "", "Music")
    .name = "Button_" & name
    .Left = X: .Top = 60
    .ZOrder msoBringToFront
    End With
End Sub
Sub Beyaz(ByVal X As Long, ByVal name As String)
    With aralik([b1:b14], vbWhite, "", "Music")
    .name = "Button_" & name
    .Left = X: .Top = 60
    .ZOrder msoSendToBack
    End With
End Sub

Sub melodi1(): Speed = 150
    beeps "5 5 3jnybt tybtftdx2d", Speed: beeps "5 5 3jnybt tybtftdx2d", Speed
    beeps "5 5 nnnyc3 ct2j nyc2 ty2btff ftf2t", Speed: beeps "5 5 nnnyc3 ct2j nyc2 ty2btff ftf3 yb2t", Speed
End Sub
Sub melodi2(): Speed = 250
    beeps "jny3b3t5 5 jny3y3b 5 5 bynk2m5 bynk2m j2b2 n3y", Speed: beeps "5 5 5 jny3b3t5 5 jny3y3b 5 5 bynk2m5 bynk2m j2b2 y3t", Speed
    beeps "5 5 5 ff3y5 yy2yyy2yby2b4t", Speed: beeps "5 5 5 ff2y5 tby tby nj3m", Speed
End Sub

Private Sub Music()
    On Error Resume Next
    Dim Sh As Worksheet: Set Sh = ActiveSheet
    beeps Split(Sh.Shapes(Application.Caller).name, "_")(1)
End Sub

Sub beeps(melodi, Optional ByVal BeepTime As Integer = 200): mr = "qazwsxedcrfvtgbyhnujmik,ol.p;/['"
    On Error Resume Next:  Dim sha As Shape, LastColor As Long
    For i = 1 To Len(melodi)
    DoEvents
    nextlen = 1: letter = Mid$(melodi, i, 1)
    nota = InStr(1, mr, letter)
    If IsNumeric(letter) And letter > 0 Then nextlen = letter: i = i + 1: nota = InStr(1, mr, Mid$(melodi, i, 1))
    If nota > 0 Then
    If Len(melodi) > 1 Then
    Set sha = ActiveSheet.Shapes("Button_" & Mid$(melodi, i, 1))
    LastColor = sha.Fill.ForeColor.RGB
    sha.Fill.ForeColor.RGB = vbRed: DoEvents
    sha.Top = sha.Top + 2: sha.Left = sha.Left + 2: DoEvents
    End If
    tone = 220 * (2 ^ ((nota - 1) / 12)): a = Beep(tone, nextlen * BeepTime)
    Else
    Set sha = Nothing
    a = Beep(30000, nextlen * BeepTime / 5)
    End If
    If Not sha Is Nothing Then
    sha.Fill.ForeColor.RGB = LastColor
    sha.Top = sha.Top - 2: sha.Left = sha.Left - 2
    End If
    Next: [a1].Select
End Sub

Function aralik(ByRef ra As Range, ByVal Button_color As Long, ByVal txt As String, Optional ByVal MacroName As String = "") As Shape
    On Error Resume Next: Err.Clear
    w = ra.Width: h = ra.Height: w = IIf(w > 10, w, 50): h = IIf(h > 10, h, 50)
    l = ra.Left: t = ra.Top:
    Dim sha As Shape: Set sha = ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, l, t, w, h)
    With sha
    .Fill.Visible = msoTrue: .Fill.Solid: .Fill.ForeColor.RGB = Button_color: .Fill.Transparency = 4
    .Fill.BackColor.RGB = vbWhite: .Fill.TwoColorGradient msoGradientFromCenter, 2
    .Adjustments.Item(1) = 0.16: .Placement = xlFreeFloating: .OLEFormat.Object.PrintObject = False
    With .TextFrame
    .Characters.Text = txt
    With .Characters.Font
    .Size = IIf(h >= 16, 10, 8): .Bold = True: .name = "Arial Narrow": .name = "Arial"
    End With
    .HorizontalAlignment = xlCenter: .VerticalAlignment = xlVAlignCenter
    End With
    .OnAction = MacroName
    End With
    Set aralik = sha
End Function
 
 
Hoşça kalın ! --)(
 
Gönderildi : 16/11/2013 15:00

(@riza-sahan)
Gönderiler: 18033
_
 

Eğlenceli bir paylaşım :))

1984 doğumluyum. 4 yaşından bu yana İstanbul’da yaşıyorum. Sırası ile aşağıdaki okullarda eğitim gördüm. Paşaköy ilkokulu (1990-1995) Kartal Zekeriyya Güçer İlköğretim Okulu(1995-1998) Ümraniye Teknik ve Endüstri Meslek Lisesi Bilgisayar Bölümü(1998-2001) Kocaeli Üniversitesi Bilgisayar Programcılığı(2002-2004) Anadolu Ünv. İşletme Fakültesi(2006-2009) Lise yıllarından sonra bir bilgisayar firmasının teknik servisinde mesleğe merhaba dedim. Outsource olarak Citibank ytl ve bina taşınma projesinde yer alarak 8 ay görev yaptım. Bu görevden sonra şu an çalışmakta olduğum yerde bilgi işlem sorumlusu olarak göreve başladım ve 18 yıldır görevimin başındayım.

 
Gönderildi : 17/11/2013 00:06

(@Anonim)
Gönderiler: 0
Konu başlatıcı
 

Evet öyle, farklı bir çalışma olduğu için oldukça beğenilmişti. 🙂

 
Gönderildi : 17/11/2013 01:50

Paylaş: