Hallo sahabat telatngoding pada kesempatan kali ini saya akan berbagi tutorial Cara Membuat Caption Label Scroll Menggunakan UserControl Visual Basic dengan mudah.
Gambar diatas adalah salah satu hasil label scroll menggunakan usercontrol pada visual basic yang bekerja secara otomatis tanpa menggunakan aksi klik untuk scroll kebawah atau keatas, cukup tempelkan mouse ke arah titik panah scroll maka akan terbawa secara otomatis.
Untuk bisa menggunakan cara tersebut ada beberapa hal yang harus di perhatikan seperti cara menulis text label dan penempatannya.
Sebelum lanjut ke tutorial cara membuat caption label dengan usercontrol pada visual basic 6.0 saya akan jelaskan sedikit tentang fungsi usercontrol pada visual basic.
Fungsi UserControl Pada Visual Basic
Usercontrol adalah fasilitas yang sudah disediakan oleh visual basic maupun visual studio yang bertujuan untuk membuat control sendiri sesuai dengan kebutuhan developernya.
Usercontrol juga bisa diartikan sebagai suatu bagian yang sangat berpengaruh besar kepada antarmuka pengguna. Untuk lebih jelasnya silahkan baca MDSN tentang usercontrol pada visual basic maupun visual basic net.
Cara Membuat Caption Label Scroll Menggunakan UserControl Visual Basic
Untuk bisa membuat caption label dengan usercontrol ada beberapa hal yang anda perhatikan, disini saya menggunakan 1 buah modul dan 1 form.
1. Buka visual basic anda
2. Pilih Standard Exe lalu klik Open
3. Salin kode dibawah ini dan letakan di dalam form tersebut.
Private Sub Form_Load() Dim strText1 As String Dim strText2 As String Dim strExampleText As String strText1 = "Nama lengkap yang diberikan orang tua kepada saya adalah Suwardi, " & vbNewLine & _ "dilahirkan di Gunung Sugih Kabupaten Lampung Tengah pada 01 Desember 1973 " & vbNewLine & _ "anak ke enam dari tujuh bersaudara dari pasangan Amri gelar Tuan Raja Paksi (alm) " & vbNewLine & _ "dengan Maspula, yang bekerja sebagai petani di Desa Buyut Ilir " & vbNewLine & _ "Kecamatan Gunung Sugih, Lampung Tengah. Walaupun dilahirkan di Gunung " & vbNewLine & _ "Sugih namun masa kecil saya dihabiskan di perantauan, karena sejak kelas 3 " & vbNewLine & _ "Sekolah Dasar (SD) saya diajak berhijrah oleh kakak saya Dr. Suwandi, S.H., M.H. (alm) " & vbNewLine & _ "ke Bandar Lampung, sehingga praktis saya dibesarkan oleh kakak saya " & vbNewLine & _ "tersebut dan tinggal jauh dari orang tua. Saya menempuh pendidikan format " & vbNewLine & _ "dari Sekolah Dasar hingga Sekolah Menengah Atas di Bandar Lampung, tepatnya " & vbNewLine & _ "di SD Negeri 1 Enggal, SMP Negeri 3 (sekarang SMPN 4 Bandar Lampung) dan " strText2 = "SMA Negeri 1 Telukbetung (sekarang SMAN 4 Bandar Lampung). " & vbNewLine & _ "Setelah menyelesaikan pendidikan tingkat SMA saya hijrah ke Lampung " & vbNewLine & vbNewLine & _ "Utara tepatnya di Kotabumi karena kakak saya juga dipindahtugaskan ke " & vbNewLine & _ "kota tersebut. Sehingga sejak tahun 1992 sampai dengan sekarang " & vbNewLine & _ "saya resmi menjadi warga Kotabumi. Di Kotabumi inilah saya menempuh " & vbNewLine & _ "pendidikan tinggi pada Sekolah Tinggi Ilmu Hukum (STIH) Muhammadiyah " & vbNewLine & _ "Kotabumi sampai 1997" strExampleText = strText1 & vbNewLine & strText2 ctlScrollingLabel1.Caption = strExampleText frmTest.Width = ctlScrollingLabel1.Left + ctlScrollingLabel1.Width + 640 frmTest.Height = ctlScrollingLabel1.Top + ctlScrollingLabel1.Height + 640 End Sub
4. Buatlah 1 buah Modul dan 1 UserControl, kemudian salin kode di bawah ini dan letakan di dalam Modul dan UserControl sesuai kode masing - masing.
- Kode Untuk Modul
Option Explicit Type POINTAPI X As Long Y As Long End Type Declare Function GetCursorPos& Lib "user32" (lpPoint As POINTAPI) Declare Function WindowFromPoint& Lib "user32" (ByVal lpPointX As Long, ByVal lpPointY As Long) Public Enum Direction dirTop = 1 dirBottom = 2 End Enum Public Enum lbBorderStyleTypes None = 0 [Fixed Single] = 1 End Enum
- Kode untuk UserControl
'========================================================================
' UserControl: ctlScrollingLabel <[| (C) 2023 Yusril |]>
' Version: 1.0 =======================
' Author: Maker Boyz
' Date: July 01, 2023
' E-mail: admin@telatngoding.com
'========================================================================
' This user control is used to add in your project a scrolling label.
' User may create a several labels and put in it a lots of text.
' Label will be scrolled down or up, until the whole text will be shown.
'
' If you have more ideas and you like to add more functions to this user
' control, go ahead ;) My programming skills aren't too big, but I hope
' you will like this project. Please email me your modifications makes in
' my user control.
'
' This code may be reused and modified for non-commercial purposes only as
' long as credit is given to the author in the programmes about box and
' it's documentation.
' If you use this code, please email me and let me know what you think about
' this code and what you are doing with it.
'========================================================================
' Bugs: if you find any bugs, email me at admin@telatngoding.com
'========================================================================
Option Explicit
Private booScrollingLabel_Top As Boolean
Private booScrollingLabel_Bottom As Boolean
Private intDirection As Integer
Private intFontHeight As Integer
Private mfonFont As StdFont
Private mpoiCursorPos As POINTAPI
Private Sub UserControl_Initialize()
'When the control is being initialized, arrows are not choosen.
booScrollingLabel_Top = False
booScrollingLabel_Bottom = False
'When the control is being initialized, show the appropriate arrows.
picTop.Picture = imgNoTop.Picture
picBottom.Picture = imgBottom.Picture
'When the control is being initialized, set the lblText's location.
With lblText
.Top = 0
.Left = 120
End With
End Sub
Private Sub UserControl_Resize()
'If the control is been decrease too much, rise up an error.
On Error GoTo Err
'Control's fit depending on objects' layout.
picText.Height = UserControl.Height - 220
picTop.Top = picText.Top
picBottom.Top = picText.Top + picText.Height - picBottom.Height
UserControl.Width = picTop.Left + picTop.Width + 120
'So the control is not decreased too much.
If (picTop.Top + picTop.Height) >= picBottom.Top Then
picBottom.Top = 605
picText.Height = 1025
UserControl.Height = 1250
End If
Exit Sub
Err:
picBottom.Top = 605
picText.Height = 1025
UserControl.Height = 1250
End Sub
Private Sub UserControl_InitProperties()
'If the control's container is in design mode, turn off the timer, which
'will cause the control to stop working.
tmrChkStatus.Enabled = Ambient.UserMode
'Default Caption property's value will be name given by her container.
Caption = Ambient.DisplayName
End Sub
Private Sub tmrChkStatus_Timer()
'This event takes place every 10 ms (interval=10) and applied to control the changes of
'the arrows status - choosen/not choosen.
Dim lonCStat As Long
Dim lonCurrhWnd As Long
Dim intLabelBottom As Integer
'Turn off the timer.
tmrChkStatus.Enabled = False
'Define the number that describe the label's bottom.
intLabelBottom = lblText.Top + lblText.Height
'With aid of two Windows API functions, define window handle, over the mouse button is.
lonCStat = GetCursorPos&(mpoiCursorPos)
lonCurrhWnd = WindowFromPoint(mpoiCursorPos.X, mpoiCursorPos.Y)
If booScrollingLabel_Top = False Then
'If the label is not on the top and mouse button is over the arrow, change
'the arrow's picture (scrooling started - imgTopScroll) and start scrolling label
'in appropriate direction.
If lonCurrhWnd = picTop.hWnd And lblText.Top <> 0 Then
booScrollingLabel_Top = True
picTop.Picture = imgTopScroll.Picture
intDirection = dirTop
tmrScrolling.Enabled = True
End If
Else
'If the label is not on the top and mouse button is no longer over the arrow, change
'the arrow's picture (scrooling could be continued - imgTop) and stop scrolling.
If lonCurrhWnd <> picTop.hWnd And lblText.Top <> 0 Then
booScrollingLabel_Top = False
picTop.Picture = imgTop.Picture
tmrScrolling.Enabled = False
'If the label is on the top and mouse button is no longer over the arrow, change
'the arrow's picture (scrooling not possible - imgNoTop) and and stop scrolling.
ElseIf lonCurrhWnd <> picTop.hWnd And lblText.Top = 0 Then
booScrollingLabel_Top = False
picTop.Picture = imgNoTop.Picture
tmrScrolling.Enabled = False
End If
End If
If booScrollingLabel_Bottom = False Then
'If the label is not on the bottom and mouse button is over the arrow, change
'the arrow's picture (scrooling started - imgBottomScroll) and start scrolling label
'in appropriate direction.
If lonCurrhWnd = picBottom.hWnd And picText.Height <= intLabelBottom Then
booScrollingLabel_Bottom = True
picBottom.Picture = imgBottomScroll.Picture
intDirection = dirBottom
tmrScrolling.Enabled = True
End If
Else
'If the label is not on the bottom and mouse button is no longer over the arrow, change
'the arrow's picture (scrooling could be continued - imgBottom) and stop scrolling.
If lonCurrhWnd <> picBottom.hWnd And picText.Height <= intLabelBottom Then
booScrollingLabel_Bottom = False
picBottom.Picture = imgBottom.Picture
tmrScrolling.Enabled = False
'If the label is on the bottom and mouse button is no longer over the arrow, change
'the arrow's picture (scrooling not possible - imgNoBottom) and stop scrolling.
ElseIf lonCurrhWnd <> picTop.hWnd And picText.Height >= intLabelBottom Then
booScrollingLabel_Bottom = False
picBottom.Picture = imgNoBottom.Picture
tmrScrolling.Enabled = False
End If
End If
'Turn on the timer.
tmrChkStatus.Enabled = True
End Sub
Private Sub tmrScrolling_Timer()
Dim intLabelBottom As Integer
'Define the number that describe bottom label.
intLabelBottom = lblText.Top + lblText.Height
'In case of in what direction label should be scrolled, take appropriate action.
Select Case intDirection
Case Is = dirTop
'While scrolling up, it is necessary to activate arrow of scrolling bottom.
If picBottom.Picture <> imgBottom.Picture Then picBottom.Picture = imgBottom.Picture
'Scroll the label on specific height
lblText.Top = lblText.Top + intFontHeight
'If the label gets to the top, change arrow and stop scrolling.
If lblText.Top = 0 Then
picTop.Picture = imgNoTop.Picture
tmrScrolling.Enabled = False
End If
Case Is = dirBottom
'While scrolling down, it is necessary to activate arrow of scrolling up.
If picTop.Picture <> imgTop.Picture Then picTop.Picture = imgTop.Picture
lblText.Top = lblText.Top - intFontHeight
End Select
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
'If the control's container is in design mode, turn off the timer, which
'will cause the control to stop working.
tmrChkStatus.Enabled = Ambient.UserMode
'Get propertys from property bag.
BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
BorderStyle = PropBag.ReadProperty("BorderStyle", 0)
Caption = PropBag.ReadProperty("Caption", Ambient.DisplayName)
Enabled = PropBag.ReadProperty("Enabled", True)
ForeColor = PropBag.ReadProperty("ForeColor", &H8000000F)
ScrollingIntevral = PropBag.ReadProperty("ScrollingIntevral", 100)
Set Font = PropBag.ReadProperty("Font", mfonFont)
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
'Save propertys in property bag.
PropBag.WriteProperty "BackColor", BackColor, &H8000000F
PropBag.WriteProperty "BorderStyle", BorderStyle, 0
PropBag.WriteProperty "Caption", Caption, Ambient.DisplayName
PropBag.WriteProperty "Enabled", Enabled, True
PropBag.WriteProperty "ForeColor", ForeColor, &H8000000F
PropBag.WriteProperty "ScrollingIntevral", ScrollingIntevral, 100
PropBag.WriteProperty "Font", Font, mfonFont
End Sub
Public Property Get Caption() As String
'Caption property come from Caption property's object's lblText value.
Caption = lblText.Caption
End Property
Public Property Let Caption(ByVal NewValue As String)
'New Caption value's is pass on to lblText object.
'Define font's height.
lblText.Caption = Mid(NewValue, 1, 1)
intFontHeight = lblText.Height
'Show new text in lblText and change value in property bag.
lblText.Caption = NewValue
UserControl.PropertyChanged "Caption"
'If picText border style's have to be decorate with border, must incresse
'a little his width - beauty issue ;)
If BorderStyle = [Fixed Single] Then
picText.Width = lblText.Width + 320
Else
picText.Width = lblText.Width + 240
End If
'Depending on text width, define arrows location.
picTop.Left = picText.Left + picText.Width + 240
picBottom.Left = picText.Left + picText.Width + 240
'Depending on text width and arrows location, define control's height and width.
UserControl.Height = picText.Top + picText.Height + 120
UserControl.Width = picTop.Left + picTop.Width + 120
End Property
Public Property Get BackColor() As OLE_COLOR
'BackColor property is stored in BackColor property picText object.
BackColor = picText.BackColor
End Property
Public Property Let BackColor(ByVal NewValue As OLE_COLOR)
'New BackColor value is passed to picText object.
picText.BackColor = NewValue
UserControl.PropertyChanged "BackColor"
End Property
Public Property Get BorderStyle() As lbBorderStyleTypes
'BorderStyle property is stored in BackColor property picText object.
BorderStyle = picText.BorderStyle
End Property
Public Property Let BorderStyle(ByVal NewValue As lbBorderStyleTypes)
'Be sure that attribute value to BorderStyle property is correct.
If NewValue = None Or NewValue = [Fixed Single] Then
'New BorderStyle value is passed to picText object.
picText.BorderStyle = NewValue
UserControl.PropertyChanged "BorderStyle"
Else
'Incorrect value BorderStyle property - show error message.
Err.Raise Number:=vbObjectError + 32112, Description:="Nieprawid³owy parametr BorderStyle (tylko 0 lub 1)"
End If
End Property
Public Property Get Font() As StdFont
'Font property is stored in Font property lblText object.
Set Font = lblText.Font
End Property
Public Property Set Font(ByVal NewValue As StdFont)
'New Font value is passed to lblText object.
On Error GoTo Err
Set lblText.Font = NewValue
UserControl.PropertyChanged "Font"
Exit Property
Err:
MsgBox "Read the error message in Set Font section", vbOKOnly + vbExclamation, "Scrollling Label"
'Probably you changed font name over the control. This operation is not allowed
'because an error occures ;( You can change the font name only when control is on
'new form. btw: if you know how to manage this error, please email me :)
End Property
Public Property Get ForeColor() As OLE_COLOR
'ForeColor property is stored in ForeColor property lblText object.
ForeColor = lblText.ForeColor
End Property
Public Property Let ForeColor(ByVal NewValue As OLE_COLOR)
'New ForeColor value is passed to lblText object.
lblText.ForeColor = NewValue
UserControl.PropertyChanged "ForeColor"
End Property
Public Property Get Enabled() As Boolean
'Enabled property is stored in Enabled property control.
Enabled = UserControl.Enabled
End Property
Public Property Let Enabled(ByVal NewValue As Boolean)
'New Enabled value is passed to control object.
UserControl.Enabled = NewValue
UserControl.PropertyChanged "Enabled"
'Depending on control's condition - active or not - should modify object lblText and
'arrows on control.
Select Case NewValue
Case Is = True
lblText.Enabled = True
picTop.Picture = imgNoTop.Picture
picBottom.Picture = imgBottom.Picture
Case Is = False
lblText.Enabled = False
picTop.Picture = imgNoTop.Picture
picBottom.Picture = imgNoBottom.Picture
End Select
End Property
Public Property Get ScrollingIntevral() As Integer
'Interval property is stored in Interval property tmrScrolling object.
ScrollingIntevral = tmrScrolling.Interval
End Property
Public Property Let ScrollingIntevral(ByVal NewValue As Integer)
'New ScrollingIntevral value is passed to tmrScrolling object.
tmrScrolling.Interval = NewValue
UserControl.PropertyChanged "ScrollingIntevral"
End Property
Public Sub DisplayAboutBox()
'Show About window.
frmAbout.Show vbModal
End Sub5. Pada Toolbox silahkan klik Scrollinglabel lalu tempelkan pada Form.
6. Untuk picturnya silahkan download di bawah ini.
https://karyawan.co.id/5W7bWwQ
7. Untuk mengisi textnya silahkan rubah pada Form bagian kode, maka anda menemukan text seperti dibawah ini. Silahkan rubah isi textnya dengan selera anda.
Private Sub Form_Load()
Dim strText1 As String
Dim strText2 As String
Dim strExampleText As String
strText1 = "Nama lengkap yang diberikan orang tua kepada saya adalah Suwardi, " & vbNewLine & _
"dilahirkan di Gunung Sugih Kabupaten Lampung Tengah pada 01 Desember 1973 " & vbNewLine & _
"anak ke enam dari tujuh bersaudara dari pasangan Amri gelar Tuan Raja Paksi (alm) " & vbNewLine & _
"dengan Maspula, yang bekerja sebagai petani di Desa Buyut Ilir " & vbNewLine & _
"Kecamatan Gunung Sugih, Lampung Tengah. Walaupun dilahirkan di Gunung " & vbNewLine & _
"Sugih namun masa kecil saya dihabiskan di perantauan, karena sejak kelas 3 " & vbNewLine & _
"Sekolah Dasar (SD) saya diajak berhijrah oleh kakak saya Dr. Suwandi, S.H., M.H. (alm) " & vbNewLine & _
"ke Bandar Lampung, sehingga praktis saya dibesarkan oleh kakak saya " & vbNewLine & _
"tersebut dan tinggal jauh dari orang tua. Saya menempuh pendidikan format " & vbNewLine & _
"dari Sekolah Dasar hingga Sekolah Menengah Atas di Bandar Lampung, tepatnya " & vbNewLine & _
"di SD Negeri 1 Enggal, SMP Negeri 3 (sekarang SMPN 4 Bandar Lampung) dan "
strText2 = "SMA Negeri 1 Telukbetung (sekarang SMAN 4 Bandar Lampung). " & vbNewLine & _
"Setelah menyelesaikan pendidikan tingkat SMA saya hijrah ke Lampung " & vbNewLine & vbNewLine & _
"Utara tepatnya di Kotabumi karena kakak saya juga dipindahtugaskan ke " & vbNewLine & _
"kota tersebut. Sehingga sejak tahun 1992 sampai dengan sekarang " & vbNewLine & _
"saya resmi menjadi warga Kotabumi. Di Kotabumi inilah saya menempuh " & vbNewLine & _
"pendidikan tinggi pada Sekolah Tinggi Ilmu Hukum (STIH) Muhammadiyah " & vbNewLine & _
"Kotabumi sampai 1997"
strExampleText = strText1 & vbNewLine & strText2
ctlScrollingLabel1.Caption = strExampleText
frmTest.Width = ctlScrollingLabel1.Left + ctlScrollingLabel1.Width + 640
frmTest.Height = ctlScrollingLabel1.Top + ctlScrollingLabel1.Height + 640
End Sub8. Rubah pada bagian yang saya tandai dengan warna orange.
9. Jalankan program anda dengan menekan F5.
Jika anda masih kebingungan dalam membuat caption label menggunakan usercontrol pada visual basic dengan megikuti tutorial diatas, anda bisa mendownload source codenya di bawah ini.
https://karyawan.co.id/EXoYH9
Sekian dulu tutorial tentang Cara Membuat Caption Label Scroll Menggunakan UserControl Visual Basic, simak terus di telatngoding.com untuk update tutorial tentang visual basic, visual basic net dan visual studio berikutnya. Selamat ngoding dan semoga sukses.