Become A VB6.0 Programmer

Automatic Select ListBox When Mouse Is Over

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 14:37:00 +0000

'Automatic select listbox when mouse over 
Option Explicit

Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function LBItemFromPt Lib "COMCTL32.DLL" (ByVal hLB As Long, ByVal ptX As Long, ByVal ptY As Long, ByVal bAutoScroll As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long

Private Const LB_SETCURSEL = &H186
Private Const LB_GETCURSEL = &H188

Private Type POINTAPI
    X As Long
Y As Long
End Type

Private Sub HightLightListBox(ByVal hwndLB As Long, ByVal X As Single, ByVal Y As Single)

Dim IndexItem As Long
Dim Point As POINTAPI

Point.X = X \ Screen.TwipsPerPixelX
    Point.Y = Y \ Screen.TwipsPerPixelY

Call ClientToScreen(hwndLB, Point)

IndexItem = LBItemFromPt(hwndLB, Point.X, Point.Y, False)

If IndexItem <> SendMessage(hwndLB, LB_GETCURSEL, 0, 0) Then
   Call SendMessage(hwndLB, LB_SETCURSEL, IndexItem, 0)
    End If

End Sub

Private Sub Form_Load()
    Dim i As Long
For i = 0 To 100
        List1.AddItem 1234567 + i
Next
End Sub

Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    HightLightListBox List1.hwnd, X, Y
End Sub

Click here for download the project

Show How To Create Elliptic Form

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 14:18:00 +0000

'Create Elliptic Form 
Option Explicit

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function ReleaseCapture Lib "USER32" () As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "USER32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Private Sub Navigate(frm As Form, ByVal NavTo As String)
    hBrowse = ShellExecute(frm.hWnd, "open", NavTo, "", "", 5)
End Sub

Private Sub Form_Click()
    Unload Me
End Sub

Private Sub Form_Load()
    SetWindowRgn hWnd, CreateEllipticRgn(0, 0, 299, 200), True
End Sub

Private Sub Label2_Click()
    MousePointer = vbHourglass
    Call ShellExecute(frm.hWnd, "open", "http://4basic-vb.blogspot.com", "", "", 5)
    MousePointer = vbDefault
End Sub


Click here for download the project

Clear All TextBox Quickly Using For Each...

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 14:16:00 +0000

'Clear all TextBox quickly using for each... 
Option Explicit

Public Sub ClearAllTextBoxes(frmClearMe As Form)
    Dim txt As Control
    For Each txt In frmClearMe
        If TypeOf txt Is TextBox Then txt.Text = ""
    Next
End Sub

Private Sub Command1_Click()
    ClearAllTextBoxes Me
End Sub

Click here for download the project

Start Your Screen Saver Programmatically Via VB6.0

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 13:08:00 +0000

'Start screen saver programmatically via visual basic 6.0 
Option Explicit

Private 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 Const WM_SYSCOMMAND = &H112&
Private Const SC_SCREENSAVER = &HF140&

Private Sub Command1_Click()
    'call this code to start it.. 
    Call SendMessage(Me.hWnd, WM_SYSCOMMAND, SC_SCREENSAVER, 0&)
End Sub

Click here for download the project

Shell Out The Default Browser Using API Call

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 13:05:00 +0000

'Shell out the default browser 
Option Explicit

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const conSwNormal = 1

Private Sub Command1_Click()
    ShellExecute hwnd, "open", "http://4basic-vb.blogspot.com", vbNullString, vbNullString, conSwNormal
End Sub

Click here for download the project

Send Mail To Someone

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 13:04:00 +0000

'Send mail to someone via VB6.0 
Option Explicit

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const SW_SHOW = 5

Private Sub Command1_Click()
    ShellExecute hwnd, "open", "mailto:4basic.vb@gmail.com", vbNullString, vbNullString, SW_SHOW
End Sub

Click here for download the project

Search A ListBox Control Quickly Using API Call

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 13:02:00 +0000

'Search a ListBox Control Quickly Using API Call 
Option Explicit

Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
Private Const LB_FINDSTRING = &H18F

Private Sub Form_Load()
    With List1
        .AddItem "Asep Hibban"
        .AddItem "Bandung"
        .AddItem "Jakarta"
        .AddItem "Garut"
        .AddItem "Surabaya"
        .AddItem "New York"
        .AddItem "Cireundeu"
        .AddItem "Parabon"
        .AddItem "Cogreg"
    End With
End Sub

Private Sub Text1_Change()
    On Error Resume Next
 List1.ListIndex = SendMessage(List1.hWnd, LB_FINDSTRING, -1, ByVal Text1.Text)
    List1.TopIndex = List1.ListIndex - 1
End Sub

Click here for download the project

Get The ScreenSaver Time-Out Value In Seconds

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 13:00:00 +0000

'Get the screen saver time-out value in seconds. 
Option Explicit

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SPI_GETSCREENSAVETIMEOUT = 14

Private Sub Command1_Click()
    Dim intValue As Integer
  Call SystemParametersInfo(SPI_GETSCREENSAVETIMEOUT, vbNull, intValue, 0)
    MsgBox ("Screen saver time-out value: " & intValue & " seconds.")
End Sub

Click here for download the project

Determine Your Screen Resolution

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 12:58:00 +0000

'Determine your screen resolution 
Option Explicit

Private Sub Command1_Click()
    Dim intWidth As Integer
 Dim intHeight As Integer

 intWidth = Screen.Width \ Screen.TwipsPerPixelX
    intHeight = Screen.Height \ Screen.TwipsPerPixelY
    MsgBox "Screen Resolution:" + vbCrLf + vbCrLf + Str$(intWidth) + " x" + Str$(intHeight), 64, "Info"
End Sub

Click here for download the project

Play MP3 File With OCX

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 12:57:00 +0000

'Play MP3 Files 
Option Explicit

Private Sub Command1_Click()
    MMC.FileName = OpenFile
    Me.Caption = MMC.FileName
    MMC.Command = "open"
    MMC.Command = "play"
End Sub

Private Function OpenFile() As String
  With cdOpen
        .FileName = ""
        .DialogTitle = "Open Files"
        .InitDir = "C:\My Documents"
        .Filter = "MP3 File (*.MP3)|*.MP3"
        .ShowOpen
        If .FileName = "" Then Exit Function
      MMC.Command = "stop"
        OpenFile = .FileName
    End With
End Function

Private Sub Command2_Click()
    MMC.Command = "stop"
End Sub

Click here for download the project

Launch Properties Dialog For A File

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 12:53:00 +0000

'Launch properties dialog for a file 
Option Explicit

'place this code in a form 
Private Sub Command1_Click()
    Call ShowProps(Text1.Text, Me.hwnd)
End Sub

'place this code bellow in a module 
Option Explicit

Type SHELLEXECUTEINFO
    cbSize As Long
  fMask As Long
  hwnd As Long
  lpVerb As String
  lpFile As String
  lpParameters As String
  lpDirectory As String
  nShow As Long
  hInstApp As Long
  lpIDList As Long
  lpClass As String
  hkeyClass As Long
  dwHotKey As Long
  hIcon As Long
  hProcess As Long
End Type

Public Const SEE_MASK_INVOKEIDLIST = &HC
Public Const SEE_MASK_NOCLOSEPROCESS = &H40
Public Const SEE_MASK_FLAG_NO_UI = &H400

Declare Function ShellExecuteEX Lib "shell32.dll" Alias "ShellExecuteEx" (SEI As SHELLEXECUTEINFO) As Long

Public Sub ShowProps(FileName As String, OwnerhWnd As Long)

  Dim SEI As SHELLEXECUTEINFO
    Dim lngReturn As Long

  With SEI
        .cbSize = Len(SEI)
        .fMask = SEE_MASK_NOCLOSEPROCESS Or _
            SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
        .hwnd = OwnerhWnd
        .lpVerb = "properties"
        .lpFile = FileName
        .lpParameters = vbNullChar
        .lpDirectory = vbNullChar
        .nShow = 0
        .hInstApp = 0
        .lpIDList = 0
    End With

  lngReturn = ShellExecuteEX(SEI)

End Sub

Click here for download the project

Get KeyBoardLayout Language From A Thread

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 12:50:00 +0000

'Get GetKeyboardLayout language from a thread 
'Original code by Gringo Man 
Option Explicit

Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long

Public Sub KeyBoardLanguage()

  Dim TheardId As Long
  Dim TheardLang As Long
  Dim processid As Long
 
  TheardId = GetWindowThreadProcessId(hwnd, processid)
    TheardLang = GetKeyboardLayout(ByVal TheardId)
    TheardLang = TheardLang Mod 10000

  If TheardLang = "9721" Then
      MsgBox "English"
    ElseIf TheardLang = "5425" Then
      MsgBox "Arabic"
    End If

End Sub

Private Sub Command1_Click()
    KeyBoardLanguage
End Sub

Click here for download the project

Determine Whether ScreenSaver Is Enabled

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 12:49:00 +0000

'Determine whether screen saver is enabled. 
Option Explicit

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SPI_GETSCREENSAVEACTIVE = 16

Private Function IsScreenSaverEnable() As Boolean
  Dim bReturn As Boolean
  Dim bActive As Boolean
  Call SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, vbNull, bReturn, 0)
    IsScreenSaverEnable = bReturn
End Function

Private Sub Command1_Click()
    MsgBox IsScreenSaverEnable
End Sub

Click here for download the project

Determine How Long Windows Run

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 12:47:00 +0000

'Determine how long windows run in milliseconds and minutes 
Option Explicit

Private Declare Function GetTickCount Lib "Kernel32" () As Long

Private Sub Timer1_Timer()
    Text1.Text = Format(GetTickCount, "0") & " milisceconds"
    Text2.Text = Format(GetTickCount / 60000, "0") & " minutes"
End Sub

Click here for download the project

Simple Encrypt And Decript A String

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 12:43:00 +0000

'Show simple encrypt & Decrypt 
Option Explicit

'This function will encrypt the text 
Function Encrypt(sText As String) As String
  Dim i As Integer
  Dim msg As String
  For i = 1 To Len(sText)
        msg = msg & Chr(Asc(Mid(sText, i, 1)) + 9)
    Next
  Encrypt = msg
End Function

'This function will decrypt the text 
Function Decrypt(sText As String) As String
  Dim i As Integer
  Dim msg As String
  For i = 1 To Len(sText)
        msg = msg & Chr(Asc(Mid(sText, i, 1)) - 9)
    Next
  Decrypt = msg
End Function

Private Sub Command1_Click()
    Text2.Text = Encrypt(Text1.Text)
End Sub

'Sample usage 
Private Sub Command2_Click()
    Text3.Text = Decrypt(Text2.Text)
End Sub

Click here for download the project

Determine Count Of Lines OF A TextBox

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 10:54:00 +0000

'Determine count of lines of a textbox 
Option Explicit

Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const EM_GETLINECOUNT = &HBA

Private Sub Command1_Click()
    Dim lngLineCount As Long
  On Error Resume Next
  lngLineCount = SendMessageLong(Text1.hwnd, EM_GETLINECOUNT, 0&, 0&)
    Text2.Text = Format$(lngLineCount, "##,###")
End Sub

Click here for download the project

Automatically Drops Down ComboBox When Receives The Focus

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 10:50:00 +0000

'Automatically drops down ComboBox when receives the focus 
Option Explicit

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Const CB_SHOWDROPDOWN = &H14F

Private Sub Combo1_GotFocus()
    Call SendMessage(Combo1.hwnd, CB_SHOWDROPDOWN, 1, ByVal 0&)
    If Combo1.ListIndex = -1 Then Combo1.ListIndex = 0
End Sub

Private Sub Form_Load()
    With Combo1
        .AddItem "asep hibban"
        .AddItem "sifahmi"
        .AddItem "galbi" ' 
        .AddItem "karim wafi"
    End With
End Sub

Click here for download the project

Change Your Computer Wallpaper

noreply@blogger.com (Administrator) — Wed, 26 Aug 2009 10:46:00 +0000

'Change your computer wallpaper 
Option Explicit

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long

Private Const SPIF_SENDWININICHANGE = &H2
Private Const SPIF_UPDATEINIFILE = &H1
Private Const SPIF_SETDESKWALLPAPER = 20

Private Sub Command1_Click()
    Call SystemParametersInfo(SPIF_SETDESKWALLPAPER, 0&, App.Path & "\Blue Lace 16.bmp", SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
End Sub

Private Sub Command2_Click()
    Call SystemParametersInfo(SPIF_SETDESKWALLPAPER, 0&, "(None)", SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
End Sub

Click here for download the project

Get Extention Only, Exename Only, Filename Only

noreply@blogger.com (Administrator) — Tue, 25 Aug 2009 18:44:00 +0000

'Get Extention only, Exename Only, Filename Only 
Option Explicit

Public Enum str_KEY
    ExtentionOnly = 0
    ExeNameOnly = 1
    FileNameOnly = 2
End Enum

Public Function GetName(sFilename As String, str As str_KEY) As String
  Dim vArray As Variant, sDelimiter As String
  Select Case str
        Case ExtentionOnly
            sDelimiter = "."
        Case ExeNameOnly
            sDelimiter = "\"
        Case FileNameOnly
            vArray = Split(sFilename, "\")
            GetName = Mid(sFilename, 1, Len(sFilename) - Len(vArray(UBound(vArray))) - 1)
            Exit Function
  End Select
  vArray = Split(sFilename, sDelimiter)
    GetName = vArray(UBound(vArray))
End Function

'Sample Usage Of Function 
Private Sub Command1_Click()
    MsgBox GetName(Text1.Text, ExeNameOnly)
End Sub

Private Sub Command2_Click()
    MsgBox GetName(Text1.Text, ExtentionOnly)
End Sub

Private Sub Command3_Click()
    MsgBox GetName(Text1.Text, FileNameOnly)
End Sub

Click here for download the project

Delete Junk Spaces

noreply@blogger.com (Administrator) — Tue, 25 Aug 2009 18:18:00 +0000

'This Function have purpose for Delete Junk Spaces 
Option Explicit

Private Function DelJunkSpace(str As String) As String
   Do While (InStr(str, "  ") > 0)
        str = Replace(str, "  ", " ")
    Loop
DelJunkSpace = str
End Function

Private Sub Form_Load()
    Dim str As String
   str = "Asep         Hibban        http://4basic-vb.blogspot.com"
    'return = "Asep Hibban http://4basic-vb.blogspot.com" 
    Text1.Text = str
End Sub

Private Sub Command1_Click()
    Dim str As String
   str = Text1.Text
    Text2.Text = DelJunkSpace(str)
End Sub

Click here for download the project

Generator Random Unix Number

noreply@blogger.com (Administrator) — Tue, 25 Aug 2009 15:59:00 +0000

'Generator random unix number 
Option Explicit
'This function will generate random unix number the range from min to max
Private Function GenRanUnix(MIN As Integer, MAX As Integer) As Collection

  Dim iMax As Integer
  Dim iRan As Integer
  Dim g As Integer
  Dim y As Integer
  Dim c As New Collection
  Dim k As New Collection
  Dim f As Integer
  Dim x As Integer
 
  For f = MIN To MAX
        c.Add f
  Next
 
  y = c.Count
    Randomize
 
  For x = 1 To y
      g = Int(y * Rnd + 1)
        k.Add c.Item(g)
        c.Remove g
      y = c.Count
    Next
 
  Set GenRanUnix = k
 
End Function
'Sample usage the range from 0 (min) to 100 (max) 
Private Sub Command1_Click()
    Dim b As New Collection
  Dim i As Integer
  Dim msg As String
  List1.Clear
    Set b = GenRanUnix(0, 100)
    For i = 1 To b.Count
        List1.AddItem b.Item(i)
    Next
End Sub

Click here for download the project

Return Average Number From An Array

noreply@blogger.com (Administrator) — Tue, 25 Aug 2009 15:43:00 +0000

'Return average from an array 
Option Explicit

Function AVERAGE(ByRef Number() As Double) As Double
  Dim iMaxNum As Double, i As Integer
  For i = LBound(Number) To UBound(Number)
        iMaxNum = iMaxNum + Number(i)
    Next i
  AVERAGE = iMaxNum / (UBound(Number) + 1)
End Function

Private Sub Command1_Click()
    Dim iArray(3) As Double
  iArray(0) = 588
    iArray(1) = 67
    iArray(2) = 66
    iArray(3) = 4
    MsgBox "The Average is: " & AVERAGE(iArray)
End Sub

Click here for download the project

Return Min Number From An Array

noreply@blogger.com (Administrator) — Tue, 25 Aug 2009 15:39:00 +0000

'Return min number from an array 
Option Explicit

Private Sub Command1_Click()
    Dim iArray(3) As Double
  iArray(0) = 588
    iArray(1) = 67
    iArray(2) = 66
    iArray(3) = 4
    MsgBox "The min number is: " & MIN(iArray)
End Sub

Function MIN(ByRef Number() As Double) As Double
  Dim iMaxNum As Double
  iMaxNum = Number(LBound(Number))
    Dim i As Integer
  For i = LBound(Number) To UBound(Number)
        If Number(i) < iMaxNum Then
         iMaxNum = Number(i)
        Else
         iMaxNum = iMaxNum
        End If
  Next i
  MIN = iMaxNum
End Function

Click here for download the project

Return Max Number From An Array

noreply@blogger.com (Administrator) — Tue, 25 Aug 2009 15:36:00 +0000

'Return max number from an array 
Option Explicit

Private Sub Command1_Click()
    Dim iArray(3) As Double
  iArray(0) = 588
    iArray(1) = 67
    iArray(2) = 66
    iArray(3) = 4
    MsgBox "The max number is: " & MAX(iArray)
End Sub

Function MAX(ByRef Number() As Double) As Double
  Dim iMaxNum As Double
  Dim i As Integer
  iMaxNum = Number(LBound(Number))
    For i = LBound(Number) To UBound(Number)
        If Number(i) > iMaxNum Then
         iMaxNum = Number(i)
        Else
         iMaxNum = iMaxNum
        End If
  Next i
  MAX = iMaxNum
End Function

Click here for download the project

Simple Way To Tile Vertically All Windows Or Applications

noreply@blogger.com (Administrator) — Tue, 25 Aug 2009 15:16:00 +0000

'Reference to Microsoft Shell Controls And Automation 'Shell32.dll 
'Tile Vertically all windows / application programatically 
Option Explicit

Dim Shell As Shell32.Shell

Private Sub Form_Load()
    Set Shell = New Shell32.Shell
End Sub

Private Sub Command3_Click()
    'Tile Vertically all windows or applications 
    Shell.TileVertically
End Sub

Click here for download the project