اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

ليبل داخل فورم يعرض محتوى نطاق كقناة تلفزيونية

مهند الزيدي

بواسطه مهند الزيدي
في منتدى الاكسيل Excel

 مشاركة
إذهب إلى أفضل إجابة Solved by شوقي ربيع,

الردود الموصى بها

  • أفضل إجابة
شوقي ربيع

شوقي ربيع

قام بنشر
  • أفضل إجابة
قام بنشر

السلام عليكم

الشكر موصول للاخ ibn_egypt

وهذا كود مشابه لما تفضل به مع بعض التعديلات

Private Sub UserForm_Initialize()
Dim wSh As Worksheet: Set wSh = Sheet2
Dim iLrw As Long: iLrw = wSh.Cells(wSh.Rows.Count, 1).End(xlUp).Row
Dim iI As Integer
Dim sTex As String

    For iI = 1 To iLrw
    If iI = 1 Then sTex = wSh.Range("A" & iI) Else sTex = sTex & " - " & wSh.Range("A" & iI)
    Next

HTML sTex, 4, 5
End Sub



Private Sub HTML(sTexte As String, iSize As Integer, iScrollAmount As Integer)
Me.WebBrowser1.Navigate _
            "about:<html><body BGCOLOR ='' scroll='no'><font color= #00000 " & _
            " size=" & iSize & " face='Arial'><marquee direction=right ; font-size: 14pt;" & _
            " color: white; border-style: ridge; border-color:  scrollAmount=" & iScrollAmount & ">" & sTexte & "</marquee></font></body></html>"
End Sub

ينسخ الكود كما هو في الفورم اما السطر HTML sTex, 4, 5 فيعني على التوالي مايلي

 النص, حجم الخط, سرعة التحرك اي انه يمكنك التحكم في الخصائص التي سبقة من هذا الكود فقط

WebBrowser.rar

وهذا حل اخر عن طريق textbox


Const cVitesse As Currency = 0.01
Dim bStart As Boolean

Sub MovBar()
    Do While bStart
        timer_avant = Timer
        Do While Timer < timer_avant + cVitesse
            DoEvents
        Loop
        sMove
    Loop
End Sub

Sub sMove()
Dim iWidth As Integer: iWidth = Me.TextBox1.Width
Dim iI As Integer

    For iI = 1 To iWidth
         timer_avant = Timer
     Do While Timer < timer_avant + cVitesse
                DoEvents
           Loop
    Me.TextBox1.Left = -iWidth + iI
    Next

End Sub

Private Sub UserForm_Activate()
        bStart = True
MovBar
End Sub

Private Sub UserForm_Initialize()
Dim wSh As Worksheet: Set wSh = Sheet2
Dim iLrw As Long: iLrw = wSh.Cells(wSh.Rows.Count, 1).End(xlUp).Row
Dim iI As Integer
Dim sTex As String

    For iI = 1 To iLrw
    If iI = 1 Then sTex = wSh.Range("A" & iI) Else sTex = sTex & " - " & wSh.Range("A" & iI)
    Next
    Me.TextBox1 = sTex
With Me.TextBox1
.AutoSize = True
.BackStyle = 0
.SpecialEffect = 0
End With

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
bStart = False
End
End Sub

textbox.rar

تحياتي للجميع

  • Like 3
مهند الزيدي

مهند الزيدي

قام بنشر
  • الكاتب
قام بنشر

شكرا اخي شوقي ربيع .وشكرا لك ابن مصر على مساعدتك...ولكن هل يمكن إستدعاء صورةأو شعار تكون فاصلة بدل الإشارة ( - ).وشكرا مرة اخرى وجزاكم الله خيرا... مثلا شعار اوفسنا المرفق بالصورة .. بطريقة WebBrowser

post-115488-0-31416700-1418060975_thumb.

شوقي ربيع

شوقي ربيع

قام بنشر
قام بنشر

السلام عليكم

بخصوص الاشارة (-) يمكنك استبدالها بماتشاء من هذا الكود

    For iI = 1 To iLrw
    If iI = 1 Then sTex = wSh.Range("A" & iI) Else sTex = sTex & " - " & wSh.Range("A" & iI)
    Next

اما ان تضع مكانها صورة ؟؟؟؟؟ لاظن ذلك ممكن

او ربما ممكن في المثال الاول لانه يعتمد على اكواد html

شوقي ربيع

شوقي ربيع

قام بنشر
قام بنشر

السلام عليكم

بخصوص الاشارة (-) يمكنك استبدالها بماتشاء من هذا الكود

    For iI = 1 To iLrw
    If iI = 1 Then sTex = wSh.Range("A" & iI) Else sTex = sTex & " - " & wSh.Range("A" & iI)
    Next

اما ان تضع مكانها صورة ؟؟؟؟؟ لاظن ذلك ممكن

او ربما ممكن في المثال الاول لانه يعتمد على اكواد html

  • 2 months later...

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept