Fungsi Convert Angka Menjadi Terbilang

Berikut saya akan membagikan Source Code Membuat Fungsi/Convert Angka Menjadi Terbilang dengan menggunakan Visual Basic 6. Penerapannya adalah apabila di suatu perusahaan baik di bank, pertokoan atau instansi pemerintah pembuatan nota kwitansi setoran,penarikan atau pembayaran pasti disertai dengan terbilang agar lebih akurat pengesahan nilai atau nominal angka. Memang secara manual bisa kita ketik di Microsoft Excel atau aplikasi lainnya tapi membutuhkan waktu sedikit lama,
Berikut saya memberikan contoh mengubah angka menjadi terbilang dengan menggunakan Visual Basic.

1. Source code di form

Option Explicit
Private Sub cmdClose_Click()
    End
End Sub
Private Sub cmdTerbilang_Click()
    Dim obj As New clsTerbilang
    txtTerbilang.Text = obj.NumToText(txtNumber.Text)
End Sub
Private Sub txtNumber_KeyPress(KeyAscii As Integer)
    If ((KeyAscii < 48 And KeyAscii <> 8) Or KeyAscii > 57) Then
        KeyAscii = 0
    End If
End Sub

2. Sorce code class modul terbilang

Option Explicit
Dim Once(0 To 20) As String
Dim Tenths(9) As String
Dim Num As String
Dim n(9) As Integer
Dim i As Integer
Dim meValue As String
Private Sub Class_Initialize()
    Once(0) = ""
    Once(1) = " Satu"
    Once(2) = " Dua"
    Once(3) = " Tiga"
    Once(4) = " Empat"
    Once(5) = " Lima"
    Once(6) = " Enam"
    Once(7) = " Tujuh"
    Once(8) = " Delapan"
    Once(9) = " Sembilan"
    Once(10) = " Sepuluh"
    Once(11) = " Sebelas"
    Once(12) = " Dua Belas"
    Once(13) = " Tiga Belas"
    Once(14) = " Empat Belas"
    Once(15) = " Lima Belas"
    Once(16) = " Enam Belas"
    Once(17) = " Tujuh Belas"
    Once(18) = " Delapan Belas"
    Once(19) = " Sembilan Belas"
    Tenths(2) = " Dua Puluh"
    Tenths(3) = " Tiga Puluh"
    Tenths(4) = " Empat Puluh"
    Tenths(5) = " Lima Puluh"
    Tenths(6) = " Enam Puluh"
    Tenths(7) = " Tujuh Puluh"
    Tenths(8) = " Delapan Puluh"
    Tenths(9) = " Sembilan Puluh"
End Sub
Public Function NumToText(Num As String) As String
    meValue = ""
    Num = Format(Num, "000,000,000.00")
    n(1) = Mid(Num, 1, 1)
    n(2) = Mid(Num, 2, 1)
    n(3) = Mid(Num, 3, 1)
    n(4) = Mid(Num, 5, 1)
    n(5) = Mid(Num, 6, 1)
    n(6) = Mid(Num, 7, 1)
    n(7) = Mid(Num, 9, 1)
    n(8) = Mid(Num, 10, 1)
    n(9) = Mid(Num, 11, 1)
    '*** MILLIONS
    i = n(1) & n(2) & n(3)
    If i > 0 Then
        If n(1) > 0 Then
            meValue = Once(n(1)) & " Ratus"
        End If
        i = n(2) & n(3)
        If i >= 20 Then
            meValue = meValue & Tenths(n(2)) & Once(n(3)) & " Juta"
        Else
            meValue = meValue & Once(i) & " Juta"
        End If
    End If
    '*** THOUSANDS
    i = n(4) & n(5) & n(6)
    If i > 0 Then
        If n(4) > 0 Then
            meValue = meValue & Once(n(4)) & " Ratus"
        End If
        i = n(5) & n(6)
        If i >= 20 Then
            meValue = meValue & Tenths(n(5)) & Once(n(6)) & " Ribu"
        Else
            meValue = meValue & Once(i) & " Ribu"
        End If
    End If
    '*** HUNDREDS
    i = n(7) & n(8) & n(9)
    If i > 0 Then
        If n(7) > 0 Then
            meValue = meValue & Once(n(7)) & " Ratus"
        End If
        i = n(8) & n(9)
        If i >= 20 Then
            meValue = meValue & Tenths(n(8)) & Once(n(9))
        Else
            meValue = meValue & Once(i)
        End If
    End If
    meValue = Replace(meValue, "Satu Ribu", "Seribu")
    meValue = Replace(meValue, "Satu Ratus", "Seratus")
    meValue = Trim(meValue)
    NumToText = meValue
End Function

Demikian souce code semoga bisa bermanfaat dan membantu rekan-rekan dalam pekerjaan.
Download disini

Read more »

Membuat Halaman Database VB 6

Membuat halaman database sangat dibutuhkan dalam pengolaan database yang cukup besar. Apabila kita menemukan suatu project demikian apa yang bisa lakukan?. Bagi anda yang mengetahui atau sudah mahir dalam programing VB 6 tentu saja sudah mengetahui solusinya. Berikut saya sharing atau berikan suatu "Tips Membuat Halaman Database atau Page Paging" dengan menggunakan database "Microsoft Access". 

Option Explicit

Dim mykoneksi As Connection

Dim WithEvents tb_1 As Recordset

Dim WithEvents tb_2 As Recordset

Dim record As Integer

Dim field As Integer

Dim page As Integer

Dim jumlah_per_halaman As Integer

Dim eop As Integer

Dim j As Integer

Private Sub cbopage_Click()

  Dim i As Integer

  Dim tempBottom As Integer

  Dim tempTop As Integer

  If cbopage.Text > 1 And _

     cbopage.Text < tb_1.PageCount Then cmdprev.Enabled = True: cmdnext.Enabled = True

  If cbopage.Text = tb_1.PageCount Then cmdprev.Enabled = True: cmdnext.Enabled = False

  If cbopage.Text <= 1 Then cmdprev.Enabled = False: cmdnext.Enabled = True

  If cbopage.ListCount = 1 Then cmdprev.Enabled = False: cmdnext.Enabled = False  

  If cbopage.Text = "1" Then

    j = 0

    tb_1.MoveFirst

    For i = 1 To jumlah_per_halaman

      j = j + 1

      tb_1.MoveNext

      If tb_1.EOF Then Exit For

    Next i

  Else

    j = 0

    tb_1.MoveFirst

    eop = cbopage.Text * jumlah_per_halaman

    tb_1.Move eop - jumlah_per_halaman

    For i = 1 To jumlah_per_halaman

      j = j + 1

      tb_1.MoveNext

      If tb_1.EOF Then Exit For

    Next i

  End If

  tempBottom = (cbopage * jumlah_per_halaman) - (jumlah_per_halaman - 1)

  tempTop = ((cbopage * jumlah_per_halaman) - (jumlah_per_halaman - 1)) + (j - 1)

  Set tb_2 = New Recordset

  tb_2.Open "SELECT * FROM table1 WHERE no_urut>=" _

                 & tempBottom & " AND no_urut<=" & tempTop & "", _

                 mykoneksi, adOpenDynamic, adLockOptimistic

  Set DataGrid1.DataSource = tb_2.DataSource

  record = tb_2.RecordCount

  field = tb_2.Fields.Count

  DoEvents

End Sub

Private Sub cbo_perpage_Click()

  Dim i As Integer

  jumlah_per_halaman = cbo_perpage.Text

  tb_1.PageSize = jumlah_per_halaman

  page = tb_1.PageCount

  cbopage.Clear

  For i = 1 To page

     cbopage.AddItem i

  Next i

  cbopage.Text = cbopage.List(0)

End Sub

Private Sub cmdCLOSE_Click()

 Unload Me

End Sub

Private Sub cmdnext_Click()

  cbopage.Text = cbopage.Text + 1

  If cbopage.Text > 1 Then cmdprev.Enabled = True

  If cbopage.Text >= tb_1.PageCount Then cmdnext.Enabled = False: cmdprev.SetFocus

End Sub

Private Sub cmdprev_Click()

  cbopage.Text = cbopage.Text - 1

  If cbopage.Text > 1 Then cmdprev.Enabled = True: cmdprev.SetFocus

  If cbopage.Text <= 1 Then cmdprev.Enabled = False: cmdnext.Enabled = True

End Sub

Private Sub Form_Load()

Dim i As Integer

  Set mykoneksi = New Connection

  mykoneksi.CursorLocation = adUseClient

  mykoneksi.Open "PROVIDER=MSDataShape;Data PROVIDER=" & _

          "Microsoft.Jet.OLEDB.4.0;Data Source=" _

          & App.Path & "\db1.mdb;"

   

  Set tb_1 = New Recordset

  tb_1.Open "SELECT * FROM table1", mykoneksi

    

  For i = 10 To 35 Step 10

     cbo_perpage.AddItem i

  Next i

  cbo_perpage.Text = cbo_perpage.List(0)

  jumlah_per_halaman = cbo_perpage.List(0)

  tb_1.PageSize = jumlah_per_halaman

  page = tb_1.PageCount

  cmdprev.Enabled = False

  cmdnext.Enabled = True

  Exit Sub

Pesan:

  MsgBox Err.Number & " - " & Err.Description

  End

End Sub

Contoh Kode membuat halaman vb 6 diatas masih sederhana dan bisa dikembangkan sesuai kebutuhan kita.  NB : "mungkin ada rekan-rekan yang ahli mohon di share... terima kasih".

Download Source disini.

Read more »

Membuat Animasi Picture

Membuat aplikasi seringkali kita ingin agar aplikasi kita kelihatan menarik misalnya about me, loading form atau halaman pembuka. berikut saya berikan contoh Membuat Animasi Picture VB 6 dan bisa dikembangkan sesuai kebutuhan kita.
Contoh tampilan latihan membuat animasi picture seperti di bawah ini :

Option Explicit

Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Dim flipped As Integer  ' bit field

Private Sub Form_Load()
    ' we need to make the form visible, first
    Show
    DoEvents
    ' then we can show the image (this cause a refresh)
    cboDissolve.ListIndex = 0
End Sub

Private Sub cboZoom_Click()
    cmdShow.Value = True
End Sub

Private Sub chkTile_Click()
    cmdShow.Value = True
End Sub

Private Sub cboDissolve_Click()
    fraZoom.Enabled = (cboDissolve.ListIndex = 0)
    cmdHorizontal.Enabled = (cboDissolve.ListIndex = 0)
    cmdVertical.Enabled = (cboDissolve.ListIndex = 0)
    cmdBoth.Enabled = (cboDissolve.ListIndex = 0)
    cmdShow.Value = True
End Sub

Private Sub cmdShow_Click()
    If cboDissolve.ListIndex = 0 Then
        ShowImage
    Else
        DissolveImage
    End If
    flipped = 0
End Sub

Sub ShowImage()
    ' show the hidden image
    Dim destWidth As Single, destHeight As Single
    Dim destX As Single, destY As Single
    Dim stepX As Single, stepY As Single
    
    ' determine zoom factor
    Select Case cboZoom.ListIndex
        Case cboZoom.ListCount - 4
            ' fit width
            destWidth = picDest.ScaleWidth
            destHeight = picSource.ScaleHeight * (destWidth / picSource.ScaleWidth)
        Case cboZoom.ListCount - 3
            ' fit height
            destHeight = picDest.ScaleHeight
            destWidth = picSource.ScaleWidth * (destHeight / picSource.ScaleWidth)
        Case cboZoom.ListCount - 2
            ' fit page (no distorsion)
            destWidth = picDest.ScaleWidth
            destHeight = picDest.ScaleHeight
            If destWidth / picSource.ScaleWidth < destHeight / picDest.ScaleHeight Then
                ' fit width, adjust height
                destHeight = picSource.ScaleHeight * (destWidth / picSource.ScaleWidth)
            Else
                ' fit height, adjust width
                destWidth = picSource.ScaleWidth * (destHeight / picSource.ScaleWidth)
            End If
        Case cboZoom.ListCount - 1
            ' fit page (distorsion)
            destWidth = picDest.ScaleWidth
            destHeight = picDest.ScaleHeight
        Case Else
            On Error Resume Next
            destWidth = picSource.ScaleWidth * Val(cboZoom) / 100
            destHeight = picSource.ScaleHeight * Val(cboZoom) / 100
            If Err Then Exit Sub
    End Select
    
    picDest.Cls
    
    If chkTile.Value = vbChecked Then
        ' tile images
        For destX = 0 To picDest.ScaleWidth Step destWidth
            For destY = 0 To picDest.ScaleHeight Step destHeight
                picDest.PaintPicture picSource.Picture, destX, destY, destWidth, destHeight
            Next
        Next
    Else
        ' simple copy
        picDest.PaintPicture picSource.Picture, 0, 0, destWidth, destHeight
    End If
End Sub

Sub DissolveImage()
    ' show the hidden image
    Dim srcWidth As Single, srcHeight As Single
    Dim srcX As Single, srcY As Single
    Dim destWidth As Single, destHeight As Single
    Dim destX As Single, destY As Single
    Dim stepX As Single, stepY As Single
    Dim i As Integer
    
    Const DISSOLVE_STEPS = 20
    
    ' most routine below use these values
    srcWidth = picSource.ScaleWidth
    srcHeight = picSource.ScaleHeight
        
    stepX = srcWidth / DISSOLVE_STEPS
    stepY = srcHeight / DISSOLVE_STEPS
    
    picDest.Cls
    
    Select Case cboDissolve.ListIndex
        Case 1
            ' Scroll from Left
            srcX = srcWidth
            For i = 1 To DISSOLVE_STEPS
                srcX = srcX - stepX
                picDest.PaintPicture picSource.Picture, 0, 0, , , srcX, 0
                RefreshAndDelay
            Next
        Case 2
            ' Scroll from right
            destX = srcWidth
            For i = 1 To DISSOLVE_STEPS
                destX = destX - stepX
                picDest.PaintPicture picSource.Picture, destX, 0, srcWidth - destX, , , , srcWidth - destX
                RefreshAndDelay
            Next
        Case 3
            ' Scroll from Top
            srcY = srcHeight
            For i = 1 To DISSOLVE_STEPS
                srcY = srcY - stepY
                picDest.PaintPicture picSource.Picture, 0, 0, , , 0, srcY
                RefreshAndDelay
            Next
        Case 4
            ' Scroll from bottom
            destY = srcHeight
            For i = 1 To DISSOLVE_STEPS
                destY = destY - stepY
                picDest.PaintPicture picSource.Picture, 0, destY, , , , , , srcHeight - destY
                RefreshAndDelay
            Next
            
        Case 5
            ' Roll from Left
            destWidth = 0
            For i = 1 To DISSOLVE_STEPS
                destWidth = destWidth + stepX
                picDest.PaintPicture picSource.Picture, 0, 0, , , 0, 0, destWidth
                RefreshAndDelay
            Next
        Case 6
            ' Roll from right
            destX = srcWidth
            For i = 1 To DISSOLVE_STEPS
                destX = destX - stepX
                picDest.PaintPicture picSource.Picture, destX, 0, , , destX, 0, srcWidth - destX
                RefreshAndDelay
            Next
        Case 7
            ' Roll from Top
            destHeight = 0
            For i = 1 To DISSOLVE_STEPS
                destHeight = destHeight + stepY
                picDest.PaintPicture picSource.Picture, 0, 0, , , 0, 0, , destHeight
                RefreshAndDelay
            Next
        Case 8
            ' Roll from bottom
            destY = srcHeight
            For i = 1 To DISSOLVE_STEPS
                destY = destY - stepY
                picDest.PaintPicture picSource.Picture, 0, destY, , , 0, destY, , srcHeight - destY
                RefreshAndDelay
            Next
        Case 9
            ' explode
            destX = srcWidth / 2
            destY = srcHeight / 2
            srcWidth = 0
            srcHeight = 0
            For i = 1 To DISSOLVE_STEPS
                destX = destX - stepX / 2
                destY = destY - stepY / 2
                srcWidth = srcWidth + stepX
                srcHeight = srcHeight + stepY
                picDest.PaintPicture picSource.Picture, destX, destY, , , destX, destY, srcWidth, srcHeight
                RefreshAndDelay
            Next
        Case 10
            ' mosaic
            ' first, prepare the matrix of the (X,Y) coordinates
            ' for all the tiles
            Dim xy(DISSOLVE_STEPS * DISSOLVE_STEPS, 1) As ShiftConstants
            Dim kx As Integer, ky As Integer, ndx As Integer
            destX = 0
            For kx = 1 To DISSOLVE_STEPS
                destY = 0
                For ky = 1 To DISSOLVE_STEPS
                    i = i + 1
                    xy(i, 0) = destX
                    xy(i, 1) = destY
                    destY = destY + stepY
                Next
                destX = destX + stepX
            Next
            ' this loop picks up a random tile, draws it and then
            ' deletes it from the xy() array so that it can't be
            ' selected any more
            For ndx = UBound(xy) To 1 Step -1
                ' draw the tile
                i = Int(Rnd * ndx + 1)
                destX = xy(i, 0)
                destY = xy(i, 1)
                picDest.PaintPicture picSource.Picture, destX, destY, , , destX, destY, stepX, stepY
                ' delete it from xy() - actually it just replace it
                ' with the last item in the array
                xy(i, 0) = xy(ndx, 0)
                xy(i, 1) = xy(ndx, 1)
            Next
    End Select

End Sub

Private Sub cmdHorizontal_Click()
    ' flip the image horizontally
    flipped = flipped Xor 1
    ShowFlippedImage
End Sub

Private Sub cmdVertical_Click()
    ' flip the image vertically
    flipped = flipped Xor 2
    ShowFlippedImage
End Sub

Private Sub cmdBoth_Click()
    ' flip the image on both axis
    flipped = flipped Xor 3
    ShowFlippedImage
End Sub

Sub ShowFlippedImage()
    picDest.Cls
    Select Case flipped
        Case 0
            picDest.PaintPicture picSource.Picture, 0, 0
        Case 1
            ' flip the image horizontally
            picDest.PaintPicture picSource.Picture, picSource.ScaleWidth, 0, -picSource.ScaleWidth
        Case 2
            ' flip the image vertically
            picDest.PaintPicture picSource.Picture, 0, picSource.ScaleHeight, , -picSource.ScaleHeight
        Case 3
            ' flip the image on both axis
            picDest.PaintPicture picSource.Picture, picSource.ScaleWidth, picSource.ScaleHeight, -picSource.ScaleWidth, -picSource.ScaleHeight
    End Select
End Sub

Sub RefreshAndDelay()
    'Refresh
    Sleep 50
End Sub

Kode diatas hanya sederhana, saya dapat dari internet melalui Om Googleee. dan telah membantu saya membuat aplikasi-aplikasi sederhan.

Source Code

Read more »

Menampilkan Gambar VB

Berikut ini saya akan bagikan source code untuk Menampilkan Gambar/Image Visual Basic, mudah-mudahan dapat membantu bagi penggemar programing visual basic. Source code ini hanya sederhana dan anda bisa kembangkan sesuai kebutuhan. 
Tampilannya seperti gambar berikut:

Dalam source kode diatas ada fungsi menampilkan data dengan memilih drive. berikut source codenya:

Option Explicit

Private Sub Form_Load()
    Drive1.Drive = "c:"
    Dir1.Path = "c:\windows"
    File1.Pattern = "*.bmp;*.dib;*.wmf;*.emf;*.gif;*.jpg"
End Sub

Private Sub Drive1_Change()
    Dir1.Path = Left$(Drive1.Drive, 1) & ":\"
End Sub

Private Sub Dir1_Change()
    File1.Path = Dir1.Path
End Sub

Private Sub File1_Click()
    LoadImage File1.Path & IIf(Right$(File1.Path, 1) <> "\", "\", "") &     File1.filename
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    File1.Height = ScaleHeight - File1.Top
    picPreview.Move picPreview.Left, picPreview.Top, ScaleWidth - picPreview.Left, ScaleHeight - picPreview.Top
    ShowImage
End Sub

Private Sub optActual_Click()
    ShowImage
End Sub

Private Sub optStretch_Click()
    ShowImage
End Sub

Private Sub optTile_Click()
    ShowImage
End Sub

Sub LoadImage(filename As String)
    On Error Resume Next
    Set imgHidden.Picture = LoadPicture(filename)
    If Err Then
        MsgBox "Unable to load file " & filename, vbExclamation
        Exit Sub
    End If
    Caption = filename & "- Image Preview"
    ShowImage
End Sub

Sub ShowImage()
    Dim x As Single, y As Single
    If optActual.Value Then
        ' Tampilan image center
        picPreview.Cls
        picPreview.PaintPicture imgHidden.Picture, (picPreview.ScaleWidth - imgHidden.Width) / 2, (picPreview.ScaleHeight - imgHidden.Height) / 2
    ElseIf optStretch.Value Then
        ' Tampilan image stretch
        picPreview.PaintPicture imgHidden.Picture, 0, 0, picPreview.ScaleWidth, picPreview.ScaleHeight
    ElseIf optTile.Value Then
        ' Tampilan image actual
        x = 0
        Do While x < picPreview.ScaleWidth
            y = 0
            Do While y < picPreview.ScaleHeight
                picPreview.PaintPicture imgHidden.Picture, x, y
                y = y + imgHidden.Height
            Loop
            x = x + imgHidden.Width
        Loop
    End If

End Sub

Demikian sample source code Menampilkan Gambar/Image VB apabila masih ada kekurangan mohon dimaafkan. Source code Download

Read more »

Fungsi Event LostFocus dan GotFocus

Fungsi Event Gotfocus yaitu terjadi pada saat focus object memasuki sebuah komponen . dan LostFocus kebalikan dari fungsi GotFocus yaitu terjadi pada saat focus object meninggalkan sebuah kompunen.

Private Sub txtUserID_LostFocus()If txtUserID.Text = "" ThenMsgBox "Harus diisi"End If 

End SubPrivate Sub txtUserID_GotFocus()txtUserID.Text = ""End Sub

Contoh penerapan Fungsi Event LostFocus dan GotFocus seperti source code sederhana di bawah ini:

Option Explicit

Private m_FocusControl As Control

Private Sub HighlightControl(ByVal ctl As Control)
    ctl.BackColor = RGB(&HC0, &HFF, &HFF)
End Sub

Private Sub UnHighlightControl(ByVal ctl As Control)
    ctl.BackColor = vbWhite
End Sub

Private Sub txtCity_GotFocus()
    HighlightControl txtCity
End Sub

Private Sub txtCity_LostFocus()
    UnHighlightControl txtCity
End Sub

Private Sub txtFirstName_GotFocus()
    HighlightControl txtFirstName
End Sub

Private Sub txtFirstName_LostFocus()
    UnHighlightControl txtFirstName
End Sub

Private Sub txtLastName_GotFocus()
    HighlightControl txtLastName
End Sub

Private Sub txtLastName_LostFocus()
    UnHighlightControl txtLastName
End Sub

Private Sub txtState_GotFocus()
    HighlightControl txtState
End Sub

Private Sub txtState_LostFocus()
    UnHighlightControl txtState
End Sub

Private Sub txtStreet_GotFocus()
    HighlightControl txtStreet
End Sub

Private Sub txtStreet_LostFocus()
    UnHighlightControl txtStreet
End Sub

Private Sub txtZip_GotFocus()
    HighlightControl txtZip
End Sub

Private Sub txtZip_LostFocus()
    UnHighlightControl txtZip
End Sub

Jika anda pingin mengembangkannya silakan klik  Download 

Read more »

Membuat Gradient VB

Pengertian gradient dalam kamus terjemahan adalah tinggi/curam tanjakan, lereng. Kalau kita implementasikan arti kata tersebut dalam pemograman adalah membuat suati garis dari kordinat x sampai y.
Contoh penerapan yaitu seperti gambar di samping ini membuat warna tampilan Form dan PictureBox. Sebagai latihan buat satu project dan tempatkan 2 buah komponen PictureBox, 1 buah kompunen timer dan 3 buah komponen label. dan masukan source kode di bawah ini.

Berikut contoh source code Membuat Gradien:

Option Explicit
Dim Red, Green, Blue, sred, ered, sgreen, sblue, egreen, eblue, difr, difg, difb, fora
Public Enum enumOrientation
    Orientation_Horizontal = 0
    Orientation_Vertical = 1
End Enum

Public Function Gradient(Frm As Object, Orientation As enumOrientation, SClr As ColorConstants, EClr As ColorConstants)
    Dim Yi
    Frm.AutoRedraw = True: Frm.ScaleMode = 3 '2 is interesting,too
    Analyze (SClr): sred = Red: sgreen = Green: sblue = Blue
    Analyze (EClr): ered = Red: egreen = Green: eblue = Blue
    difr = ered - sred: difg = egreen - sgreen: difb = eblue - sblue
    Select Case Orientation
      Case Is = 0: fora = Frm.ScaleHeight
      Case Is = 1: fora = Frm.ScaleWidth
    End Select
    For Yi = 0 To fora
    sred = sred + (difr / fora): If sred < 0 Then sred = 0
    sgreen = sgreen + (difg / fora): If sgreen < 0 Then sgreen = 0
    sblue = sblue + (difb / fora): If sblue < 0 Then sblue = 0
    Select Case Orientation
      Case Is = 0: Frm.Line (0, Yi)-(Frm.ScaleWidth, Yi), RGB(sred, sgreen, sblue), B
      Case Is = 1: Frm.Line (Yi, 0)-(Yi, Frm.ScaleHeight), RGB(sred, sgreen, sblue), B
    End Select
    Next
End Function

Public Function Analyze(CConst As ColorConstants)
    Dim rr, gr, br As Long
    rr = 1: gr = 256: br = 65536
    Dim rest As Long
    rest = CConst \ br
    Blue = rest
    CConst = CConst Mod br
    If Blue < 0 Then Blue = 0
    rest = CConst \ gr
    Green = rest
    CConst = CConst Mod gr
    If Green < 0 Then Green = 0
    rest = CConst \ rr
    Red = rest
    CConst = CConst Mod rr
    If Red < 0 Then Red = 0
End Function

Private Sub Form_Resize()
    Gradient Picture1, 0, vbCyan, vbYellow
    Gradient Picture2, 0, vbRed, vbCyan
    Gradient Me, 1, vbGreen, vbRed
    Label1.Caption = "Gradiant Picture"
End Sub

Private Sub Timer1_Timer()
    Label4.Caption = Time
    Label5.Caption = Format(Date, "Long date")
End Sub

Silakan Download disini

Read more »