السلام عليكم ورحمة الله وبركاته



أقدم لكم موضوع ترفيهي ، حيث يمكنك توليد شعار لاسمك أو اسم موقعك باستخدام الأكواد في أقل من دقيقة .. كل ما عليك هو أن تقوم بإدراج موديول جديد وتضع فيه الكود التالي

Sub Draw_Name_Logo()
    Dim i       As Integer
    Dim k       As Integer
    Dim x       As Single
    Dim y       As Single
    Dim z       As Single
    Dim n       As Single
    Dim sSize   As Single
    Dim sName   As String
    Dim stLeft  As Single
    Dim stTop   As Single
    Dim sh      As Shape
    Dim rng     As Range

    Range("A7").Select
    stLeft = ActiveCell.Left - 30
    stTop = ActiveCell.Top

    sName = "أكاديمية الصقر للتدريب"

    n = 12
    k = Len(sName)
    sSize = Application.InchesToPoints(1)

    For i = 1 To k
        If Mid(sName, i, 1) <> " " Then
            x = n * i / k
            x = Application.InchesToPoints(x)
            y = Application.InchesToPoints(z)

            If i Mod 2 = 1 Then
                Set sh = ActiveSheet.Shapes.AddShape(msoShapeUpRibbon, stLeft + x, stTop + y, sSize, sSize)
            Else
                Set sh = ActiveSheet.Shapes.AddShape(msoShapeDownRibbon, stLeft + x, stTop + y, sSize, sSize)
            End If

            sh.Fill.ForeColor.RGB = RGB(GiveRandom(150, 200), GiveRandom(200, 255), GiveRandom)
            sh.Fill.Visible = msoTrue

            sh.TextFrame.Characters.Text = UCase(Mid(sName, i, 1))
            sh.TextFrame.Characters.Font.Size = 18
            sh.TextFrame.Characters.Font.Name = "Arial"
            sh.TextFrame.Characters.Font.Bold = True
            sh.TextFrame.Characters.Font.Color = RGB(0, 0, 0)

            sh.TextFrame2.VerticalAnchor = msoAnchorMiddle
            sh.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
        End If
    Next i
End Sub

Sub Delete_Shapes_Except_Form_Controls()
    Dim shp As Shape

    For Each shp In ActiveSheet.Shapes
        If shp.Type = msoAutoShape Or shp.Type = msoTextBox Then shp.Delete
    Next shp
End Sub

Function GiveRandom(Optional lowerBound As Integer = 100, Optional upperBound As Integer = 255) As Integer
    Randomize Timer
    GiveRandom = Int((upperBound - lowerBound + 1) * Rnd + lowerBound)
End Function

كل ما عليك تغييره هو المتغير المسمى sName .. ثم قم برسم زري أمر على ورقة العمل : أحدهما لرسم الشعار بالأشكال المحددة والآخر لحذف هذه الأشكال

رابط الملف من هنا

أخوكم في الله / ياسر خليل أبو البراء