Horizontal Scroll And Vertical Scroll

Option Explicit 
  
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 
  
Public Const SB_LINEUP As Long = 0 
Public Const SB_LINEDOWN As Long = 1 
  
Public Const WM_VSCROLL As Long = &H115 
Public Const WM_HSCROLL As Long = &H114 
Public Const WM_MOUSEWHEEL As Long = &H20A 
Public Const GWL_WNDPROC = (-4) 
  
Public PrevProc As Long 
Public blnFocusScroll As Boolean 
  
Function NewWindowProc(ByVal hWnd As Long, _ 
ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 
On Error Resume Next 
    Select Case Msg 
        Case Is = WM_MOUSEWHEEL 
            If blnFocusScroll = True Then 
                If (wParam > 0) Then 
                    'Form1 adalah nama form yang akan akan digunakan 
                    'Scroll adalah nama scrollbar yang akan digunakan 
                    SendMessage Form1.Scroll.hWnd, WM_VSCROLL, SB_LINEUP, 0& 
                    Form1.Scroll.Value = Form1.Scroll.Value - _ 
                    Form1.Scroll.LargeChange 
                Else 
                    SendMessage Form1.Scroll.hWnd, WM_VSCROLL, SB_LINEDOWN, 0& 
                    Form1.Scroll.Value = Form1.Scroll.Value + _ 
                    Form1.Scroll.LargeChange 
                End If 
                Form1.Scroll_Change 
            End If 
        End Select 
        ' 
        NewWindowProc = CallWindowProc(PrevProc, hWnd, Msg, wParam, lParam) 
End Function 
  
Public Sub HookForm(F As Form) 
    PrevProc = SetWindowLong(F.hWnd, GWL_WNDPROC, AddressOf NewWindowProc) 
End Sub 
  
Public Sub UnHookForm(F As Form) 
    SetWindowLong F.hWnd, GWL_WNDPROC, PrevProc 
End Sub 

Dalam form tambahkan kode di bawah ini:

Option Explicit 
  
Dim AwalTop As Long 
  
Sub Scrolling(Value As Long) 
    Dim i As Long 
  
    picItem(0).Top = picItem(0).Top + (AwalTop - Value) 
  
    For i = 1 To picItem.Count - 1 
        picItem(i).Top = picItem(i - 1).Top + Me.picItem(0).Height + 20 
        DoEvents 
    Next 
  
    AwalTop = Value 
End Sub 
  
Private Sub Form_Load() 
    HookForm Me 
    blnFocusScroll = True 
    Me.Scroll.Max = 2500 
    Me.Scroll.SmallChange = 10 
    Me.Scroll.LargeChange = 100 
End Sub 
  
Private Sub Form_Unload(Cancel As Integer) 
    UnHookForm Me 
End Sub 
  
Sub Scroll_Change() 
    Scrolling Me.Scroll.Value 
End Sub 
  
Sub Scroll_Scroll() 
    Scrolling Me.Scroll.Value 
End Sub 

Perhatian:
Kode di atas menggunakan subclassing, kesalahan mengkode dapat menyebabkan CRASH!

READ MORE - Horizontal Scroll And Vertical Scroll

Menyimpan File Ke Dalam Format MHTML

Menyimpan file dalam format MHTML tentunya memiliki banyak keuntungan, salah satu dari banyak keuntungan tersebut ialah terintegrasinya seluruh gambar dan file dengan baik, sehingga kita bisa mendownload halaman situs/blog yang kita kunjungi utuh dengan seluruh gambarnya.

Apabila Anda gabungkan dengan prosedur untuk mengekstrak link dari sebuah blog, maka ia akan memiliki kemampuan yang lebih baik lagi, dengan kata lain Anda dapat mem-back-up satu blog milik Anda sendiri ataupun milik orang lain utuh dengan seluruh gambarnya.

Option Explicit  

Public Function SaveWebPageToMHTFile(url As String, filepath As String)  
      
On Error GoTo ErrHandler  

    Dim msg As New CDO.Message  
    Dim stm As New   ADODB.Stream  
      
    msg.MimeFormatted = True  
    msg.CreateMHTMLBody url, CDO.CdoMHTMLFlags.cdoSuppressNone, "", ""  
    '//Pilih charset yang sesuai 
    stm.Charset = "utf-8"  
    Set stm = msg.GetStream()  
    stm.SaveToFile filepath, ADODB.SaveOptionsEnum.adSaveCreateOverWrite  
    Set msg = Nothing  
    stm.Close  
      
    Exit Function  

ErrHandler:  

    MsgBox Err.Description  
      
End Function  

Contoh pemanggilan prosedur fungsi di atas:

Private Sub Command1_Click()  
    '//Coba menyimpan file dalam bentuk MHTML </i> 
    SaveWebPageToMHTFile "http://www.planet-source-code.com/vb/default.asp?lngWId=1", "c:\psc.MHTML"  
End Sub  

Catatan: Sebelum Anda menggunakan fungsi di atas, tambahkan referensi Microsoft ActiveX Data Objects 2.8 Liblari dan Microsoft CDO for Windows 2000 Liblary

READ MORE - Menyimpan File Ke Dalam Format MHTML

Kesalahan Penulisan Variable Yang Umum Terjadi

Seringkali kita menemui penulisan variable seperti di bawah ini:

Option Explicit 
 
Private Sub Form_Load() 
    Dim i, a, b, c, s As String 
    'Kode selanjutnya 
End Sub 

Penulisan variable seperti di atas seakan-akan menunjukan bahwa i, a, b, c memiliki tipe data string, Padahal dalam kenyataanya variable i, a, b, c di atas memiliki type data variant, hanya variable s saja dari contoh di atas yang memiliki type data string. Darimana kita mengetahuinya? mari kita lanjutkan.... rubahlah kode di atas sehingga menjadi:

Option Explicit 
 
Private Sub Form_Load() 
    Dim i, a, b, c, s As String 
    'Kode selanjutnya ... 
    'TypeName digunakan untuk mengetahui data type sebuah variable 
    Debug.Print TypeName(i) 'Empty -> data type variant 
    Debug.Print TypeName(b) 'Empty -> data type variant 
    Debug.Print TypeName(c) 'Empty -> data type variant 
    Debug.Print TypeName(s) 'String -> data type string 
End Sub  

Sebelum menjalankan kodenya, pijit CTRL + G untuk memunculkan Immediate Window untuk melihat hasilnya.

READ MORE - Kesalahan Penulisan Variable Yang Umum Terjadi

Blokir Situs Menggunakan Visual Basic 6.0

Option Explicit 
 
Public Declare Function GetForegroundWindow Lib "user32" ) As Long 
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long 
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long 
Public Const WM_CLOSE = &H10 
 
Public Function kick(target As String) 
    Dim H As   Long 
    Dim T As String * 255 
    H = GetForegroundWindow 
    GetWindowText H, T, 255 
    If InStr(UCase(T), UCase(target)) > 0 Then 
        SendMessage H, WM_CLOSE, 0, 0 
    End If 
End Function 

READ MORE - Blokir Situs Menggunakan Visual Basic 6.0