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 »