none
Forum for Helpful Visual Basic 6.0 Codes... Part 2 RRS feed

  • Question

  • I'm starting Part 2 of the "Helpful VB Codes" thread as i'm facing problems  in the 1st part. Everybody is requested to put their new queries here.
    Tuesday, May 8, 2007 9:14 AM

Answers


  • Code 37 - creates an Access database file with three tables

    Dim ws As Workspace
    Dim db As Database

    Set ws = DBEngine.Workspaces(0)
    Set db = ws.CreateDatabase(App.Path & "\Database.mdb", dbLangGeneral)
        
    Dim dbsNorthwind As Database
    Dim tdfNew As TableDef
    Dim tdfNew2 As TableDef
    Dim tdfNew3 As TableDef
    Dim idxNew As Index
    Dim idxLoop As Index
    Dim fldLoop As Field
    Dim prpLoop As Property

    Set dbsNorthwind = OpenDatabase(App.Path & "\Database.mdb")

    Set tdfNew = dbsNorthwind.CreateTableDef("Name")
        tdfNew.Fields.Append tdfNew.CreateField("ID", dbLong)
        tdfNew.Fields("id").Attributes = tdfNew.Fields("id").Attributes + dbAutoIncrField
        tdfNew.Fields.Append tdfNew.CreateField("First Name", dbText)
        tdfNew.Fields.Append tdfNew.CreateField("Last Name", dbText)
        dbsNorthwind.TableDefs.Append tdfNew
        
    Set tdfNew2 = dbsNorthwind.CreateTableDef("Phone Number")
        tdfNew2.Fields.Append tdfNew2.CreateField("ID", dbLong)
        tdfNew2.Fields("id").Attributes = tdfNew2.Fields("id").Attributes + dbAutoIncrField
        tdfNew2.Fields.Append tdfNew2.CreateField("First Name", dbText)
        tdfNew2.Fields.Append tdfNew2.CreateField("Last Name", dbText)
        tdfNew2.Fields.Append tdfNew2.CreateField("Number", dbText)
        dbsNorthwind.TableDefs.Append tdfNew2

    Set tdfNew3 = dbsNorthwind.CreateTableDef("Email Address")
        tdfNew3.Fields.Append tdfNew3.CreateField("ID", dbLong)
        tdfNew3.Fields("id").Attributes = tdfNew3.Fields("id").Attributes + dbAutoIncrField
        tdfNew3.Fields.Append tdfNew3.CreateField("First Name", dbText)
        tdfNew3.Fields.Append tdfNew3.CreateField("Last Name", dbText)
        tdfNew3.Fields.Append tdfNew3.CreateField("E-Mail", dbText)
        dbsNorthwind.TableDefs.Append tdfNew3

    With tdfNew
        Set idxNew = .CreateIndex("IDIndex")
            idxNew.Fields.Append idxNew.CreateField("ID")
            idxNew.Primary = True
            .Indexes.Append idxNew
        Set idxNew = .CreateIndex("FirstNameIndex")
            idxNew.Fields.Append idxNew.CreateField("First Name")
            .Indexes.Append idxNew
        Set idxNew = .CreateIndex("LastNameIndex")
            idxNew.Fields.Append idxNew.CreateField("Last Name")
            .Indexes.Append idxNew
            
    With tdfNew2
        Set idxNew = .CreateIndex("IDIndex")
            idxNew.Fields.Append idxNew.CreateField("ID")
            idxNew.Primary = True
            .Indexes.Append idxNew
        Set idxNew = .CreateIndex("FirstNameIndex")
            idxNew.Fields.Append idxNew.CreateField("First Name")
            .Indexes.Append idxNew
        Set idxNew = .CreateIndex("LastNameIndex")
            idxNew.Fields.Append idxNew.CreateField("Last Name")
            .Indexes.Append idxNew
        Set idxNew = .CreateIndex("NumberIndex")
            idxNew.Fields.Append idxNew.CreateField("Number")
            .Indexes.Append idxNew


    With tdfNew3
        Set idxNew = .CreateIndex("IDIndex")
            idxNew.Fields.Append idxNew.CreateField("ID")
            idxNew.Primary = True
            .Indexes.Append idxNew
        Set idxNew = .CreateIndex("FirstNameIndex")
            idxNew.Fields.Append idxNew.CreateField("First Name")
            .Indexes.Append idxNew
        Set idxNew = .CreateIndex("LastNameIndex")
            idxNew.Fields.Append idxNew.CreateField("Last Name")
            .Indexes.Append idxNew
        Set idxNew = .CreateIndex("EmailIndex")
            idxNew.Fields.Append idxNew.CreateField("E-Mail")
            .Indexes.Append idxNew

        Debug.Print .Indexes.Count & " Indexes in " & _
            .Name & " TableDef"

        For Each idxLoop In .Indexes

            With idxLoop
                Debug.Print "    " & .Name

                Debug.Print "        Fields"
                For Each fldLoop In .Fields
                    Debug.Print "            " & fldLoop.Name
                Next fldLoop

                Debug.Print "        Properties"

                For Each prpLoop In .Properties
                    Debug.Print "            " & prpLoop.Name & _
                        " = " & IIf(prpLoop = "", "[empty]", _
                        prpLoop)
                Next prpLoop
            End With

        Next idxLoop

    End With
    End With
    End With

    dbsNorthwind.Close

    Tuesday, May 8, 2007 9:18 AM

  • Code 38 - Getting CPU back for ADO

    Dim cmd As ADODB.Command
    Set cmd = New ADODB.Command

            cmd.ActiveConnection = "DSN=test"
            cmd.CommandTimeout = 180
            cmd.CommandText = "sp_name"
            cmd.CommandType = adCmdStoredProc
            cmd.Execute , , adAsyncExecute'<--- start ASYNCHROUS

    'You can also make a dumy progress bar to show proggres
    Do While (cmd.State And adStateExecuting) = adStateExecuting
                DoEvents
    Loop

    Tuesday, May 8, 2007 9:22 AM

  • Code 39 - Concise code to populate ADO recordset from MSAccess query with multiple parameters

    'Set reference to ADO library first.
    'In my test, the parameter query in MSAccess looks like this (for testing purpose only):
    'SELECT Titles.Title, Titles.[Year Published], Titles.PubID, Publishers.Name, 'Publishers.State
    'FROM Publishers INNER JOIN Titles ON Publishers.PubID = Titles.PubID
    'WHERE (((Titles.[Year Published])>=[SatartDate] And (Titles.[Year 'Published])<=[EndDate])
    'AND ((Publishers.State)=[StateParam]) AND '((Publishers.PubID)<=[PubIDParam]));
    '
    '
      Dim Cnn As New ADODB.Connection
      Dim Rst As New ADODB.Recordset
      '
      'Open a Connection using an ODBC DSN. You can not use Jet OLEDB Provider here.
      Cnn.Open "DSN=adoobj;UID=;PWD=;"
      '
      Set Rst = Cnn.Execute("Qry_MultiPrm #1/1/98#, #12/12/00#, 'MA', 8", , mdStoredProc)
      '
      Do While Not Rst.EOF
        Debug.Print Rst(0)
        Rst.MoveNext
      Loop
     
      Set Rst = Nothing
      Set Cnn = Nothing
      '

    Tuesday, May 8, 2007 9:23 AM

  • Code 40 - Code for converting the Parameterized ADO Command object into a SQL String that can be executed in Query-Analyzer for better error diagnostics

    '   The following code is for converting the Parameterized ADO Command object into a SQL String
    '   that can be executed in Query-Analyzer

    Public Function Cmd2SQL(objCmd As ADODB.Command) As String
    '-------------------------------------------------------
    ' Name:        Cmd2SQL
    ' Description: Takes and ADO Command object and translates it into a SQL string
    '              that you can run in Query-Analyzer to get a better error message or use
    '              in your application
    ' Parameters:  objCmd As ADODB.Command
    ' Returns:     String - the parameter text with or without quotation wrappers
    '-------------------------------------------------------
     Dim strSQL As String
     Dim n As Integer
     
        ' Take out all extra characters in CommandText
        strSQL = objCmd.CommandText
        strSQL = Replace(strSQL, "?", "")
        strSQL = Replace(strSQL, "{", "")
        strSQL = Replace(strSQL, "}", "")
        strSQL = Replace(strSQL, " ", "")
        strSQL = Replace(strSQL, "call", "")
        strSQL = Replace(strSQL, "(", "")
        strSQL = Replace(strSQL, ")", "")
        strSQL = Replace(strSQL, ",", "")
        strSQL = Replace(strSQL, "=", "")

     ' Convert parameter names to SQL @parameters
      For n = 0 To objCmd.Parameters.Count - 1
        If objCmd.Parameters(n).Name <> "RETURN_VALUE" Then
            strSQL = strSQL & " @" & objCmd.Parameters(n).Name & " = " & _
            WrapWithApos(objCmd.Parameters(n)) & ", "
        End If
      Next n

     ' Take off trailing comma
     Cmd2SQL = Left(strSQL, Len(RTrim(strSQL)) - 1)

    End Function

    Private Function WrapWithApos(prm As ADODB.Parameter) As String
    '-------------------------------------------------------
    ' Name:        WrapWithApos
    ' Description: Interrogates parameter for special cases then calls the Quote
    '              function to wrap the parameter value with quotes if applicable
    ' Parameters:  prm As ADODB.Parameter
    ' Returns:     String - the parameter text with or without quotation wrappers
    '-------------------------------------------------------
     Dim strText As String

        If IsNull(prm.Value) Then
            strText = "NULL"
        ElseIf IsDate(prm.Value) Then
            strText = "'" & prm.Value & "'"
        Else
            strText = prm.Value
        End If

        If prm.Value <> "NULL" Then
            If Quote(prm.Type) = True Then
                strText = "'" & RTrim(strText) & "'"
            End If
        End If
     WrapWithApos = RTrim(strText)
    End Function

    Private Function Quote(intPrmType As Integer) As Boolean
    '-------------------------------------------------------
    ' Name:        Quote
    ' Description: This function determines if a ADO Command Object Parameter should
    '              be wrapped with quotes when it is converted to a SQL string or not
    ' Parameters:  Parameter Type as integer
    ' Returns:     Boolean
    '               True - this is a string param and should be wrapped with quotes
    '               False - this is a numeric param and should not
    '-------------------------------------------------------
     Dim bolVarQuote As Boolean

        Select Case intPrmType
            Case Is = adNumeric
            Case Is = adVarBinary
            Case Is = adUnsignedTinyInt
            Case Is = adSmallInt
            Case Is = adBoolean
            Case Is = adSingle
            Case Is = adCurrency
            Case Is = adInteger
            Case Is = adDouble
            Case Is = adBinary
            Case Is = adVarBinary
            Case Is = adLongVarBinary

            Case Is = adLongVarWChar
                bolVarQuote = True
            Case Is = adVarChar
                bolVarQuote = True
            Case Is = adWChar
                bolVarQuote = True
            Case Is = adDBTimeStamp
                bolVarQuote = True
            Case Else
                bolVarQuote = True
            End Select
        Quote = bolVarQuote
    End Function

    Tuesday, May 8, 2007 9:25 AM

  • Code 41 : Shell out to default web browser
    Declarations

    'used for shelling out to the default web browser
    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
    Public Const conSwNormal = 1




    Code 41 : Shell out to default web browser

    ShellExecute hwnd, "open", "http://www.google.com", vbNullString, vbNullString, conSwNormal



    Sunday, May 20, 2007 8:22 AM

  • Code 43 : Launch default mail program to send an email message

    Declarations

    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




    Code 43 : Launch default mail program to send an email message

    Code

        ShellExecute hwnd, "open", "mailto:sanket.shah@rediffmail.com", vbNullString, vbNullString, SW_SHOW



    Sunday, May 20, 2007 8:28 AM

  • Code 44 : Create an Internet shortcut

    'Call the CreateInternetShortCut function to create a shortcut. 
    'Here is an example...   
    CreateInternetShortCut "C:\windows\desktop\test.url", "http://www.google.com"

    Sub CreateInternetShortCut(URLFile As String, URLTarget As String)

    'An Internet Shortcut takes on the form of
    '   [InternetShortcut]
    '   URL=http://sanket.textilestudies.com  

        Dim intFreeFile As Integer

        'get free file number
        intFreeFile = FreeFile
       
        'print the URL file
        Open URLFile For Output As intFreeFile
        Print #intFreeFile, "[InternetShortcut]"
        Print #intFreeFile, "URL=" & URLTarget
        Close intFreeFile
       
    End Sub

    Sunday, May 20, 2007 8:34 AM

  • Code 45 : Dial Internet using Dial Up Networking (DUN) to connect

    Declarations

    Const Internet_Autodial_Force_Unattended As Long = 2

    Public Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
    Public Declare Function InternetAutodialHangup Lib "wininet.dll" (ByVal dwReserved As Long) As Long




    Code 45 : Dial Internet using Dial Up Networking (DUN) to connect

    Code

    Dim lResult As Long
    lResult = InternetAutodial(Internet_Autodial_Force_Unattended, 0&)



    Sunday, May 20, 2007 8:36 AM

  • Code 46 : Close dial-up internet connection
    Declarations

    Const Internet_Autodial_Force_Unattended As Long = 2

    Public Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
    Public Declare Function InternetAutodialHangup Lib "wininet.dll" (ByVal dwReserved As Long) As Long




    Code 46 : Close dial-up internet connection
    Code

    Dim lResult As Long
    lResult = InternetAutodialHangup(0&)


    Sunday, May 20, 2007 8:38 AM

  • Code 47 : Send Mail from Visual Basic Using OLE Messaging

    ' 1) Open a new project in Visual Basic.
    ' 2) On the Tools menu, choose References and select the Microsoft CDO 1.21 Library.
    ' 3) Add a CommandButton to the default form. Accept the default name, Command1.
    ' 4) Copy the following code into the General Declarations section of the default form:


    Option Explicit


    Private Sub Command1_Click()
      Dim objSession As Object
      Dim objMessage As Object
      Dim objRecipient As Object


      'Create the Session Object
      Set objSession = CreateObject("mapi.session")


      'Logon using the session object
      'Specify a valid profile name if you want to
      'Avoid the logon dialog box
      objSession.Logon profileName:="MS Exchange Settings"


      'Add a new message object to the OutBox
      Set objMessage = objSession.Outbox.Messages.Add


      'Set the properties of the message object
      objMessage.subject = "This is a test."
      objMessage.Text = "This is the message text."


      'Add a recipient object to the objMessage.Recipients collection
      Set objRecipient = objMessage.Recipients.Add


      'Set the properties of the recipient object
      objRecipient.Name = "sanket.shah@rediffmail.com"  '<---Replace this with a valid
                                      'display name or e-mail alias
      objRecipient.Type = mapiTo
      objRecipient.Resolve

      'Send the message
      objMessage.Send showDialog:=False
      MsgBox "Message sent successfully!"

      'Logoff using the session object
      objSession.Logoff
    End Sub


    Sunday, May 20, 2007 8:41 AM

  • Code 48 : How to ping an IP address using VB

    '1) Place a command button on the form and place this code in the Click event
       Dim ECHO As ICMP_ECHO_REPLY
       Dim pos As Integer
      
      'ping an ip address, passing the
      'address and the ECHO structure
       Call Ping("202.54.10.2", ECHO)
      
      'display the results from the ECHO structure
       Form1.Print GetStatusCode(ECHO.status)
       Form1.Print ECHO.Address
       Form1.Print ECHO.RoundTripTime & " ms"
       Form1.Print ECHO.DataSize & " bytes"
      
       If Left$(ECHO.Data, 1) <> Chr$(0) Then
          pos = InStr(ECHO.Data, Chr$(0))
          Form1.Print Left$(ECHO.Data, pos - 1)
       End If

       Form1.Print ECHO.DataPointer

    '2) Add a .BAS module and paste this code in that module
    '3) Click the command button
    Option Explicit

    Public Const IP_STATUS_BASE = 11000
    Public Const IP_SUCCESS = 0
    Public Const IP_BUF_TOO_SMALL = (11000 + 1)
    Public Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
    Public Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
    Public Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
    Public Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
    Public Const IP_NO_RESOURCES = (11000 + 6)
    Public Const IP_BAD_OPTION = (11000 + 7)
    Public Const IP_HW_ERROR = (11000 + 8)
    Public Const IP_PACKET_TOO_BIG = (11000 + 9)
    Public Const IP_REQ_TIMED_OUT = (11000 + 10)
    Public Const IP_BAD_REQ = (11000 + 11)
    Public Const IP_BAD_ROUTE = (11000 + 12)
    Public Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
    Public Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
    Public Const IP_PARAM_PROBLEM = (11000 + 15)
    Public Const IP_SOURCE_QUENCH = (11000 + 16)
    Public Const IP_OPTION_TOO_BIG = (11000 + 17)
    Public Const IP_BAD_DESTINATION = (11000 + 18)
    Public Const IP_ADDR_DELETED = (11000 + 19)
    Public Const IP_SPEC_MTU_CHANGE = (11000 + 20)
    Public Const IP_MTU_CHANGE = (11000 + 21)
    Public Const IP_UNLOAD = (11000 + 22)
    Public Const IP_ADDR_ADDED = (11000 + 23)
    Public Const IP_GENERAL_FAILURE = (11000 + 50)
    Public Const MAX_IP_STATUS = 11000 + 50
    Public Const IP_PENDING = (11000 + 255)
    Public Const PING_TIMEOUT = 200
    Public Const WS_VERSION_REQD = &H101
    Public Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
    Public Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
    Public Const MIN_SOCKETS_REQD = 1
    Public Const SOCKET_ERROR = -1

    Public Const MAX_WSADescription = 256
    Public Const MAX_WSASYSStatus = 128

    Public Type ICMP_OPTIONS
        Ttl             As Byte
        Tos             As Byte
        Flags           As Byte
        OptionsSize     As Byte
        OptionsData     As Long
    End Type

    Dim ICMPOPT As ICMP_OPTIONS

    Public Type ICMP_ECHO_REPLY
        Address         As Long
        status          As Long
        RoundTripTime   As Long
        DataSize        As Integer
        Reserved        As Integer
        DataPointer     As Long
        Options         As ICMP_OPTIONS
        Data            As String * 250
    End Type

    Public Type HOSTENT
        hName As Long
        hAliases As Long
        hAddrType As Integer
        hLen As Integer
        hAddrList As Long
    End Type

    Public Type WSADATA
        wVersion As Integer
        wHighVersion As Integer
        szDescription(0 To MAX_WSADescription) As Byte
        szSystemStatus(0 To MAX_WSASYSStatus) As Byte
        wMaxSockets As Integer
        wMaxUDPDG As Integer
        dwVendorInfo As Long
    End Type


    Public Declare Function IcmpCreateFile Lib "icmp.dll" () As Long

    Public Declare Function IcmpCloseHandle Lib "icmp.dll" _
       (ByVal IcmpHandle As Long) As Long
      
    Public Declare Function IcmpSendEcho Lib "icmp.dll" _
       (ByVal IcmpHandle As Long, _
        ByVal DestinationAddress As Long, _
        ByVal RequestData As String, _
        ByVal RequestSize As Integer, _
        ByVal RequestOptions As Long, _
        ReplyBuffer As ICMP_ECHO_REPLY, _
        ByVal ReplySize As Long, _
        ByVal Timeout As Long) As Long
       
    Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long

    Public Declare Function WSAStartup Lib "WSOCK32.DLL" _
       (ByVal wVersionRequired As Long, _
        lpWSADATA As WSADATA) As Long
       
    Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long

    Public Declare Function gethostname Lib "WSOCK32.DLL" _
       (ByVal szHost As String, _
        ByVal dwHostLen As Long) As Long
       
    Public Declare Function gethostbyname Lib "WSOCK32.DLL" _
       (ByVal szHost As String) As Long
      
    Public Declare Sub RtlMoveMemory Lib "kernel32" _
       (hpvDest As Any, _
        ByVal hpvSource As Long, _
        ByVal cbCopy As Long)


    Public Function GetStatusCode(status As Long) As String

       Dim msg As String

       Select Case status
          Case IP_SUCCESS:               msg = "ip success"
          Case IP_BUF_TOO_SMALL:         msg = "ip buf too_small"
          Case IP_DEST_NET_UNREACHABLE:  msg = "ip dest net unreachable"
          Case IP_DEST_HOST_UNREACHABLE: msg = "ip dest host unreachable"
          Case IP_DEST_PROT_UNREACHABLE: msg = "ip dest prot unreachable"
          Case IP_DEST_PORT_UNREACHABLE: msg = "ip dest port unreachable"
          Case IP_NO_RESOURCES:          msg = "ip no resources"
          Case IP_BAD_OPTION:            msg = "ip bad option"
          Case IP_HW_ERROR:              msg = "ip hw_error"
          Case IP_PACKET_TOO_BIG:        msg = "ip packet too_big"
          Case IP_REQ_TIMED_OUT:         msg = "ip req timed out"
          Case IP_BAD_REQ:               msg = "ip bad req"
          Case IP_BAD_ROUTE:             msg = "ip bad route"
          Case IP_TTL_EXPIRED_TRANSIT:   msg = "ip ttl expired transit"
          Case IP_TTL_EXPIRED_REASSEM:   msg = "ip ttl expired reassem"
          Case IP_PARAM_PROBLEM:         msg = "ip param_problem"
          Case IP_SOURCE_QUENCH:         msg = "ip source quench"
          Case IP_OPTION_TOO_BIG:        msg = "ip option too_big"
          Case IP_BAD_DESTINATION:       msg = "ip bad destination"
          Case IP_ADDR_DELETED:          msg = "ip addr deleted"
          Case IP_SPEC_MTU_CHANGE:       msg = "ip spec mtu change"
          Case IP_MTU_CHANGE:            msg = "ip mtu_change"
          Case IP_UNLOAD:                msg = "ip unload"
          Case IP_ADDR_ADDED:            msg = "ip addr added"
          Case IP_GENERAL_FAILURE:       msg = "ip general failure"
          Case IP_PENDING:               msg = "ip pending"
          Case PING_TIMEOUT:             msg = "ping timeout"
          Case Else:                     msg = "unknown  msg returned"
       End Select
      
       GetStatusCode = CStr(status) & "   [ " & msg & " ]"
      
    End Function


    Public Function HiByte(ByVal wParam As Integer)

        HiByte = wParam \ &H100 And &HFF&

    End Function


    Public Function LoByte(ByVal wParam As Integer)

        LoByte = wParam And &HFF&

    End Function


    Public Function Ping(szAddress As String, ECHO As ICMP_ECHO_REPLY) As Long

       Dim hPort As Long
       Dim dwAddress As Long
       Dim sDataToSend As String
       Dim iOpt As Long
      
       sDataToSend = "Echo This"
       dwAddress = AddressStringToLong(szAddress)
      
       Call SocketsInitialize
       hPort = IcmpCreateFile()
      
       If IcmpSendEcho(hPort, _
                       dwAddress, _
                       sDataToSend, _
                       Len(sDataToSend), _
                       0, _
                       ECHO, _
                       Len(ECHO), _
                       PING_TIMEOUT) Then
      
            'the ping succeeded,
            '.Status will be 0
            '.RoundTripTime is the time in ms for
            '               the ping to complete,
            '.Data is the data returned (NULL terminated)
            '.Address is the Ip address that actually replied
            '.DataSize is the size of the string in .Data
             Ping = ECHO.RoundTripTime
       Else: Ping = ECHO.status * -1
       End If
                          
       Call IcmpCloseHandle(hPort)
       Call SocketsCleanup
      
    End Function
      

    Function AddressStringToLong(ByVal tmp As String) As Long

       Dim i As Integer
       Dim parts(1 To 4) As String
      
       i = 0
      
      'we have to extract each part of the
      '123.456.789.123 string, delimited by
      'a period
       While InStr(tmp, ".") > 0
          i = i + 1
          parts(i) = Mid(tmp, 1, InStr(tmp, ".") - 1)
          tmp = Mid(tmp, InStr(tmp, ".") + 1)
       Wend
      
       i = i + 1
       parts(i) = tmp
      
       If i <> 4 Then
          AddressStringToLong = 0
          Exit Function
       End If
      
      'build the long value out of the
      'hex of the extracted strings
       AddressStringToLong = Val("&H" & Right("00" & Hex(parts(4)), 2) & _
                             Right("00" & Hex(parts(3)), 2) & _
                             Right("00" & Hex(parts(2)), 2) & _
                             Right("00" & Hex(parts(1)), 2))
      
    End Function


    Public Function SocketsCleanup() As Boolean

        Dim X As Long
       
        X = WSACleanup()
       
        If X <> 0 Then
            MsgBox "Windows Sockets error " & Trim$(Str$(X)) & _
                   " occurred in Cleanup.", vbExclamation
            SocketsCleanup = False
        Else
            SocketsCleanup = True
        End If
       
    End Function


    Public Function SocketsInitialize() As Boolean

        Dim WSAD As WSADATA
        Dim X As Integer
        Dim szLoByte As String, szHiByte As String, szBuf As String
       
        X = WSAStartup(WS_VERSION_REQD, WSAD)
       
        If X <> 0 Then
            MsgBox "Windows Sockets for 32 bit Windows " & _
                   "environments is not successfully responding."
            SocketsInitialize = False
            Exit Function
        End If
       
        If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
           (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
            HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
           
            szHiByte = Trim$(Str$(HiByte(WSAD.wVersion)))
            szLoByte = Trim$(Str$(LoByte(WSAD.wVersion)))
            szBuf = "Windows Sockets Version " & szLoByte & "." & szHiByte
            szBuf = szBuf & " is not supported by Windows " & _
                              "Sockets for 32 bit Windows environments."
            MsgBox szBuf, vbExclamation
            SocketsInitialize = False
            Exit Function
           
        End If
       
        If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
            szBuf = "This application requires a minimum of " & _
                     Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
            MsgBox szBuf, vbExclamation
            SocketsInitialize = False
            Exit Function
        End If
       
        SocketsInitialize = True
           
    End Function

    Sunday, May 20, 2007 8:46 AM

  • Code 49 : Add Images to Menu Items (Along with the Text)

    Declarations

    Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
    Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
    Public Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
    Public Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long

    Public Const MF_BITMAP = &H4




    Code 49 : Add Images to Menu Items (Along with the Text)

    Public Sub AddImageToMenuItem(hMenu As Long, lSubMenuPos As Long, lMenuItemPos As Long, _
                                  imlImageList As ImageList, lImagePos As Long)
    ' Add the selected bitmap to the given menu item.
    '
    ' hMenu - the menu handle for the menu you want to modify.
    ' lSubMenuPos - the position of the submenu (0 based).
    ' lMenuItemPos - the position of the menu item (0 based).
    ' imlImageList - the imagelist from which you will get the images.
    ' lImagePos - the position in the image list where the image is stored.
        Dim hSubMenu As Long
        Dim lMenuID As Long
        Dim lRet As Long
     
        On Error GoTo AddImageToMenuItem_Error
     
        ' Get the submenu handle.
        hSubMenu = GetSubMenu(hMenu, lSubMenuPos)
     
        ' Get the menu item id.
        lMenuID = GetMenuItemID(hSubMenu, lMenuItemPos)
       
        ' Make the call that puts the Bitmap in.
        lRet = SetMenuItemBitmaps(hMenu, lMenuID, MF_BITMAP, imlImageList.ListImages(lImagePos).Picture, imlImageList.ListImages(lImagePos).Picture)
     
        Exit Sub
     
    AddImageToMenuItem_Error:
       ' Appropriate error handling.
    End Sub




    Private Sub AddMenuBitmapsPrototype()
        Dim hMenu As Long
       
        hMenu = GetMenu(Me.hwnd)
       
        Call AddImageToMenuItem(hMenu, 0, 0, imlMainToolBarImageList, 1)
    End Sub


    Images should be 13x13 or smaller to fit properly into the menu.
    This takes images from an ImageList control, but, of course, you can modify
    this to use any control that has a Picture property.
    Can be modified to take a Key instead of a position for the images in the ImageList.



    Sunday, May 20, 2007 8:48 AM

  • Code 50 : Turns on Cap's Lock through your program

    Sub CapsON ()
    Call SetKeyboardState(VbKeyCaps)
    End sub

    Sunday, May 20, 2007 8:49 AM

  • Code 51 : Automatically calls up Dial Up Networking and "Clicks" Connect

    'Place the following code under a command button or in a menu, etc...

    Dim X
    '"TATA Broadband" is the name under the icon in Dial-up Networking
    X = Shell("rundll32.exe rnaui.dll,RnaDial " & "TATA Broadband", 1)
    DoEvents
    'You can type in your password before the { below.
    SendKeys "{enter}", True
    DoEvents
    'End Sub

    Sunday, May 20, 2007 8:51 AM

  • Code 52 : Find IP address ginving the hostname

    Declarations


    'Here's sample code for gethostbyname()

    'Add a textbox (Text1) And a Command button (Command1) To a New form And use the following code:

    'Usage: Fill in the textbox with the name you want to resolve and click the command button to resolve the name.

    Private Const WS_VERSION_REQD = &H101
    Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
    Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
    Private Const MIN_SOCKETS_REQD = 1
    Private Const SOCKET_ERROR = -1
    Private Const WSADescription_Len = 256
    Private Const WSASYS_Status_Len = 128

    Private Type HOSTENT
       hName As Long
       hAliases As Long
       hAddrType As Integer
       hLength As Integer
       hAddrList As Long
    End Type

    Private Type WSADATA
       wversion As Integer
       wHighVersion As Integer
       szDescription(0 To WSADescription_Len) As Byte
       szSystemStatus(0 To WSASYS_Status_Len) As Byte
       iMaxSockets As Integer
       iMaxUdpDg As Integer
       lpszVendorInfo As Long
    End Type

    Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
    Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired&, lpWSAData As WSADATA) As Long
    Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
    Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname$) As Long
    Private Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)





    Code 52 : Find IP address ginving the hostname

    Code


    Function hibyte(ByVal wParam As Integer)
      
       hibyte = wParam \ &H100 And &HFF&
      
    End Function

    Function lobyte(ByVal wParam As Integer)
      
       lobyte = wParam And &HFF&
      
    End Function

    Sub SocketsInitialize()
      
       Dim WSAD As WSADATA
       Dim iReturn As Integer
       Dim sLowByte As String, sHighByte As String, sMsg As String
      
       iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
      
       If iReturn <> 0 Then
          MsgBox "Winsock.dll is not responding."
          End
       End If
      
       If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then
          sHighByte = Trim$(Str$(hibyte(WSAD.wversion)))
          sLowByte = Trim$(Str$(lobyte(WSAD.wversion)))
          sMsg = "Windows Sockets version " & sLowByte & "." & sHighByte
          sMsg = sMsg & " is not supported by winsock.dll "
          MsgBox sMsg
          End
       End If
      
       If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
          sMsg = "This application requires a minimum of "
          sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
          MsgBox sMsg
          End
       End If
      
    End Sub

    Sub SocketsCleanup()
       Dim lReturn As Long
      
       lReturn = WSACleanup()
      
       If lReturn <> 0 Then
          MsgBox "Socket error " & Trim$(Str$(lReturn)) & " occurred in Cleanup "
          End
       End If
      
    End Sub

    Sub Form_Load()
      
       SocketsInitialize
      
    End Sub

    Private Sub Form_Unload(Cancel As Integer)
      
       SocketsCleanup
      
    End Sub

    Private Sub Command1_click()
       Dim hostent_addr As Long
       Dim host As HOSTENT
       Dim hostip_addr As Long
       Dim temp_ip_address() As Byte
       Dim i As Integer
       Dim ip_address As String
      
       hostent_addr = gethostbyname(Text1)
      
       If hostent_addr = 0 Then
          MsgBox "Can't resolve name."
          Exit Sub
       End If
      
       RtlMoveMemory host, hostent_addr, LenB(host)
       RtlMoveMemory hostip_addr, host.hAddrList, 4
      
       ReDim temp_ip_address(1 To host.hLength)
       RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
      
       For i = 1 To host.hLength
          ip_address = ip_address & temp_ip_address(i) & "."
       Next
       ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
      
       MsgBox ip_address
      
    End Sub




    Sunday, May 20, 2007 8:53 AM

  • Code 53 : SMTP Mail Program

    'you MUST put the Winsock1 control on your form
    'and this will work VERY quickly!!

    Dim Response As String, Reply As Integer, DateNow As String
    Dim first As String, Second As String, Third As String
    Dim Fourth As String, Fifth As String, Sixth As String
    Dim Seventh As String, Eighth As String
    Dim Start As Single, Tmr As Single



    Sub SendEmail(MailServerName As String, FromName As String, FromEmailAddress As String, ToName As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String)
              
        Winsock1.LocalPort = 0 ' Must set local port to 0 (Zero) or you can only send 1 e-mail pre program start
        
    If Winsock1.State = sckClosed Then ' Check to see if socet is closed
        DateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600"
        first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf ' Get who's sending E-Mail address
        Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf ' Get who mail is going to
        Third = "Date:" + Chr(32) + DateNow + vbCrLf ' Date when being sent
        Fourth = "From:" + Chr(32) + FromName + vbCrLf ' Who's Sending
        Fifth = "To:" + Chr(32) + ToNametxt + vbCrLf ' Who it going to
        Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf ' Subject of E-Mail
        Seventh = EmailBodyOfMessage + vbCrLf ' E-mail message body
        Ninth = "mouse mailer" + vbCrLf ' What program sent the e-mail, customize this
        Eighth = Fourth + Third + Ninth + Fifth + Sixth  ' Combine for proper SMTP sending

        Winsock1.Protocol = sckTCPProtocol ' Set protocol for sending
        Winsock1.RemoteHost = MailServerName ' Set the server address
        Winsock1.RemotePort = 25 ' Set the SMTP Port
        Winsock1.Connect ' Start connection
        
        WaitFor ("220")
        
        StatusTxt.Caption = "Connecting...."
        StatusTxt.Refresh
        
        Winsock1.SendData ("HELO worldcomputers.com" + vbCrLf)

        WaitFor ("250")

        StatusTxt.Caption = "Connected"
        StatusTxt.Refresh

        Winsock1.SendData (first)

        StatusTxt.Caption = "Sending Message"
        StatusTxt.Refresh

        WaitFor ("250")

        Winsock1.SendData (Second)

        WaitFor ("250")

        Winsock1.SendData ("data" + vbCrLf)
        
        WaitFor ("354")


        Winsock1.SendData (Eighth + vbCrLf)
        Winsock1.SendData (Seventh + vbCrLf)
        Winsock1.SendData ("." + vbCrLf)

        WaitFor ("250")

        Winsock1.SendData ("quit" + vbCrLf)
        
        StatusTxt.Caption = "Disconnecting"
        StatusTxt.Refresh

        WaitFor ("221")

        Winsock1.Close
    Else
        MsgBox (Str(Winsock1.State))
    End If
       
    End Sub
    Sub WaitFor(ResponseCode As String)
        Start = Timer ' Time event so won't get stuck in loop
        While Len(Response) = 0
            Tmr = Start - Timer
            DoEvents ' Let System keep checking for incoming response **IMPORTANT**
            If Tmr > 50 Then ' Time in seconds to wait
                MsgBox "SMTP service error, timed out while waiting for response", 64, MsgTitle
                Exit Sub
            End If
        Wend
        While Left(Response, 3) <> ResponseCode
            DoEvents
            If Tmr > 50 Then
                MsgBox "SMTP service error, impromper response code. Code should have been: " + ResponseCode + " Code recieved: " + Response, 64, MsgTitle
                Exit Sub
            End If
        Wend
    Response = "" ' Sent response code to blank **IMPORTANT**
    End Sub


    Private Sub Command1_Click()
        SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtEmailBodyOfMessage.Text
        'MsgBox ("Mail Sent")
        StatusTxt.Caption = "Mail Sent"
        StatusTxt.Refresh
        Beep
        
        Close
    End Sub

    Private Sub Command2_Click()
        
        End
        
    End Sub

    Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)

        Winsock1.GetData Response ' Check for incoming response *IMPORTANT*

    End Sub

    Sunday, May 20, 2007 9:04 AM

  • Code 54 : Retreve a web page's source through your program using The Inet OCX

    Function OpenUrl (URL)
    Dim P() as byte
    Dim T as string
    B = Inet1.OpenUrl(URL)
    For i = 1 to len(B)
    T = T + UBound(P(T))
    next i
    End function

    Sunday, May 20, 2007 9:06 AM

  • Code 55 : Use the Microsoft Internet Control to determine when a web page was last modified

    'set a reference to the Microsoft Internet Control and then use the code below.

        Dim strHeader As String
       
        'set protocol to HTTP
        Inet1.Protocol = icHTTP
       
        'open URL
        Inet1.OpenURL ("http://www.microsoft.com")
       
        ' Retrieve the date page was last modified
        strHeader = Inet1.GetHeader("Last-modified")
       
        MsgBox strHeader

    Sunday, May 20, 2007 9:07 AM

  • Code 56 : This function returns any of the various components of the URL that are present

    Declarations

    Public Type typURL 'http://sit:sitter@proxy.spiderit.net:881/prox/proxycfg.php3?openpage
        Protocol    As String   'contains the protocol if specified (e.g. http://, ftp:// etc.)
        ServerName  As String   'contains the servername (e.g. proxy.spiderit.net)
        Filename    As String   'contains the filename (e.g. proxycfg.php3)
        Dir         As String   'contains the directory (e.g. /prox/)
        Filepath    As String   'contains the whole filepath (e.g. /prox/proxycfg.php3)
        Username    As String   'contains the username (e.g. sit)
        Password    As String   'contains the password (e.g. sitter)
        Query       As String   'contains the querystring (e.g. openpage)
        ServerPort  As Integer  'contains the serverport (e.g. 881)
    End Type

    Public Const strNOCONTENT As String = "NOCONTENT"
    Public Const intDEFAULTPORT As Integer = 80

    Function ParseURL(URL As String) As typURL
    Dim strTemp As String
    Dim strServerAuth As String
    Dim strServerNPort As String
    Dim strAuth As String


    strTemp = URL

    '********
    '- Parse protocol
    If (InStr(1, strTemp, "://") > 0) Then
        'URL contains protocol
        ParseURL.Protocol = Left(strTemp, InStr(1, strTemp, "://") - 1)
        strTemp = Right(strTemp, Len(strTemp) - (Len(ParseURL.Protocol) + 3)) 'delete protocol + ://
    Else
        'URL do not contains the protocol
        ParseURL.Protocol = strNOCONTENT
    End If

    '********
    '- Parse authenticate information
    If (InStr(1, strTemp, "/") > 0) Then
        'extract servername and user and password if there are directory infos
        strServerAuth = Left(strTemp, InStr(1, strTemp, "/") - 1)
        strTemp = Right(strTemp, Len(strTemp) - (Len(strServerAuth) + 1))
    Else
        'extract servername and user and password if there are no directory infos
        strServerAuth = strTemp
        strTemp = "/"
    End If

    If (InStr(1, strServerAuth, "@") > 0) Then
        'there are user and password informations
        strAuth = Left(strServerAuth, InStr(1, strServerAuth, "@") - 1)
        strServerNPort = Right(strServerAuth, Len(strServerAuth) - (Len(strAuth) + 1))
    Else
        'there are no user and password informations
        strAuth = ""
        strServerNPort = strServerAuth
    End If

    If (InStr(1, strAuth, ":") > 0) And (Len(strAuth) > 0) Then
        'split username and password on ":" splitter
        ParseURL.Username = Left(strAuth, InStr(1, strAuth, ":") - 1)
        ParseURL.Password = Right(strAuth, Len(strAuth) - InStr(1, strAuth, ":"))
    ElseIf (InStr(1, strAuth, ":") <= 0) And (Len(strAuth) > 0) Then
        'only username was submitted
        ParseURL.Username = strAuth
        ParseURL.Password = strNOCONTENT
    Else
        'no authenticate information was submitted
        ParseURL.Username = strNOCONTENT
        ParseURL.Password = strNOCONTENT
    End If

    If (InStr(1, strServerNPort, ":") > 0) Then
        'Servername contains port
        ParseURL.ServerPort = Int(Right(strServerNPort, Len(strServerNPort) - InStr(1, strServerNPort, ":")))
        ParseURL.ServerName = Left(strServerNPort, InStr(1, strServerNPort, ":") - 1)
    Else
        ParseURL.ServerPort = intDEFAULTPORT
        ParseURL.ServerName = strServerNPort
    End If

    If (InStr(1, strTemp, "?") > 0) Then
        ParseURL.Query = Right(strTemp, Len(strTemp) - InStr(1, strTemp, "?"))
        strTemp = Left(strTemp, InStr(1, strTemp, "?") - 1)
    Else
        ParseURL.Query = strNOCONTENT
    End If

    For i = Len(strTemp) To 1 Step -1
        If (Mid(strTemp, i, 1) = "/") Then
            ParseURL.Filename = Right(strTemp, Len(strTemp) - i)
            ParseURL.Dir = Left(strTemp, i)
            If Not (Left(ParseURL.Dir, 1) = "/") Then
                ParseURL.Dir = "/" & ParseURL.Dir
            End If
            Exit For
        End If
    Next
       
    ParseURL.Filepath = "/" & strTemp
    If Not (Left(ParseURL.Filepath, 1) = "/") Then
        ParseURL.Filepath = "/" & ParseURL.Filepath
    End If

    End Function




    Code 56 : This function returns any of the various components of the URL that are present

    Code

    Private Sub Form_Load()
    Const strURL As String = "http://web:logon@intranet.q-tec.org:89/euro/rechner/euro.php3?startpage"
    msgtext = ParseURL(strURL).Protocol & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Username & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Password & vbCrLf
    msgtext = msgtext & ParseURL(strURL).ServerName & vbCrLf
    msgtext = msgtext & ParseURL(strURL).ServerPort & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Filepath & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Dir & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Filename & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Query & vbCrLf
    MsgBox msgtext, vbInformation
    End Sub



    Sunday, May 20, 2007 9:19 AM

  • Code 57 : Gives the right URL after Download Complete

    Private Sub WebBrowser1_DownloadComplete()
    Combo2.Text = WebBrowser1.LocationURL
    End Sub

    Sunday, May 20, 2007 9:22 AM

  • Code 58 : Verify a given port

    Public Function VerifyPort (PortStr As String) As Boolean
    'Put this in a module, or change "Public" to
    '"Private" and put it in a form.

    Trim(PortStr)

    'If there's nothing in the box assume the
    'user has cleared it and return no errors.
    If Len(PortStr) = 0 Then
        VerifyPort = False
        Exit Function
    End If

    'Check to see if the string can be converted
    'to an integer.
    If IsNumeric(PortStr) = False Then
        MsgBox "Error: Integer values only.", vbInformation, "Error!"
        VerifyPort = False
        Exit Function
    End If

    'IsNumeric doesn't search for commas, so check
    'if the user entered a comma.
    For i = 1 To Len(PortStr)
        If InStr(i, PortStr, ",") Then
            MsgBox "Error: Integer values only.", vbInformation, "Error!"
            VerifyPort = False
            Exit Function
        End If
    Next i

    'If the port is or starts with a zero, return
    'an error.
    If Val(PortStr) = 0 Then
        MsgBox "Error: Ports 1 - 65535 Only.", vbInformation, "Error!"
        VerifyPort = False
        Exit Function
    End If
    If Left(PortStr, 1) = "0" Then
        MsgBox "Error: Ports 1 - 65535 Only.", vbInformation, "Error!"
        VerifyPort = False
        Exit Function
    End If

    'Check if the port exceeds the maximum range.
    If Val(txtRemotePort.Text) > 65535 Then
        MsgBox "Error: Ports 1 - 65535 only.", vbInformation, "Error!"
        txtLocalPort.Text = "65535"
        VerifyPort = False
        Exit Function
    End If

    VerifyPort = True
    End Function

    Sunday, May 20, 2007 9:23 AM

  • Code 59 : Gets the URL string from the ie browser edit window

    Declarations

    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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function SendMessageLong& Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
    Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
    Const WM_USER = &H400
    Const EM_LIMITTEXT = WM_USER + 21
    Private Const WM_GETTEXT = &HD
    Private Const WM_GETTEXTLENGTH = &HE
    Private Const EM_GETLINECOUNT = &HBA
    Private Const EM_LINEINDEX = &HBB
    Private Const EM_LINELENGTH = &HC1




    Code 59 : Gets the URL string from the ie browser edit window

    Code

    Private Sub GetURLstring_Click() 

     On Error GoTo CallErrorA
        Dim iPos As Integer
        Dim sClassName As String
        Dim GetAddressText As String
        Dim lhwnd As Long
        Dim WindowHandle As Long
       
       lhwnd = 0
       sClassName = ("IEFrame")
       lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
       sClassName = ("WorkerA")
       lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
       sClassName = ("ReBarWindow32")
       lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
       sClassName = ("ComboBoxEx32")
       lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
       sClassName = ("ComboBox")
       lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
       sClassName = ("Edit")
       lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
           
            WindowHandle& = lhwnd
            Dim buffer As String, TextLength As Long
            TextLength& = SendMessage(WindowHandle&, WM_GETTEXTLENGTH, 0&, 0&)
            buffer$ = String(TextLength&, 0&)
            Call SendMessageByString(WindowHandle&, WM_GETTEXT, TextLength& + 1, buffer$)
            MsgBox buffer$

       Exit Sub
    CallErrorA:
        MsgBox Err.Description
        Err.Clear

    End Sub



    Sunday, May 20, 2007 9:26 AM

  • Code 60 : Find Your Ip

    Code for .bas file

    Option Explicit

    Public Const MAX_WSADescription = 256
    Public Const MAX_WSASYSStatus = 128
    Public Const ERROR_SUCCESS       As Long = 0
    Public Const WS_VERSION_REQD     As Long = &H101
    Public Const WS_VERSION_MAJOR    As Long = WS_VERSION_REQD \ &H100 And &HFF&
    Public Const WS_VERSION_MINOR    As Long = WS_VERSION_REQD And &HFF&
    Public Const MIN_SOCKETS_REQD    As Long = 1
    Public Const SOCKET_ERROR        As Long = -1

    Public Type HOSTENT
       hName      As Long
       hAliases   As Long
       hAddrType  As Integer
       hLen       As Integer
       hAddrList  As Long
    End Type

    Public Type WSADATA
       wVersion      As Integer
       wHighVersion  As Integer
       szDescription(0 To MAX_WSADescription)   As Byte
       szSystemStatus(0 To MAX_WSASYSStatus)    As Byte
       wMaxSockets   As Integer
       wMaxUDPDG     As Integer
       dwVendorInfo  As Long
    End Type


    Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long

    Public Declare Function WSAStartup Lib "WSOCK32.DLL" _
       (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
       
    Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long

    Public Declare Function gethostname Lib "WSOCK32.DLL" _
       (ByVal szHost As String, ByVal dwHostLen As Long) As Long
       
    Public Declare Function gethostbyname Lib "WSOCK32.DLL" _
       (ByVal szHost As String) As Long
       
    Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
       (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
    Public Function GetIPAddress() As String

       Dim sHostName    As String * 256
       Dim lpHost    As Long
       Dim HOST      As HOSTENT
       Dim dwIPAddr  As Long
       Dim tmpIPAddr() As Byte
       Dim i         As Integer
       Dim sIPAddr  As String
       
       If Not SocketsInitialize() Then
          GetIPAddress = ""
          Exit Function
       End If
       If gethostname(sHostName, 256) = SOCKET_ERROR Then
          GetIPAddress = ""
          MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & _
                  " has occurred. Unable to successfully get Host Name."
          SocketsCleanup
          Exit Function
       End If
       sHostName = Trim$(sHostName)
       lpHost = gethostbyname(sHostName)
        
       If lpHost = 0 Then
          GetIPAddress = ""
          MsgBox "Windows Sockets are not responding. " & _
                  "Unable to successfully get Host Name."
          SocketsCleanup
          Exit Function
       End If
       CopyMemory HOST, lpHost, Len(HOST)
       CopyMemory dwIPAddr, HOST.hAddrList, 4
       ReDim tmpIPAddr(1 To HOST.hLen)
       CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
       For i = 1 To HOST.hLen
          sIPAddr = sIPAddr & tmpIPAddr(i) & "."
       Next
       GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
       
       SocketsCleanup
        
    End Function

    Public Function HiByte(ByVal wParam As Integer)

        HiByte = wParam \ &H100 And &HFF&
     
    End Function
    Public Function LoByte(ByVal wParam As Integer)

        LoByte = wParam And &HFF&

    End Function
    Public Sub SocketsCleanup()

        If WSACleanup() <> ERROR_SUCCESS Then
            MsgBox "Socket error occurred in Cleanup."
        End If
        
    End Sub

    Public Function SocketsInitialize() As Boolean

       Dim WSAD As WSADATA
       Dim sLoByte As String
       Dim sHiByte As String
       
       If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
          MsgBox "The 32-bit Windows Socket is not responding."
          SocketsInitialize = False
          Exit Function
       End If
       
       
       If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
            MsgBox "This application requires a minimum of " & _
                    CStr(MIN_SOCKETS_REQD) & " supported sockets."
            
            SocketsInitialize = False
            Exit Function
       End If
       
       
       If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
         (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
          HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
          
          sHiByte = CStr(HiByte(WSAD.wVersion))
          sLoByte = CStr(LoByte(WSAD.wVersion))
          
          MsgBox "Sockets version " & sLoByte & "." & sHiByte & _
                 " is not supported by 32-bit Windows Sockets."
          
          SocketsInitialize = False
          Exit Function
          
       End If
        SocketsInitialize = True
    End Function




    Code 60 : Find Your Ip

    Code

    Private Sub Form_Load()
       Text1.Text = GetIPAddress()
       If Text1.Text = "127.0.0.1" Then
    Label1.Caption = "You are of Line"
       Else
    Label1.Caption = "You are on Line"
       End If
    End Sub



    Sunday, May 20, 2007 9:29 AM

  • Code 61 : An alternate FTP method
    Sub PoorMansFTP

    Dim strTempDir As String
    Dim strTempFtpFile As String
    Dim strFileName As String
    Dim strSiteAddress As String
    Dim strUserName As String
    Dim strPassword As String
    Dim strRemoteDirectory As String

    strSiteAddress = "www.yourdomain.com"
    strUserName = "Username goes here"
    strPassword = "Password goes here or assigned in some other way"
    strRemoteDirectory = "upload directory, ie. wwwroot/path/path"

    strTempDir = Environ("Temp")
    If Len(strTempDir) = 0 Then strTempDir = "C:"
    strTempFtpFile = strTempDir & "\fdty.l34"
    strFileName = "C:\SomePath\SomeFileToUpload.xxx"



    '''Write FTP commands into a file
    Open strTempFtpFile For Output As #1

        Print #1, "open " & strSiteAddress
        Print #1, "user " & strUserName
        Print #1, strPassword   '''some servers may require "PW " & strPassword
                                '''but most automatically ask for it
        Print #1, "type binary"
        Print #1, "cd " & strRemoteDirectory
        Print #1, "put " & strHtmlFileName
        Print #1, "Quit"

    Close #1

    ''' call ftp.exe with -n parameter, which will supress the automatic feedback
    ''' from the server, and -s which contains the path to the file to use for
    ''' ftp commands.
    Call Shell("ftp -n -s:" & strTempFtpFile, vbHide)

    End Sub

    Sunday, May 20, 2007 9:32 AM

  • Code 62 : small code gets you IP address and Host name
    'Make 2 TextBoxes
    'Put this in Form load >>>>


    Text1.Text = Winsock1.LocalIP
    Text2.Text = Winsock1.LocalHostName


    Sunday, May 20, 2007 9:37 AM

  • Code 63 : WebBrowser > Opens New Window using your program
    'Microsoft IE/Shdocvw.dll needed
    Private Sub webbrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean)
        Dim F As New observe
        F.Show
        Set ppDisp = F.webbrowser1.object
    End Sub
    Sunday, May 20, 2007 9:39 AM

  • Code 64 : guaranteed way to view the source code of a webpage
    text1.text = webbrowser1.document.documentelement.innerhtml
    Sunday, May 20, 2007 9:42 AM

  • Code 65 : Adding Hyperlink Using the Label Control

    'add textbox(text1) and label(label1)
    'then add the following:

    Option Explicit


    Private Const clrLinkActive = vbBlue
    Private Const clrLinkHot = vbRed
    Private Const clrLinkInactive = vbBlack

    Private Const SW_SHOWNORMAL As Long = 1
    Private Const SW_SHOWMAXIMIZED As Long = 3
    Private Const SW_SHOWDEFAULT As Long = 10

    Private Type POINTAPI
       X As Long
       Y As Long
    End Type

    Private Declare Function GetCursorPos Lib "user32" _
      (lpPoint As POINTAPI) As Long

    Private Declare Function ScreenToClient Lib "user32" _
      (ByVal hwnd As Long, _
       lpPoint As POINTAPI) As Long

    Private Declare Function GetDesktopWindow Lib "user32" () As Long

    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 Sub Form_Load()

    Text1.Text = "http://www.google.com/"
    Label1.AutoSize = True
         
    End Sub


    Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    With Label1
    .ForeColor = clrLinkInactive
    .FontUnderline = False
    End With
    End Sub

    Private Sub label1_Click()

       Dim sURL As String

      'open the URL using the default browser
       sURL = Label1.Caption

       Call RunShellExecute("open", sURL, 0&, 0&, SW_SHOWNORMAL)
      
    End Sub


    Private Sub RunShellExecute(sTopic As String, sFile As Variant, _
                               sParams As Variant, sDirectory As Variant, _
                               nShowCmd As Long)

      'execute the passed operation, passing
      'the desktop as the window to receive
      'any error messages
       Call ShellExecute(GetDesktopWindow(), _
                         sTopic, _
                         sFile, _
                         sParams, _
                         sDirectory, _
                         nShowCmd)

    End Sub


    Private Sub Text1_Change()

      'reflect changes to the textbox
       Label1.Caption = Text1.Text

    End Sub


    Private Sub Text1_GotFocus()

       Dim pos As String
      
      'if the textbox has the URL double
      'slashes, select only the text after
      'them for editing convenience
       pos = InStr(Text1.Text, "//")
      
       If pos Then
      
          With Text1
             .SelStart = pos + 1
             .SelLength = Len(.Text)
          End With
         
       End If


    End Sub


    Private Sub label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
       
       With Label1
      
             .ForeColor = clrLinkActive
             .FontUnderline = True
      
       End With
      
    End Sub

    Sunday, May 20, 2007 9:45 AM

  • Code 66 : Setup a DSN-Less database in Active Server Pages

    'DBName.mdb is the name of your database

    <% conn.Open "driver={Microsoft Access Driver (*.mdb)}; dbq=c:\database\DBName.mdb;uid=Admin" %>

    Sunday, May 20, 2007 9:47 AM

  • Code 67 : Retrieve Server Variables
    <%
    For Each Item In Request.ServerVariables
    Response.Write Item & " - " & Request.ServerVariables(Item) & "<BR>"
    Next
    %>
    Sunday, May 20, 2007 9:51 AM

  • Code 68 : Loop through Submitted items that were POSTed from a form
    <%
    For Each Item in Request.Form
    Response.Write Item & " - " & Request(Item) & "<BR>"
    Next
    %>
    Sunday, May 20, 2007 9:54 AM

  • Code 69 : Populate a combo box with information from a database Code Snippet
    <BR>This is an HTML ListBox<BR>   
    <SELECT NAME="ListBox" SIZE=1>
    <% Set conn = Server.CreateObject("ADODB.Connection") %>
    <% conn.Open "DSN=AdvWorks"  ' connect to the database %>
    <% Set rs = conn.Execute("SELECT City FROM Customers") %>
    <% Do While Not rs.EOF  ' define the ListBox OPTIONs %>
    <OPTION VALUE="<%= rs("City") %>"> <%= rs("City") %>
    <% rs.MoveNext %>   
    <% Loop %>   
    <% rs.Close %>   
    <% conn.Close %>
    Sunday, May 20, 2007 9:56 AM

  • Code 70 : Lists all file within the current directoryCode Snippet
    <html>
    <head><title></title></head>
    <body>
    <%
      Dim fso, f, f1, fc, s
      Set fso = CreateObject("Scripting.FileSystemObject")
        TheFile = Server.MapPath(Request.ServerVariables("SCRIPT_NAME"))
        loc = InStrRev(TheFile,"\")
        TheFile = Left(TheFile,loc)
      Set f = fso.GetFolder(TheFile)
      Set fc = f.Files
      For Each f1 in fc
        'change the file extensions to view different files.
        if right(f1,5) = ".html" or right(f1,4) = ".htm" then
                s = s & "<A HREF='" & f1.name & "'>" & f1.name & "</A>"
            s = s &  "<BR>"
        End If
      Next
      ShowFileList = s

    %>
    <%
    response.write ShowFileList
    %>
    </body>
    </html>
    Sunday, May 20, 2007 9:58 AM

  • Code 71 : Using the Ad Rotator component from MicrsoftCode Snippet
    <%
    Set AdRotator = Server.CreateObject("MSWC.AdRotator")
    AdText = AdRotator.GetAdvertisement("/banners/ads.txt")
    BeginLoc = InStr(AdText, "<A")
    TELoc = InStr(BeginLoc + 3, AdText, " ")
    AdText = Left(AdText,TELoc) & "TARGET=NewWin " & Right(AdText,(Len(AdText)-TELoc))
    response.write AdText
    %>
    Sunday, May 20, 2007 9:59 AM

  • Code 72 : How to call a stored procedure from active server pagesCode Snippet
    <%@ language="VBScript"%>
    <% option explicit%>
    <!-- #include virtual="adovbs.inc"-->
    'Open the Connection
    set conn = Server.CreateObject("ADODB.Connection")
    conn.open "dsn=dsn;uid=username;pwd=password"
    'Now call the stored Procedure
    Set cmd=Server.CreateObject("ADODB.Command")
    set cmd.activeconnection=conn
    cmd.commandtext="Procedure_name"
       cmd.commandtype=adcmdStoredProc
       cmd.parameters.refresh
       cmd.parameters(1).value = Value1
       cmd.parameters(2).value = Value2
       .
       .
       cmd.parameters(n).value = Valuen
    'for the ouput from stored procdure
      cmd.execute
      returnvalue = cmd.parameters(0).value      
    ' and for resultset
      set rs = cmd.execute.
      conn.close

        


    Sunday, May 20, 2007 10:02 AM

  • Code 73 : Detecting Browser TypeCode Snippet
    <%
       Set MyBrowser=server.createobject("MSWC.Browsertype")
       response.write MyBrowser.Browser
    %>
    Sunday, May 20, 2007 10:04 AM

  • Code 74 : Populates a table with records returned from a databaseCode Snippet
    strConnectionString = "SystemDSN"    'I used a system DSN
    Set connection = Server.CreateObject("ADODB.Connection")
    connection.Open strConnectionString
    <html>

    <table border="1" cellpadding="4" cellspacing="3" width="598" bordercolorlight="#000080">


    <%Set RS = Server.CreateObject("ADODB.Recordset")

    strSQL = "SELECT * FROM tblYourTable WHERE field = whatever "
    RS.Open strSQL, connection
        %>
        <%While NOT RS.EOF%>
            <td width="129" align="center"><font face="Arial"><font size="2"><%=RS("field1")%></font></font></td>
            <td width="65" align="center"><font face="Arial"><font size="2"><%=RS("field2")%></font></font></td>
            <td width="79" align="center"><font face="Arial"><font size="2"><%=RS("field3")%></font></font></td>
            <td width="86" align="center"><font face="Arial"><font size="2"><%=RS("field4")%></font></font></td>
            <td width="72" align="center"><font face="Arial"><font size="2"><%=RS("field5")%></font></font></td>
            <td width="77" align="center"><font face="Arial"><font size="2"><%=RS("field6")%></font></font></td>
        </tr>
        <%RS.MoveNext
        Wend
        RS.Close
        %>
        
    </table>
    </html>

    Sunday, May 20, 2007 10:06 AM

  • Code 75 : When an error occurs on one of your ASP pages, this sub will email you a notification of that error and show the user friendly error page.
    <%@ TRANSACTION=Required %> ' You must have this line!


    <%
    '*******************************************************************************
    'This section traps errors and emails you a report of it and displays a user friendly error page.
    '*******************************************************************************

    sub OnTransactionAbort()
         response.clear
         response.write "An error was encountered processing your information."&"<br>"
         response.write "Please click the HOME button in your browser and try again."&"<br>"
         response.write "A notice of this error has been sent to the web administrators."&"<br>"
         response.write "Thank you for your patience."
         
         SET objMail=Server.CreateObject("CDONTS.Newmail")
         objMail.From    = "error@yourplace.com"
        objMail.To        = "webmaster@yourplace.com" 'your email address    
         objMail.Subject = "!!Error At Web Site!!"
         objMail.Body    = "On " & now() &_
            ", the following error was " &_
            "generated in page " &_
            Request.ServerVariables( "SCRIPT_NAME" ) &_
            ": " & vbnewline & vbnewline &_
            err.Description
         objMail.Importance = 2
         objMail.Send
         Set objMail = Nothing
    end sub %>

    Sunday, May 20, 2007 10:08 AM

  • Code 76 : Use Page Counter component to count how many times the current page was hit
    <%@ Language=VBScript %>
    <HTML>
    <HEAD>
    <TITLE>ASP 2.0 Demo - The Page Counter Component</TITLE>
    </HEAD>
    <BODY>
    <H2>ASP 2.0 Demo -The Page Counter Component</H2>
    <HR>
    This sample show how to use <B>Page Counter</B> component to count how many times the current page was hit. This component is implemented in file <B>PAGECNT.DLL</B>. Make sure you have it on your server and installed properly. You can use the Personal Web Server to test this ASP page.
    <P>
    <font color=blue>How to: Click the Refresh or Reload menu button to see the result ! </font>
    <HR>
    <P>
     <%
      Dim objPC
      Dim lngHitCount
      On Error Resume Next
      Set objPC=Server.CreateObject("IISSample.PageCounter")
      If IsObject(objPC)=False Then
        Response.Write "The Page Counter component object can not be created at this time. "
        Response.Write "Either you do not have this component on the server machine or it "
        Response.Write "is not installed properly."
        Response.Write "You may try to fix this problem by installing IIS Resource Kit."
      Else
        Response.Write "The Page Counter component object is created successfully !<P>"
        lngHitCount=objPC.PageHit()
        Response.Write("Number of times (reset one) this page was hit - ")   
        Response.Write cstr(lngHitCount)
        Response.Write("<BR>")
        If ((lngHitCount Mod 10)=0) Then
           Response.Write("<font color=red><P>You hit the lucky number.</font><BR>")
           If (lngHitCount>=100) Then    ' Reset count.
         objPC.Reset
             Response.Write("The page counter was reset every time it reaches 100 !")
           End If
        End If
      End If
      %>
    <P>
    </BODY>
    </HTML>

    Sunday, May 20, 2007 10:10 AM

  • Code 77 : MyInfo Component Sample
    <%@ Language=VBScript %>
    <HTML>
    <HEAD>
    <TITLE>ASP 2.0 Demo - The MyInfo Component </TITLE>
    </HEAD>
    <BODY>
    <H2>ASP 2.0 Demo - The MyInfo Component </H2>
    <HR>
    The <B>MyInfo Component</B> can be used to keep track of personal information, provided by the server administrator.
    <P>
    This component is implemented in <B>MYINFO.DLL.</B>
    <P>At the begining, you may have nothing in the MyInfo for some properties, but you can add your own and modify them.
    <P>
    <B><font color=blue>How to: You can click the Reload or Refresh menu button to see the result.</font></B>
    <HR>
    <P>
     <%
      Dim objMyInfo
      On Error Resume Next
      Set objMyInfo=Server.CreateObject("MSWC.MyInfo")
      If IsObject(objMyInfo)=False Then
        Response.Write "The MyInfo object can not be created on this machine. Either you do not "
        Response.Write "have this component on the server machine or it is not installed properly."
        Response.Write "You may try to fix this problem by installing IIS Resource Kit."
      Else
        Response.Write "The MyInfo object is created successfully !<P>"
        Response.Write "Before I change my info, I have following:<BR>"    
        Response.Write("<BR>My favorite color is - " + objMyInfo.FavoriteColor)
        Response.Write("<BR>My startdate is - " + objMyInfo.StartDate)
        Response.Write("<BR>My email address is - " + objMyInfo.Email)
        Response.Write("<BR>Last time MyInfo was reset is - " + objMyInfo.MyInfoReset)
        '
        ' Reset my info.
        If objMyInfo.FavoriteColor="blue" Then
          objMyInfo.FavoriteColor="purple"
        Else
          objMyInfo.FavoriteColor="blue"
        End if
        '
        If objMyInfo.StartDate="1/1/1999" Then
          objMyInfo.StartDate="1/1/2000"
        Else
          objMyInfo.StartDate="1/1/1999"
        End If
        '
        If objMyInfo.Email="sanket.1985@gmail.com" Then
          objMyInfo.Email="sanket.shah@rediffmail.com"
        Else
          objMyInfo.Email="sanket.shah@hotmail.com"
        End if
        '
        objMyInfo.MyInfoReset=Now
        '
        ' Display new values.
        Response.Write "<P>After I change my info, I have following:<BR>"    
        Response.Write("<BR>My new favorite color is - " + objMyInfo.FavoriteColor)
        Response.Write("<BR>My new startdate is - " + objMyInfo.StartDate)
        Response.Write("<BR>My new email address is - " + objMyInfo.Email)
      End if  
     %>
    <P>
    </BODY>
    </HTML>

    Sunday, May 20, 2007 10:13 AM

  • Code 78 : ASP sample of Registry Access component

    <%@ Language=VBScript %>
    <HTML>
    <HEAD>
    </HEAD>
    <TITLE>ASP 2.0 Demo - Registry Access Component</TITLE>
    <BODY>
    <H2>ASP 2.0 Demo - Registry Access Component</H2>
    <HR>
    The <B>Registry Access</B> component provides access to the registry on a local or remote computer.
    <P>
    <HR>
    <P>
     <%
      Dim objRegAccess
      Dim strIEVersion
      On Error Resume Next
      Set objRegAccess=Server.CreateObject("IISSample.RegistryAccess")
      If IsObject(objRegAccess)=False Then
        Response.Write "The Registry Access component object can not be created at this time. "
        Response.Write "Either you do not have this component on the server machine or it "
        Response.Write "is not installed properly."
        Response.Write "You may try to fix this problem by installing IIS Resource Kit."
      Else
        Response.Write "The Registry Access component object is created successfully !<P>"
        strIEVersion=objRegAccess.Get("HKLM\Software\Microsoft\Internet Explorer\Version Vector\IE")
        Response.Write("Internet Explorer version - " + strIEVersion)
        Response.Write("<P>")
        If Trim(strIEVersion) <> "" Then
          Response.Write("You got something useful !")
        End if
      End if
     %>
    </BODY>
    </HTML>

    Sunday, May 20, 2007 10:16 AM
  • Man Sanket you areawesome Smile

    really good codes Smile

    Do you know how to automize some activities in the websites ?

    Like automated logging into mail.yahoo.com and then entering the user and pass, and then also checking that INBOX(X) text, and checking whats the value of X. etc etc ?

    I want to automize some few things. If you have any idea about it, do let me know.
    Sunday, May 20, 2007 10:49 AM
  • Hey Harshil, I'm already on way to automate that procedure. Wait for some time and I'll let you know.
    Sunday, May 20, 2007 7:12 PM
  • Thanks a lot my friend. , you are so kind.Smile

    Btw how was your quiz ? hope it went good.
    Monday, May 21, 2007 3:56 AM
  • Hey Harshil,

    My quiz really went good. How was yours ?
    Thursday, May 24, 2007 2:47 PM

  • Code 79 : Shell out to a 32-bit application and wait until task completes

    Declarations

    '*** Monitoring a DOS Shell
    Private Declare Function OpenProcess Lib "Kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
    Private Declare Function GetExitCodeProcess Lib "Kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
    Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
    Const STILL_ACTIVE = &H103
    Const PROCESS_QUERY_INFORMATION = &H400




    Code 79 : Shell out to a 32-bit application and wait until task completes


    Sub Shell32Bit(ByVal JobToDo As String)

             Dim hProcess As Long
             Dim RetVal As Long
             'The next line launches JobToDo as icon,

             'captures process ID
             hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(JobToDo, 1))

             Do

                 'Get the status of the process
                 GetExitCodeProcess hProcess, RetVal

                 'Sleep command recommended as well as DoEvents
                 DoEvents: Sleep 100

             'Loop while the process is active
             Loop While RetVal = STILL_ACTIVE


    End Sub



    Thursday, May 24, 2007 2:48 PM
  • Code 80 : Close all windows and logon as a different user
    Declarations

    Private Const EWX_LogOff As Long = 0
    Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long




    Code 80 : Close all windows and logon as a different user
    Code

    'close all programs and log on as a different user
    lngResult = ExitWindowsEx(EWX_LogOff, 0&)




    Thursday, May 24, 2007 2:51 PM

  • Code 81 : Shut down the computer

    Declarations

    Private Const EWX_SHUTDOWN As Long = 1
    Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long




    Code 81 : Shut down the computer

    Code

    'shut down the computer
    lngResult = ExitWindowsEx(EWX_SHUTDOWN, 0&)



    Thursday, May 24, 2007 3:01 PM

  • Code 82 : Reboot the computer

    Declarations

    Private Const EWX_REBOOT As Long = 2
    Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long




    Code 82 : Reboot the computer

    'reboot the computer
    lngResult = ExitWindowsEx(EWX_REBOOT, 0&)



    Thursday, May 24, 2007 3:03 PM

  • Code 83 : Find free disk space on a computer

    Declarations

    Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long

    Public Type DiskInformation
        lpSectorsPerCluster As Long
        lpBytesPerSector As Long
        lpNumberOfFreeClusters As Long
        lpTotalNumberOfClusters As Long
    End Type




    Code 83 : Find free disk space on a computer

    Code

    Dim info As DiskInformation
    Dim lAnswer As Long
    Dim lpRootPathName As String
    Dim lpSectorsPerCluster As Long
    Dim lpBytesPerSector As Long
    Dim lpNumberOfFreeClusters As Long
    Dim lpTotalNumberOfClusters As Long
    Dim lBytesPerCluster As Long
    Dim lNumFreeBytes As Double
    Dim sString As String

    lpRootPathName = "c:\"
    lAnswer = GetDiskFreeSpace(lpRootPathName, lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters)
    lBytesPerCluster = lpSectorsPerCluster * lpBytesPerSector
    lNumFreeBytes = lBytesPerCluster * lpNumberOfFreeClusters
    sString = "Number of Free Bytes : " & lNumFreeBytes & vbCr & vbLf
    sString = sString & "Number of Free Kilobytes: " & (lNumFreeBytes / 1024) & "K" & vbCr & vbLf
    sString = sString & "Number of Free Megabytes: " & Format(((lNumFreeBytes / 1024) / 1024), "0.00") & "MB"

    MsgBox sString



    Thursday, May 24, 2007 3:05 PM

  • Code 84 : Determine when your visual basic application gains or loses focus

    Declarations

    Option Explicit

    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

    Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
      (ByVal hwnd As Long, ByVal nIndex As Long, _
      ByVal dwNewLong As Long) As Long

    Public Const WM_ACTIVATEAPP = &H1C
    Public Const GWL_WNDPROC = -4

    Global lpPrevWndProc As Long
    Global gHW As Long




    Code 84 : Determine when your visual basic application gains or loses focus

    Code

    'Paste the following code into the code window for Form1:

    Sub Form_Load()
       'Store handle to this form's window
       gHW = Me.hWnd

       'Call procedure to begin capturing messages for this window
       Hook
    End Sub

    Private Sub Form_Unload(Cancel As Integer)
       'Call procedure to stop intercepting the messages for this window
       Unhook
    End Sub

    '******************************************************************
    'Paste the following code into the main module:
    Public Sub Hook()
       'Establish a hook to capture messages to this window
       lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, _
         AddressOf WindowProc)
    End Sub

    Public Sub Unhook()
       Dim temp As Long

       'Reset the message handler for this window
       temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
    End Sub



    Thursday, May 24, 2007 3:06 PM

  • Code 84 : Determine the number of lines in a multi-line text box

    Declarations

    Public 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

    Public Const EM_GETLINECOUNT = &HBA




    Code 84 : Determine the number of lines in a multi-line text box

    Code

        Dim lngLineCount As Long
        On Error Resume Next
     
       'get/show the number of lines in the edit control
        lngLineCount = SendMessageLong(Text1.hwnd, EM_GETLINE, 0&, 0&)
        Label1 = Format$(lngLineCount, "##,###")



    Thursday, May 24, 2007 3:09 PM
  • Code 86 : generate GUIDs (Globally Unique Identifiers)

    Declarations
    Public Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(7) As Byte
    End Type

    Public Declare Function CoCreateGuid Lib "OLE32.DLL" (pGuid As GUID) As Long
    Public Const S_OK = 0 ' return value from CoCreateGuid


    Code 86 : generate GUIDs (Globally Unique Identifiers)

    Code
    Function GetGUID() As String
        
        Dim lResult As Long
        Dim lguid As GUID
        Dim MyguidString As String
        Dim MyGuidString1 As String
        Dim MyGuidString2 As String
        Dim MyGuidString3 As String
        Dim DataLen As Integer
        Dim StringLen As Integer
        Dim i%
        
        On Error GoTo error_olemsg
        
        lResult = CoCreateGuid(lguid)
        
        If lResult = S_OK Then
            MyGuidString1 = Hex$(lguid.Data1)
            StringLen = Len(MyGuidString1)
            DataLen = Len(lguid.Data1)
            MyGuidString1 = LeadingZeros(2 * DataLen, StringLen) & MyGuidString1        'First 4 bytes (8 hex digits)
            
            MyGuidString2 = Hex$(lguid.Data2)
            StringLen = Len(MyGuidString2)
            DataLen = Len(lguid.Data2)
            MyGuidString2 = LeadingZeros(2 * DataLen, StringLen) & Trim$(MyGuidString2)        'Next 2 bytes (4 hex digits)
            
            MyGuidString3 = Hex$(lguid.Data3)
            StringLen = Len(MyGuidString3)
            DataLen = Len(lguid.Data3)
            MyGuidString3 = LeadingZeros(2 * DataLen, StringLen) & Trim$(MyGuidString3)        'Next 2 bytes (4 hex digits)
            
            GetGUID = MyGuidString1 & MyGuidString2 & MyGuidString3
            
            For i% = 0 To 7
               MyguidString = MyguidString & Format$(Hex$(lguid.Data4(i%)), "00")
            Next i%
            
            'MyGuidString contains last 8 bytes of Guid (16 hex digits)
            GetGUID = GetGUID & MyguidString
        Else
            GetGUID = "00000000" ' return zeros if function unsuccessful
        End If
        
        Exit Function

    error_olemsg:
             MsgBox "Error " & Str(Err) & ": " & Error$(Err)
             GetGUID = "00000000"
             Exit Function

    End Function

    Function LeadingZeros(ExpectedLen As Integer, ActualLen As Integer) As String
        LeadingZeros = String$(ExpectedLen - ActualLen, "0")
    End Function


    Thursday, May 24, 2007 3:11 PM

  • Code 87 : Sets the volume label for a drive

    Declarations

    Declare Function SetVolumeLabel Lib "kernel32" Alias "SetVolumeLabelA" (ByVal lpRootPathName As String, ByVal lpVolumeName As String) As Long

    Public Function SetLabel(RootName As String, NewLabel As String)

    If RootName ="" Then

    Exit Function

    End If

    Call SetVolumeLabel(RootName,NewLabel)

    End Function




    Code 87 : Sets the volume label for a drive

    Code

    Private Sub Command1_Click()
    Call SetLabel("c:\windows","Sanket")
    End Sub



    Thursday, May 24, 2007 3:14 PM

  • Code 88 : Enum the supported display resolutions, change resolution and detect the display change message from Windows

    Declarations

    Public Const GWL_WNDPROC = (-4)
    Public Const WM_DISPLAYCHANGE = &H7E

    Public Const DISP_CHANGE_SUCCESSFUL = 0
    Public Const DISP_CHANGE_RESTART = 1
    Public Const DISP_CHANGE_FAILED = -1
    Public Const DISP_CHANGE_BADMODE = -2
    Public Const DISP_CHANGE_NOTUPDATED = -3
    Public Const DISP_CHANGE_BADFLAGS = -4
    Public Const DISP_CHANGE_BADPARAM = -5
    Public Const CDS_UPDATEREGISTRY = 1
    Public Const DM_BITSPERPEL = &H40000
    Public Const DM_PELSHEIGHT = &H100000
    Public Const DM_PELSWIDTH = &H80000


    Public Type DevMode
        dmDeviceName As String * 32
        dmSpecVersion As Integer
        dmDriverVersion As Integer
        dmSize As Integer
        dmDriverExtra As Integer
        dmFields As Long
        dmOrientation As Integer
        dmPaperSize As Integer
        dmPaperLength As Integer
        dmPaperWidth As Integer
        dmScale As Integer
        dmCopies As Integer
        dmDefaultSource As Integer
        dmPrintQuality As Integer
        dmColor As Integer
        dmDuplex As Integer
        dmYResolution As Integer
        dmTTOption As Integer
        dmCollate As Integer
        dmFormName As String * 32
        dmLogPixels As Integer
        dmBitsPerPel As Long
        dmPelsWidth As Long
        dmPelsHeight As Long
        dmDisplayFlags As Long
        dmDisplayFrequency As Long
        dmICMMethod As Long         ' Windows 95 only
        dmICMIntent As Long         ' Windows 95 only
        dmMediaType As Long         ' Windows 95 only
        dmDitherType As Long        ' Windows 95 only
        dmICCManufacturer As Long   ' Windows 95 only
        dmICCModel As Long          ' Windows 95 only
        dmPanningWidth As Long  ' Windows 95 only
        dmPanningHeight As Long ' Windows 95 only
    End Type

    Public 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 Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As DevMode, ByVal dwFlags As Long) As Long

    Public Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As DevMode) As Long




    Code 88 : Enum the supported display resolutions, change resolution and detect the display change message from Windows

    Code

    '----------------------------------------------------------
    'Procedure for Enum the supported resolutions
    '----------------------------------------------------------
    Private Sub EnumRes()
       
        Dim utDevMode As DevMode, fEnd As Boolean
        Dim sDeviceName As String, iMode As Long
        Dim oItem As New ListItem
       
        utDevMode.dmSize = Len(utDevMode)
        iMode = 0
       
        Do

            fEnd = EnumDisplaySettings(sDeviceName, iMode, utDevMode)

            'Do sth with the utDevMode structure
            'The fields dmPelsWidth, dmPelsHeight, dmBitsPerPel are most useful

            iMode = iMode + 1

        Loop Until Not fEnd
       
    End Sub


    '----------------------------------------------------------
    'Code for changing display resolution
    '----------------------------------------------------------
    Private Sub ChangeIt(lPelsWidth As Long, lPelsHeight As Long, lBitsPerPel As Long)

        Dim utDevMode   As DevMode
        Dim iRes        As Long
        Dim sMsg        As String
        Dim oItem       As ListItem
       
        If lvSettings.SelectedItem Is Nothing Then Exit Sub
       
        With utDevMode
            .dmSize = Len(utDevMode)
            .dmPelsWidth = lPelsWidth
            .dmPelsHeight = lPelsHeight
            .dmBitsPerPel = lBitsPerPel
            .dmFields = DM_BITSPERPEL Or DM_PELSHEIGHT Or DM_PELSWIDTH
        End With
       
        iRes = ChangeDisplaySettings(utDevMode, CDS_UPDATEREGISTRY)

        Select Case iRes
            Case Is = DISP_CHANGE_SUCCESSFUL
                sMsg = "Display setting has been changed successfully."
            Case Is = DISP_CHANGE_RESTART
                sMsg = "You have to restart your computer in order to carry out the new setting."
            Case Is = DISP_CHANGE_FAILED
                sMsg = "Sorry, failed to change the display setting."
        End Select
       
        If sMsg <> vbNullString Then MsgBox sMsg, , "Display"
       
    End Sub


    '----------------------------------------------------------
    'To detect the change notification of display resolution
    'from Windows, put the code below into a module, except
    'Hook & Unhook in a form.
    'To begin to capture the notification, call Hook
    'To end capturing the notification, call Unhook
    '----------------------------------------------------------

    Public lPreWndProc As Long

    Public Type TLoHiLong
        lo As Integer
        hi As Integer
    End Type

    Public Type TAllLong
        all As Long
    End Type


    '----------------------------------------------------------
    'Procedure for Subclassing
    '----------------------------------------------------------
    Public Function MyWndProc _
        (ByVal hwnd As Long, _
        ByVal lMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long
       
        If lMsg = WM_DISPLAYCHANGE Then
            Debug.Print "DisplayChange"
            Debug.Print "BitsPerPel: ", wParam
            Debug.Print "lParam: ", lParam
            Debug.Print "loword of lParam: ", LoWord(lParam)
            Debug.Print "HiWord of lParam: ", HiWord(lParam)
        End If
       
        MyWndProc = CallWindowProc(lPreWndProc, hwnd, lMsg, wParam, lParam)

    End Function

    Public Function LoWord(dw As Long) As Integer
        Dim lohi As TLoHiLong
        Dim all As TAllLong
        all.all = dw
        LSet lohi = all
        LoWord = lohi.lo
    End Function

    Public Function HiWord(dw As Long) As Integer
        Dim lohi As TLoHiLong
        Dim all As TAllLong
        all.all = dw
        LSet lohi = all
        HiWord = lohi.hi
    End Function

    '----------------------------------------------------------
    'Code for Subclassing
    '----------------------------------------------------------
    Private Sub Hook()
        lPreWndProc = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf MyWndProc)
    End Sub

    Private Sub Unhook()
        Call SetWindowLong(Me.hwnd, GWL_WNDPROC, lPreWndProc)
    End Sub


    '----------------------------------------------------------
    'Note:
    '   The HiWord & LoWord functions are from
    '   the book Hardcore Visual Basic by
    '   B.Mckinney, Microsoft PRESS
    '----------------------------------------------------------



    Thursday, May 24, 2007 3:16 PM

  • Code 89 : Calls the "Open File Dialog" without need for an OCX

    Declarations

    Private Type OPENFILENAME
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
    End Type

    Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long




    Code 89 : Calls the "Open File Dialog" without need for an OCX

    Code

    'Place the following code in under a command button or in a menu, etc...

        Dim ofn As OPENFILENAME
        ofn.lStructSize = Len(ofn)
        ofn.hwndOwner = Form1.hWnd
        ofn.hInstance = App.hInstance
        ofn.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + "*.txt" + Chr$(0) + "Rich Text Files (*.rtf)" + Chr$(0) + "*.rtf" + Chr$(0)
            ofn.lpstrFile = Space$(254)
            ofn.nMaxFile = 255
            ofn.lpstrFileTitle = Space$(254)
            ofn.nMaxFileTitle = 255
            ofn.lpstrInitialDir = curdir
            ofn.lpstrTitle = "Our File Open Title"
            ofn.flags = 0
            Dim a
            a = GetOpenFileName(ofn)

            If (a) Then
                    MsgBox "File to Open: " + Trim$(ofn.lpstrFile)
            Else
                    MsgBox "Cancel was pressed"
            End If



    Thursday, May 24, 2007 3:19 PM

  • Code 90 : Create GetMouseFocus / LostMouseFocus in yours controls

    Declarations
    Public Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
    Public Declare Function ReleaseCapture Lib "user32" () As Long




    Code 90 : Create GetMouseFocus / LostMouseFocus in yours controls

    Code
    'Put this code in MouseMove event. In this example, I put a CommandButton on a
    'form with the name Command1

    Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Static CtrMov As Boolean
    With Command1 'Change this 'Command1' to your control name
        If (X < 0) Or (Y < 0) Or (X > .Width) Or (Y > .Height) Then
            ReleaseCapture
            CtrMov = False
            
            'Put here your code to LostMouseFocus
            'For example:
            Me.Print "LostMouseFocus"
            
        Else
            SetCapture .hwnd
            If CtrMov = False Then
                CtrMov = True
                            
                'Put here your code to GetMouseFocus
                'For example:
                Me.Print "GetMouseFocus"
            
            End If
        End If
    End With
    End Sub



    Thursday, May 24, 2007 3:23 PM

  • Code 91 : make a transparent area of different shape

    Declarations
    Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
    Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) 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 CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
    Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long




    Code 91 : make a transparent area of different shape

    Code
    Private Function fMakeATranspArea(AreaType As String, pCordinate() As Long) As Boolean


    Const RGN_DIFF = 4

    Dim lOriginalForm As Long
    Dim ltheHole As Long
    Dim lNewForm As Long
    Dim lFwidth As Single
    Dim lFHeight As Single
    Dim lborder_width As Single
    Dim ltitle_height As Single


     On Error GoTo Trap
        lFwidth = ScaleX(Width, vbTwips, vbPixels)
        lFHeight = ScaleY(Height, vbTwips, vbPixels)
        lOriginalForm = CreateRectRgn(0, 0, lFwidth, lFHeight)
        
        lborder_width = (lFHeight - ScaleWidth) / 2
        ltitle_height = lFHeight - lborder_width - ScaleHeight

    Select Case AreaType
     
        Case "Elliptic"
     
                ltheHole = CreateEllipticRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))

        Case "RectAngle"
       
                ltheHole = CreateRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))

          
        Case "RoundRect"
                 
                   ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(5), pCordinate(6))

        Case "Circle"
                   ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(3), pCordinate(4))
        
        Case Else
               MsgBox "Unknown Shape!!"
               Exit Function

           End Select

        lNewForm = CreateRectRgn(0, 0, 0, 0)
        CombineRgn lNewForm, lOriginalForm, _
            ltheHole, RGN_DIFF
        
        SetWindowRgn hWnd, lNewForm, True
        Me.Refresh
        fMakeATranspArea = True
    Exit Function

    Trap:
         MsgBox "error Occurred. Error # " & Err.Number & ", " & Err.Description


    End Function

    ' 3'To Call
    Dim lParam(1 To 6) As Long

    lParam(1) = 100
    lParam(2) = 100
    lParam(3) = 250
    lParam(4) = 250
    lParam(5) = 50
    lParam(6) = 50

    'Call fMakeATranspArea("RoundRect", lParam())
    'Call fMakeATranspArea("RectAngle", lParam())
    Call fMakeATranspArea("Circle", lParam())
    'Call fMakeATranspArea("Elliptic", lParam())


    Thursday, May 24, 2007 3:25 PM

  • Code 92 : capture the screen or the active window of your computer Programmatically

    Declarations

    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
      ByVal dwFlags As Long, ByVal dwExtraInfo As Long)




    Code 92 : capture the screen or the active window of your computer Programmatically

    Code
    Public Function fSaveGuiToFile(ByVal theFile As String) As Boolean


    Dim lString As String

    On Error goto Trap
    'Check if the File Exist
        If Dir(theFile) <> "" Then Exit Function

        'To get the Entire Screen
        Call keybd_event(vbKeySnapshot, 1, 0, 0)

          'To get the Active Window
        'Call keybd_event(vbKeySnapshot, 0, 0, 0)
     
        SavePicture Clipboard.GetData(vbCFBitmap), theFile

    fSaveGuiToFile = True
    Exit Function

    Trap:
    'Error handling
    MsgBox "Error Occured in fSaveGuiToFile. Error #: " & Err.Number & ", " & Err.Description

    End Function


    Thursday, May 24, 2007 3:28 PM

  • Code 93 : Create Multi-Column Menus in Visual Basic Using the WIN32

    Declarations
    Private Type MENUITEMINFO
          cbSize As Long
          fMask As Long
          fType As Long
          fState As Long
          wID As Long
          hSubMenu As Long
          hbmpChecked As Long
          hbmpUnchecked As Long
          dwItemData As Long
          dwTypeData As String
          cch As Long
    End Type

    Private Const MF_MENUBARBREAK = &H20& ' columns with a separator line
    Private Const MF_MENUBREAK = &H40&    ' columns w/o a separator line
    Private Const MF_STRING = &H0&
    Private Const MF_HELP = &H4000&
    Private Const MFS_DEFAULT = &H1000&
    Private Const MIIM_ID = &H2
    Private Const MIIM_SUBMENU = &H4
    Private Const MIIM_TYPE = &H10
    Private Const MIIM_DATA = &H20

    Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal B As Boolean, lpMenuItemInfo As MENUITEMINFO) As Long
    Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As Long
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long




    Code 93 : Create Multi-Column Menus in Visual Basic Using the WIN32

    Code
    ' 1.Open a new Standard EXE Project. Form1 is created by default.
    ' 2.Add a CommandButton to Form1.
    ' 3.On the Tools menu, click Menu Editor. Create a menu consisting of at least two top level menus containing at least four submenu items each.
    ' 4.Add the following code to Form1:
             
    Private Sub Command1_Click()

        ' Splitting a menu here demonstrates that this can be done dynamically.
        Dim mnuItemInfo As MENUITEMINFO, hMenu As Long, hSubMenu As Long
        Dim BuffStr As String * 80   ' Define as largest possible menu text.
        
        hMenu = GetMenu(Me.hwnd)   ' retrieve menu handle.
        BuffStr = Space(80)
        With mnuItemInfo   ' Initialize the UDT.
               .cbSize = Len(mnuItemInfo)   ' 44
               .dwTypeData = BuffStr & Chr(0)
               .fType = MF_STRING
               .cch = Len(mnuItemInfo.dwTypeData)   ' 80
               .fState = MFS_DEFAULT
               .fMask = MIIM_ID Or MIIM_DATA Or MIIM_TYPE Or MIIM_SUBMENU
        End With

        ' Use item break point position for the '3' below (zero-based list).
        hSubMenu = GetSubMenu(hMenu, 0)
        If GetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
           MsgBox "GetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
        Else
           mnuItemInfo.fType = mnuItemInfo.fType Or MF_MENUBARBREAK
           If SetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
              MsgBox "SetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
           End If
        End If
        DrawMenuBar (Me.hwnd)   ' Repaint top level Menu.

    End Sub



    Private Sub Form_Load()

        ' This works for either an API-created menu or a native VB Menu.
        Dim mnuItemInfo As MENUITEMINFO, hMenu As Long, hSubMenu As Long
        Dim BuffStr As String * 80   ' Define as largest possible menu text.
        
        hMenu = GetMenu(Me.hwnd)   ' Retrieve menu handle.
        BuffStr = Space(80)
        
        With mnuItemInfo   ' Initialize the UDT
               .cbSize = Len(mnuItemInfo)   ' 44
               .dwTypeData = BuffStr & Chr(0)
               .fType = MF_STRING
               .cch = Len(mnuItemInfo.dwTypeData)   ' 80
               .fState = MFS_DEFAULT
               .fMask = MIIM_ID Or MIIM_DATA Or MIIM_TYPE Or MIIM_SUBMENU
        End With

        ' Use item break point position for the '3' below (zero-based list).
        hSubMenu = GetSubMenu(hMenu, 1)
        If GetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
           MsgBox "GetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
        Else
           mnuItemInfo.fType = mnuItemInfo.fType Or MF_MENUBREAK
           If SetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
              MsgBox "SetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
           End If
        End If
        DrawMenuBar (Me.hwnd)   ' Repaint top level Menu.

    End Sub



    Thursday, May 24, 2007 3:31 PM
  • Code 94 : Stay on Top option

    Declarations
    'Add this into your module

    Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

    Global Const conHwndTopmost = -1
    Global Const conHwndNoTopmost = -2
    Global Const conSwpNoActivate = &H10
    Global Const conSwpShowWindow = &H40


    Code 94 : Stay on Top option

    Code
    'Stick an checkbox on your form, call it chkStayOnTop
    'Make sure you define your form properties after the conHwndTopmost statement
    Select Case chkStayOnTop.Checked

    Case False
    mnuStayOnTop.Checked = True
    SetWindowPos hwnd, conHwndTopmost, 100, 100, 205, 141, conSwpNoActivate Or conSwpShowWindow
            
    Case True
    chkStayOnTop.Checked = False
    SetWindowPos hwnd, conHwndNoTopmost, 100, 100, 205, 141, conSwpNoActivate Or conSwpShowWindow

    End Select


    Thursday, May 24, 2007 3:33 PM

  • Code 95 : Automatically drops down the list portion of a ComboBox control whenever the ComboBox receives the focus

    Declarations

    Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long




    Code 95 : Automatically drops down the list portion of a ComboBox control whenever the ComboBox receives the focus

    Code
    Private Sub Combo1_GotFocus()
       Const CB_SHOWDROPDOWN = &H14F
       Dim Tmp
       Tmp = SendMessage(Combo1.hwnd, CB_SHOWDROPDOWN, 1, ByVal 0&)
    End Sub



    Thursday, May 24, 2007 3:43 PM

  • Code 96 : Retrieve and Set windows 32 Regional Settings

    Declarations
    Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
    Declare Function SetLocaleInfo Lib "kernel32" Alias "SetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String) As Boolean
    Declare Function GetUserDefaultLCID% Lib "kernel32" ()

    Public Const LOCALE_ICENTURY = &H24
    Public Const LOCALE_ICOUNTRY = &H5
    Public Const LOCALE_ICURRDIGITS = &H19
    Public Const LOCALE_ICURRENCY = &H1B
    Public Const LOCALE_IDATE = &H21
    Public Const LOCALE_IDAYLZERO = &H26
    Public Const LOCALE_IDEFAULTCODEPAGE = &HB
    Public Const LOCALE_IDEFAULTCOUNTRY = &HA
    Public Const LOCALE_IDEFAULTLANGUAGE = &H9
    Public Const LOCALE_IDIGITS = &H11
    Public Const LOCALE_IINTLCURRDIGITS = &H1A
    Public Const LOCALE_ILANGUAGE = &H1
    Public Const LOCALE_ILDATE = &H22
    Public Const LOCALE_ILZERO = &H12
    Public Const LOCALE_IMEASURE = &HD
    Public Const LOCALE_IMONLZERO = &H27
    Public Const LOCALE_INEGCURR = &H1C
    Public Const LOCALE_INEGSEPBYSPACE = &H57
    Public Const LOCALE_INEGSIGNPOSN = &H53
    Public Const LOCALE_INEGSYMPRECEDES = &H56
    Public Const LOCALE_IPOSSEPBYSPACE = &H55
    Public Const LOCALE_IPOSSIGNPOSN = &H52
    Public Const LOCALE_IPOSSYMPRECEDES = &H54
    Public Const LOCALE_ITIME = &H23
    Public Const LOCALE_ITLZERO = &H25
    Public Const LOCALE_NOUSEROVERRIDE = &H80000000
    Public Const LOCALE_S1159 = &H28
    Public Const LOCALE_S2359 = &H29
    Public Const LOCALE_SABBREVCTRYNAME = &H7
    Public Const LOCALE_SABBREVDAYNAME1 = &H31
    Public Const LOCALE_SABBREVDAYNAME2 = &H32
    Public Const LOCALE_SABBREVDAYNAME3 = &H33
    Public Const LOCALE_SABBREVDAYNAME4 = &H34
    Public Const LOCALE_SABBREVDAYNAME5 = &H35
    Public Const LOCALE_SABBREVDAYNAME6 = &H36
    Public Const LOCALE_SABBREVDAYNAME7 = &H37
    Public Const LOCALE_SABBREVLANGNAME = &H3
    Public Const LOCALE_SABBREVMONTHNAME1 = &H44
    Public Const LOCALE_SCOUNTRY = &H6
    Public Const LOCALE_SCURRENCY = &H14
    Public Const LOCALE_SDATE = &H1D
    Public Const LOCALE_SDAYNAME1 = &H2A
    Public Const LOCALE_SDAYNAME2 = &H2B
    Public Const LOCALE_SDAYNAME3 = &H2C
    Public Const LOCALE_SDAYNAME4 = &H2D
    Public Const LOCALE_SDAYNAME5 = &H2E
    Public Const LOCALE_SDAYNAME6 = &H2F
    Public Const LOCALE_SDAYNAME7 = &H30
    Public Const LOCALE_SDECIMAL = &HE
    Public Const LOCALE_SENGCOUNTRY = &H1002
    Public Const LOCALE_SENGLANGUAGE = &H1001
    Public Const LOCALE_SGROUPING = &H10
    Public Const LOCALE_SINTLSYMBOL = &H15
    Public Const LOCALE_SLANGUAGE = &H2
    Public Const LOCALE_SLIST = &HC
    Public Const LOCALE_SLONGDATE = &H20
    Public Const LOCALE_SMONDECIMALSEP = &H16
    Public Const LOCALE_SMONGROUPING = &H18
    Public Const LOCALE_SMONTHNAME1 = &H38
    Public Const LOCALE_SMONTHNAME10 = &H41
    Public Const LOCALE_SMONTHNAME11 = &H42
    Public Const LOCALE_SMONTHNAME12 = &H43
    Public Const LOCALE_SMONTHNAME2 = &H39
    Public Const LOCALE_SMONTHNAME3 = &H3A
    Public Const LOCALE_SMONTHNAME4 = &H3B
    Public Const LOCALE_SMONTHNAME5 = &H3C
    Public Const LOCALE_SMONTHNAME6 = &H3D
    Public Const LOCALE_SMONTHNAME7 = &H3E
    Public Const LOCALE_SMONTHNAME8 = &H3F
    Public Const LOCALE_SMONTHNAME9 = &H40
    Public Const LOCALE_SMONTHOUSANDSEP = &H17
    Public Const LOCALE_SNATIVECTRYNAME = &H8
    Public Const LOCALE_SNATIVEDIGITS = &H13
    Public Const LOCALE_SNATIVELANGNAME = &H4
    Public Const LOCALE_SNEGATIVESIGN = &H51
    Public Const LOCALE_SPOSITIVESIGN = &H50
    Public Const LOCALE_SSHORTDATE = &H1F
    Public Const LOCALE_STHOUSAND = &HF
    Public Const LOCALE_STIME = &H1E
    Public Const LOCALE_STIMEFORMAT = &H1003



    Code 96 : Retrieve and Set windows 32 Regional Settings

    Code
    Private Sub Get_locale() ' Retrieve the regional setting

          Dim Symbol As String
          Dim iRet1 As Long
          Dim iRet2 As Long
          Dim lpLCDataVar As String
          Dim Pos As Integer
          Dim Locale As Long
          
          Locale = GetUserDefaultLCID()

    'LOCALE_SDATE is the constant for the date separator
    'as stated in declarations
    'for any other locale just change the contant in the Function
          
          iRet1 = GetLocaleInfo(Locale, LOCALE_SDATE, lpLCDataVar, 0)
          Symbol = String$(iRet1, 0)
          
          iRet2 = GetLocaleInfo(Locale, LOCALE_SDATE, Symbol, iRet1)
          Pos = InStr(Symbol, Chr$(0))
          If Pos > 0 Then
               Symbol = Left$(Symbol, Pos - 1)
               msgbox "Regional Setting = " + symbol
          End If

    End sub

    Private Sub Set_locale() 'Change the regional setting

          Dim Symbol As String
          Dim iRet As Long
          Dim Locale As Long
          
    'LOCALE_SDATE is the constant for the date separator
    'as stated in declarations
    'for any other locale just change the contant in the Function

          Locale = GetUserDefaultLCID() 'Get user Locale ID
          Symbol = "-" 'New character for the locale
          iRet = SetLocaleInfo(Locale, LOCALE_SDATE, Symbol)


        
    End Sub


    Thursday, May 24, 2007 3:46 PM

  • Code 97 : Disable/Enable Ctrl+Alt+Del and Alt+Tab

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

    Public Const SPI_SCREENSAVERRUNNING = 97



    Code 97 : Disable/Enable Ctrl+Alt+Del and Alt+Tab

    Code
    Private Sub ToggleCtrlAltDel(IsEnabled As Boolean)
       Dim lReturn  As Long
       Dim lBool As Long
       lReturn = SystemParametersInfo(SPI_SCREENSAVERRUNNING, IsEnabled, lBool, vbNull)
    End Sub


    Thursday, May 24, 2007 3:48 PM

  • Code 98 : Changing the System colors from visual basic

    Declarations
    Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long
    Public Const COLOR_ACTIVEBORDER = 10
    Public Const COLOR_ACTIVECAPTION = 2
    Public Const COLOR_APPWORKSPACE = 12
    Public Const COLOR_BACKGROUND = 1
    Public Const COLOR_BTNFACE = 15
    Public Const COLOR_BTNSHADOW = 16
    Public Const COLOR_BTNTEXT = 18
    Public Const COLOR_CAPTIONTEXT = 9
    Public Const COLOR_INACTIVEBORDER = 11
    Public Const COLOR_INACTIVECAPTION = 3
    Public Const COLOR_MENU = 4
    Public Const COLOR_MENUTEXT = 7
    Public Const COLOR_SCROLLBAR = 0
    Public Const COLOR_WINDOW = 5
    Public Const COLOR_WINDOWFRAME = 6
    Public Const COLOR_WINDOWTEXT = 8




    Code 98 : Changing the System colors from visual basic

    Code
    Public Sub elements()
    Combo1.AddItem "COLOR_ACTIVEBORDER"
    Combo1.AddItem "COLOR_ACTIVECAPTION"
    Combo1.AddItem "COLOR_APPWORKSPACE"
    Combo1.AddItem "COLOR_BACKGROUND"
    Combo1.AddItem "COLOR_BTNFACE"
    Combo1.AddItem "COLOR_BTNTEXT"
    Combo1.AddItem "COLOR_CAPTIONTEXT"
    Combo1.AddItem "COLOR_INACTIVEBORDER"
    Combo1.AddItem "COLOR_INACTIVECAPTION"
    Combo1.AddItem "COLOR_MENU"
    Combo1.AddItem "COLOR_MENUTEXT"
    Combo1.AddItem "COLOR_SCROLLBAR"
    Combo1.AddItem "COLOR_WINDOW"
    Combo1.AddItem "COLOR_WINDOWFRAME"
    Combo1.AddItem "COLOR_WINDOWTEXT"
    End Sub

    Private Sub Command1_Click()
    Dim RT As Long
    CD.ShowColor
    Call CHANGE_COLORS
    End Sub

    Private Sub Command2_Click()
    End
    End Sub

    Private Sub Form_Load()
    Call elements
    End Sub

    Public Sub CHANGE_COLORS()
    Select Case Combo1.Text
    Case "COLOR_ACTIVEBORDER"
         RT = SetSysColors(1, 10, CD.Color)
    Case "COLOR_ACTIVE_CAPTION"
         RT = SetSysColors(1, 2, CD.Color)
    Case "COLOR_APPWORKSPACE"
         RT = SetSysColors(1, 12, CD.Color)
    Case "COLOR_BACKGROUND"
         RT = SetSysColors(1, 1, CD.Color)
    Case "COLOR_BTNFACE"
         RT = SetSysColors(1, 15, CD.Color)
    Case "COLOR_BTNTEXT"
         RT = SetSysColors(1, 16, CD.Color)
    Case "COLOR_CAPTIONTEXT"
         RT = SetSysColors(1, 9, CD.Color)
    Case "COLOR_INACTIVEBORDER"
         RT = SetSysColors(1, 11, CD.Color)
    Case "COLOR_INACTIVECAPTION"
         RT = SetSysColors(1, 3, CD.Color)
    Case "COLOR_MENU"
         RT = SetSysColors(1, 4, CD.Color)
    Case "COLOR_MENUTEXT"
         RT = SetSysColors(1, 7, CD.Color)
    Case "COLOR_SCROLLBAR"
         RT = SetSysColors(1, 0, CD.Color)
    Case "COLOR_WINDOW"
         RT = SetSysColors(1, 5, CD.Color)
    Case "COLOR_WINDOWFRAME"
         RT = SetSysColors(1, 6, CD.Color)
    Case "COLOR_WINDOWTEXT"
         RT = SetSysColors(1, 8, CD.Color)
    End Select
    End Sub



    Thursday, May 24, 2007 3:50 PM

  • Code 99 : Create Database Through Visual Basic
    Private Sub Command1_Click()
    On Error GoTo procerror
    Screen.MousePointer = 11
    Dim dbname As String
    dbname = GetDBName()
    If Len(dbname) > 0 Then
       CreateDB dbname
    End If
    procexit:
    Screen.MousePointer = 0
    Exit Sub
    procerror:
    MsgBox Err.Description
    Resume procexit

    End Sub

    Public Function GetDBName() As String
    On Error GoTo procerror
    Dim filename As String
    cd.DefaultExt = "mdb"
    cd.DialogTitle = "Create Database"
    cd.Filter = "VB Databases (*.mdb)|*.mdb"
    cd.FilterIndex = 1
    cd.Flags = cdlOFNHideReadOnly Or _
               cdlOFNOverwritePrompt Or _
               cdlOFNPathMustExist
    cd.CancelError = True
    cd.ShowSave
    filename = cd.filename
    On Error Resume Next
    Kill filename

    procexit:
    GetDBName = filename
    Exit Function


    procerror:
    filename = ""
    Resume procexit
    End Function

    Public Sub CreateDB(dbname As String)
    Dim db As Database
    Set db = DBEngine(0).CreateDatabase(dbname, dbLangGeneral)
    End Sub

    Private Sub Command2_Click()
    Form2.Show
    End Sub

    Private Sub Command3_Click()
    Form3.Show
    End Sub

    Private Sub Command4_Click()
    Form4.Show
    End Sub

    Thursday, May 24, 2007 3:54 PM

  • Code 101 : Get Data From Excel To Visual Basic

    Option Explicit
    Dim db As Database
    Dim rs As Recordset
    Private filepath As String
    Private sheetname As String

    Private Sub Form_Activate()
    DoEvents
    filepath = "G:\Sanket\Project Base\Codes\Tryouts\test.xls"
    sheetname = "Sheet1$"
    Set db = OpenDatabase(filepath, False, False, "Excel 8.0;HDR=yes;")
    Set rs = db.OpenRecordset(sheetname)
    rs.MoveFirst
    Screen.MousePointer = 11
    While rs.EOF <> True
    List1.AddItem rs.Fields("Name") & "  " & rs.Fields(1) & "  " & rs.Fields(2)
    rs.MoveNext
    Wend
    Screen.MousePointer = 0
    End Sub

    Thursday, May 24, 2007 3:56 PM

  • Code 101 : Play Wav Sound Files Using API's

    Declarations
    'module (Api Functions declarations)

    Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

    Public Const SND_ALIAS = &H10000     '  name is a WIN.INI [sounds] entry
    Public Const SND_ASYNC = &H1         '  play asynchronously
    Public Const SND_LOOP = &H8         '  loop the sound until next sndPlaySound
    Public Const SND_NOWAIT = &H2000      '  don't wait if the driver is busy
    Public Const SND_SYNC = &H0         '  play synchronously (default)




    Code 101 : Play Wav Sound Files Using API's

    Code
    'Form code

    public sub cmdPlaysoundClick()

    dim ret as long
    ret=sndplaysound("F:\Songs\Dhoom-2\Title.mp3",SND_SYNC)

    End Sub



    Thursday, May 24, 2007 3:59 PM

  • Code 102 : Search a ListBox Control Quickly Using API Call

    Declarations
    Const LB_FINDSTRING = &H18F
    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



    Code 102 : Search a ListBox Control Quickly Using API Call

    Code
    Private Sub Text1_Change()
        List1.ListIndex = SendMessage(List1.hWnd, LB_FINDSTRING, -1, _
                    ByVal Text1.Text)
    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


    Thursday, May 24, 2007 4:01 PM

  • Code 103 : Tells you how long you have been in windows using the GetTickCount API

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



    Code 103 : Tells you how long you have been in windows using the GetTickCount API

    Code
    lblTime.Caption = Format(GetTickCount, "0") 'How long in windows (milliseconds)
    'lblTime.Caption = Format(GetTickCount / 60000, "0") 'How long in windows in (seconds)


    Thursday, May 24, 2007 4:05 PM
  • Code 104 : get GetKeyboardLayout language from a thread

    Declarations
    Public 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



    Code 104 : get GetKeyboardLayout language from a thread

    Code
    Public Sub FindTheardlanguage  ()

    Dim TheardId As Long
    Dim TheardLang As Long

        TheardId = get_threadId 'call function
        TheardLang = GetKeyboardLayout(ByVal TheardId)
        TheardLang = TheardLang Mod 10000
        
      Select Case TheardLang
       Case 9721 'english
        'do your stuff
        
       Case 1869 'hebrew
         'do your stuff
       
      End Select
        

    End Sub



    Public Function get_threadId() As Long
    Dim threadid As Long, processid As Long

    get_threadId = GetWindowThreadProcessId(winHWND, processid)

    End Function



    Thursday, May 24, 2007 4:11 PM

  • Code 105 : How to get the Windows directory with only one line code
    Dim Windows (Optional)

    Windows = Environ("Windir")
    'Get the Windows directory from a MS-Dos Environment, stored in c:\msdos.sys


    MsgBox Windows (Optional)
    Thursday, May 24, 2007 4:15 PM
  • Code 106 : Get the User Name of a person logged into a particular machine in Windows NT

    Declarations
    Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

    Dim counter As Long, s As String
    Dim dl As Long


    Code 106 : Get the User Name of a person logged into a particular machine in Windows NT

    Code
    counter = 200    'size of buffer
    s = String(counter, 0)

    dl = GetComputerName(s, counter)
    Text1.Text = Left(s, counter)     'gets the name of the user in a textbox



    Thursday, May 24, 2007 4:18 PM

  • Code 107 : Get the name of a particular computer

    Declarations
    Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

    Dim dl As Long
    Dim cnt As Long, s As String



    Code 107 : Get the name of a particular computer

    Code
        cnt = 200
        s = String(cnt, 0)
            
        dl = GetComputerName(s, counter)
        Text1.Text = Left(s, counter)
            
       


    Thursday, May 24, 2007 4:23 PM
  • Code 108 : Auto-searching by entering text in a combo box

    Declarations
    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 Const CB_FINDSTRING = &H14C


    Code 108 : Auto-searching by entering text in a combo box

    Code
    Enter the following code in the combo box's Change event:  
     
    Private Sub Combo1_Change()
      Dim iStart As Integer
      Dim sString As String
      Static iLeftOff As Integer
     
      iStart = 1
      iStart = Combo1.SelStart
     
      If iLeftOff <> 0 Then
        Combo1.SelStart = iLeftOff
        iStart = iLeftOff
      End If
     
      sString = CStr(Left(Combo1.Text, iStart))
      Combo1.ListIndex = SendMessage(Combo1.hwnd, _
      CB_FINDSTRING, -1, ByVal CStr(Left( _
      Combo1.Text, iStart)))
     
      If Combo1.ListIndex = -1 Then
        iLeftOff = Len(sString)
        Combo1.Text = sString
      End If
     
      Combo1.SelStart = iStart
      iLeftOff = 0
    End Sub 


    Thursday, May 24, 2007 4:25 PM
  • Code 109 : gets the state of any key on the keyboard

    Declarations
    Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer


    Code 109 : gets the state of any key on the keyboard

    Code
    'Have you ever faced the problem of not being able to
    'get key input when more than four keys are being
    'pressed? With this API it is no longer a problem!
    'This is a short sample that gets the state of any key
    'on the keyboard. The numbers passed in are the same as
    'the keycodes in Form_KeyDown. You can look these up by
    'typing "key code constants" in the VB help. The return
    'values are sort of weird. At the beginning, the value
    'of an unpressed key is 0, if it is held down after that,
    'the value is -127, unpressed again is 1, and the second
    'pressed value is -128. This cycle then repeats itself.

    Dim RetValue As Long
    Dim SendKeyCode As Long
    SendKeyCode = 37 'Left key
    RetValue = GetKeyState(SendKeyCode)
    Print RetValue



    Thursday, May 24, 2007 4:29 PM
  • Code 110 : Change Date Format of the system

    Declarations
    Public Const LOCALE_SSHORTDATE As Long = &H1F
    Public Const LOCALE_USER_DEFAULT As Long = &H400

    Public Declare Function GetLocaleInfo Lib "kernel32" _
        Alias "GetLocaleInfoA" (ByVal lLocale As Long, _
            ByVal lLocaleType As Long, ByVal sLCData As String, _
            ByVal lBufferLength As Long) As Long
    Public Declare Function SetLocaleInfo Lib "kernel32" _
        Alias "SetLocaleInfoA" (ByVal Locale As Long, _
            ByVal LCType As Long, ByVal lpLCData As String) As Long



    Code 110 : Change Date Format of the system

    Code
    'put this code at form
    'i have used for short date format similarly it can be used for long
    'date format

        Dim shortDateFormat As String
        Dim lBuffSize As String
        Dim sBuffer As String
        Dim lRetGet As Long
        Dim lRetSet As Long
        
        lBuffSize = 256
        sBuffer = String$(lBuffSize, vbNullChar)
        'get the date information in buffer
        lRetGet = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SSHORTDATE, sBuffer, lBuffSize)
     
        If lRetGet > 0 Then
            shortDateFormat = Left$(sBuffer, lRetGet - 1)
            'this is the existing format of machine
       End If
        'to change the format if doesn't matches ur format
        'MM should be used in capital for monyhs,small m are for minutes
        If LCase(shortDateFormat) <> "dd/mm/yyyy" Then
            lRetSet = SetLocaleInfo(LOCALE_USER_DEFAULT,_ LOCALE_SSHORTDATE, "dd/MM/yyyy")
    'on sucess lretset have value greater than 0
            If lRetSet <= 0 Then
                 msgbox "date format not changed
            End If
        End If



    Thursday, May 24, 2007 4:31 PM
  • Code 111 : Adding AutoComplete to a VB Text Box

    Declarations
    'Add a label (Label1), and text box (Text1) and a command button (Command1) to
    'a form, and add the following:


    Option Explicit

    'Flags to control the operation of SHAutoComplete.
    'The first four are used to override the Internet
    'Explorer registry settings. The user can change
    'these settings manually by launching the Internet
    'Options property sheet from the Tools menu and
    'clicking the Advanced tab.The last five can be
    'used to specify which files or URLs will be
    'available for autoappend or autosuggest operations.

    'Ignore registry default and force feature on
    Private Const SHACF_AUTOSUGGEST_FORCE_ON  As Long = &H10000000

    'Ignore registry default and force feature off.
    Private Const SHACF_AUTOSUGGEST_FORCE_OFF  As Long = &H20000000

    'Ignore registry default and force feature on. (Also know as AutoComplete)
    Private Const SHACF_AUTOAPPEND_FORCE_ON  As Long = &H40000000

    'Ignore registry default and force feature off. (Also know as AutoComplete)
    Private Const SHACF_AUTOAPPEND_FORCE_OFF  As Long = &H80000000

    'Currently (SHACF_FILESYSTEM | SHACF_URLALL)
    Private Const SHACF_DEFAULT  As Long = &H0

    'Includes the File System as well as the rest
    'of the shell (Desktop\My Computer\Control Panel\)
    Private Const SHACF_FILESYSTEM  As Long = &H1

    'URLs in the User's History
    Private Const SHACF_URLHISTORY  As Long = &H2

    'URLs in the User's Recently Used list
    Private Const SHACF_URLMRU  As Long = &H4

    Private Const SHACF_URLALL  As Long = (SHACF_URLHISTORY Or SHACF_URLMRU)

    'Identifies the platform for which the DLL was built.
    Private Const DLLVER_PLATFORM_WINDOWS As Long = &H1  'Windows 95
    Private Const DLLVER_PLATFORM_NT As Long = &H2       'Windows NT

    Private Type DllVersionInfo
       cbSize As Long
       dwMajorVersion As Long
       dwMinorVersion As Long
       dwBuildNumber As Long
       dwPlatformID As Long
    End Type

    Private Declare Function SHAutoComplete _
       Lib "Shlwapi.dll" _
      (ByVal hwndEdit As Long, _
       ByVal dwFlags As Long) As Long

    Private Declare Function DllGetVersion _
       Lib "Shlwapi.dll" _
      (dwVersion As DllVersionInfo) As Long



    Code 111 : Adding AutoComplete to a VB Text Box

    Code
    Private Function GetIEVersion(DVI As DllVersionInfo) As Long
       
       DVI.cbSize = Len(DVI)
       Call DllGetVersion(DVI)

       GetIEVersion = DVI.dwMajorVersion
       
    End Function


    Private Function GetIEVersionString() As String
       
       Dim DVI As DllVersionInfo
       
       DVI.cbSize = Len(DVI)
       Call DllGetVersion(DVI)

       GetIEVersionString = "Internet Explorer " & _
                            DVI.dwMajorVersion & "." & _
                            DVI.dwMinorVersion & "." & _
                            DVI.dwBuildNumber
       
    End Function


    Private Sub Command1_Click()

       Dim DVI As DllVersionInfo

       If GetIEVersion(DVI) >= 5 Then
       
         'Turn on auto-complete
          Call SHAutoComplete(Text1.hWnd, SHACF_DEFAULT)
          
         'update the captions and set focus to the textbox
          Command1.Caption = "SHAutoComplete is On"
          Command1.Enabled = False
          Text1.SetFocus
          Text1.SelStart = Len(Text1.Text)
       
       Else
       
         'damn!
          MsgBox "Sorry ... you need IE5 to use this demo", vbExclamation
          
       End If
       
    End Sub


    Private Sub Form_Load()

      'dim a DllVersionInfo type
       Dim DVI As DllVersionInfo

      'display the version of Shlwapi
       Label1 = "Using Shlwapi.dll for " & GetIEVersionString
       
      'if not 5 or greater, can't do it
       Command1.Enabled = GetIEVersion(DVI) >= 5
       Command1.Caption = "SHAutoComplete is Off"

    End Sub



    Thursday, May 24, 2007 4:33 PM
  • Code 112 : Single Line Code to Hide the Start Button

    Declarations
    Private Declare Function ShowWindow Lib "User32" (ByVal hWnd as Long,ByVal nCmdShow as Long) as Long
    ' Please Kindly check the API Declartion for the Above Function or Declare the
    ' function using API Text Viewer


    Code 112 : Single Line Code to Hide the Start Button

    Code

    Private Sub Command1_Click
    ShowWindow 532,0 'To Hide
    ShowWindow 532,1 'To Show
    End Sub



    Thursday, May 24, 2007 4:36 PM

  • Code 113 : Find and replace one string with another
        Function FindReplace(SourceString, SearchString, ReplaceString)
            tmpString1 = SourceString
            Do Until vFixed
                tmpString2 = tmpString1
                tmpString1 = ReplaceFirstInstance(tmpString1, SearchString,ReplaceString)
                If tmpString1 = tmpString2 Then vFixed = True
            Loop
            FindReplace = tmpString1
        End Function

        Function ReplaceFirstInstance(SourceString, SearchString, ReplaceString)
            FoundLoc = InStr(1, SourceString, SearchString)
            If FoundLoc <> 0 Then
                    ReplaceFirstInstance = Left(SourceString, FoundLoc - 1) & _
                    ReplaceString & Right(SourceString, _
                    Len(SourceString) - (FoundLoc - 1) - Len(SearchString))
            Else
                ReplaceFirstInstance = SourceString
            End If
        End Function
    Thursday, May 24, 2007 4:38 PM
  • Code 114 : Quick and easy encryption
    'Encryption function
    Public Function Encrypt(ByVal Plain As String)
        Dim Letter As String
        For I = 1 To Len(Plain)
            Letter = Mid$(Plain, I, 1)
            Mid$(Plain, I, 1) = Chr(Asc(Letter) + 1)
        Next I
        Encrypt = Plain
    End Function
    'Here's the Decryption function:
    Public Function Decrypt(ByVal Encrypted As String)
    Dim Letter As String
        For I = 1 To Len(Encrypted)
            Letter = Mid$(Encrypted, I, 1)
            Mid$(Encrypted, I, 1) = Chr(Asc(Letter) - 1)
        Next I
        Decrypt = Encrypted
    End Function

    'here is sample code to test it....
    Dim strMessage As String
    strMessage = "Original:"
    strMessage = strMessage & "This is a test" & vbCrLf
    strMessage = strMessage & vbCrLf & "Encrypted:"
    strMessage = strMessage & Encrypt("This is a test") & vbCrLf
    strMessage = strMessage & vbCrLf & "Un-Encrypted:"
    strMessage = strMessage & Decrypt(Encrypt("This is a test"))
    MsgBox strMessage
    Thursday, May 24, 2007 4:42 PM
  • Code 115 : Fast append of strings

    Declarations
    Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As Long
    Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
    Declare Function GetTickCount Lib "kernel32" () As Long



    Code 115 : Fast append of strings

    Code
    Private Sub Command1_Click()
       
       Dim g         As String
       
       Label1.Caption = ""
       u% = DoEvents
       tim& = GetTickCount
       '**************
       ' slow version
       '**************
       'note the second & is just to prove that joining to strings is
       'not inherently slow, only adding a string to itself g$ = g$ & extra
       
       For a% = 1 To 5000
          g = g & "str" & "g "
       Next
       
       '****
       Text1.Text = GetTickCount - tim&
       Label1.Caption = g
       
    End Sub

    Private Sub Command2_Click()
       Label1.Caption = ""
       u% = DoEvents
       tim& = GetTickCount
       Dim pos&
       Dim src As String
       Dim des As String
       '****************
       ' Fast Version
       '****************
       'Allocates a big string, then copies the smaller strings into it.
       'this means that VB does not need to perform the expensive
       'dynamic realocation of string memory!
       
       des = Space$(10000)
       
       src = "str" & "g "
       For a% = 1 To 5000
          If pos& + LenB(src) > LenB(des) Then des = des & Space$(10000)
          CopyMemory ByVal StrPtr(des) + pos&, ByVal StrPtr(src), LenB(src)
          pos& = pos& + LenB(src)
       Next
       
       des = Left$(des, pos& \ 2) 'trim back to size
       '**********
       Text2.Text = GetTickCount - tim&
       Label1.Caption = des
    End Sub



    Friday, May 25, 2007 5:59 PM

  • Code 116 : Function takes a number and returns the text for that number in check like format
    Function NumToText (dblValue As Double) As String
        Static ones(0 To 9) As String
        Static teens(0 To 9) As String
        Static tens(0 To 9) As String
        Static thousands(0 To 4) As String
        Dim i As Integer, nPosition As Integer
        Dim nDigit As Integer, bAllZeros As Integer
        Dim strResult As String, strTemp As String
        Dim tmpBuff As String

        ones(0) = "zero"
        ones(1) = "one"
        ones(2) = "two"
        ones(3) = "three"
        ones(4) = "four"
        ones(5) = "five"
        ones(6) = "six"
        ones(7) = "seven"
        ones(8) = "eight"
        ones(9) = "nine"

        teens(0) = "ten"
        teens(1) = "eleven"
        teens(2) = "twelve"
        teens(3) = "thirteen"
        teens(4) = "fourteen"
        teens(5) = "fifteen"
        teens(6) = "sixteen"
        teens(7) = "seventeen"
        teens(8) = "eighteen"
        teens(9) = "nineteen"

        tens(0) = ""
        tens(1) = "ten"
        tens(2) = "twenty"
        tens(3) = "thirty"
        tens(4) = "forty"
        tens(5) = "fifty"
        tens(6) = "sixty"
        tens(7) = "seventy"
        tens(8) = "eighty"
        tens(9) = "ninty"

        thousands(0) = ""
        thousands(1) = "thousand"
        thousands(2) = "million"
        thousands(3) = "billion"
        thousands(4) = "trillion"

        'Trap errors
        On Error GoTo NumToTextError
        'Get fractional part
        strResult = "and " & Format((dblValue - Int(dblValue)) * 100, "00") & "/100"
        'Convert rest to string and process each digit
        strTemp = CStr(Int(dblValue))
        'Iterate through string
        For i = Len(strTemp) To 1 Step -1
            'Get value of this digit
            nDigit = Val(Mid$(strTemp, i, 1))
            'Get column position
            nPosition = (Len(strTemp) - i) + 1
            'Action depends on 1's, 10's or 100's column
            Select Case (nPosition Mod 3)
                Case 1  '1's position
                    bAllZeros = False
                    If i = 1 Then
                        tmpBuff = ones(nDigit) & " "
                    ElseIf Mid$(strTemp, i - 1, 1) = "1" Then
                        tmpBuff = teens(nDigit) & " "
                        i = i - 1   'Skip tens position
                    ElseIf nDigit > 0 Then
                        tmpBuff = ones(nDigit) & " "
                    Else
                        'If next 10s & 100s columns are also
                        'zero, then don't show 'thousands'
                        bAllZeros = True
                        If i > 1 Then
                            If Mid$(strTemp, i - 1, 1) <> "0" Then
                                bAllZeros = False
                            End If
                        End If
                        If i > 2 Then
                            If Mid$(strTemp, i - 2, 1) <> "0" Then
                                bAllZeros = False
                            End If
                        End If
                        tmpBuff = ""
                    End If
                    If bAllZeros = False And nPosition > 1 Then
                        tmpBuff = tmpBuff & thousands(nPosition / 3) & " "
                    End If
                    strResult = tmpBuff & strResult
                Case 2  'Tens position
                    If nDigit > 0 Then
                        strResult = tens(nDigit) & " " & strResult
                    End If
                Case 0  'Hundreds position
                    If nDigit > 0 Then
                        strResult = ones(nDigit) & " hundred " & strResult
                    End If
            End Select
        Next i
        'Convert first letter to upper case
        If Len(strResult) > 0 Then
            strResult = UCase$(Left$(strResult, 1)) & Mid$(strResult, 2)
        End If

    EndNumToText:
        'Return result
        NumToText = strResult
        Exit Function

    NumToTextError:
        strResult = "#Error#"
        Resume EndNumToText

    End Function

    Friday, May 25, 2007 6:02 PM
  • Code 117 : Function to remove all occurrences of a string inside another string
    Public Function RemoveString(pStr As String, strRemove As String, Optional ignoreCase As Variant) As String

    'Removes all occurences of strRemove from pStr
    'ignoreCase tells us to ignore the case when making comparisons

    On Error GoTo RemoveStringERR

    Dim opStr As String
    Dim c As New Collection
    Dim s As New clsStringAnalyser
    Dim res As Variant

        If IsMissing(ignoreCase) Then
            ignoreCase = True
        End If
        
        c.Add strRemove
        
        res = s.PopWord(pStr, ignoreCase, c)
        
        Do While Not IsNull(res)
            opStr = opStr + res
            res = s.PopWord()
        Loop
        
        RemoveString = opStr
        
    RemoveStringEXIT:
        Exit Function
    RemoveStringERR:
        RemoveString = Null
        Err.Raise (Err.Number)
        Resume RemoveStringEXIT
    End Function
    Friday, May 25, 2007 6:06 PM
  • Code 118 : Another way to find and replace all instances of one string in another
    Public Sub RemoveString(Entire As String, Word As String)
        Dim I As Integer
        I = 1
        Dim LeftPart
        Do While True
            I = InStr(1, Entire, Word)
            If I = 0 Then
                Exit Do
            Else
                LeftPart = Left(Entire, I - 1)
                Entire = LeftPart & Right(Entire, Len(Entire) - Len(Word) - Len(LeftPart))
            End If
        Loop
        MsgBox Entire
    End Sub

    Public Sub Form_Load()
        RemoveString "StringToSearch", "WordToRemove"
    End Sub
    Friday, May 25, 2007 6:08 PM

  • Code 119 : Token Routine - sGetToken
    Public Function sGetToken(ByVal sAllTokens As String, Optional ByVal iToken As Integer = 1, Optional ByVal sDelim As String = " ") As String
        Static iCurTokenLocation As Long ' Character position of the first delimiter string
        Static nDelim As Integer            ' Length of the delimiter string
        nDelim = Len(sDelim)

        If iToken < 1 Or nDelim < 1 Then
         ' Negative or zeroth token or empty delimiter strings mean an empty token
           Exit Function
        ElseIf iToken = 1 Then
         ' Quickly extract the first token
           iCurTokenLocation = InStr(sAllTokens, sDelim)
           If iCurTokenLocation > 1 Then
              sGetToken = Left(sAllTokens, iCurTokenLocation - 1)
           ElseIf iCurTokenLocation = 1 Then
              sGetToken = ""
           Else
              sGetToken = sAllTokens
           End If
           Exit Function
        Else
         ' Find the Nth token
           Do
              iCurTokenLocation = InStr(sAllTokens, sDelim)
              If iCurTokenLocation = 0 Then
                 Exit Function
              Else
                 sAllTokens = Mid(sAllTokens, iCurTokenLocation + nDelim)
              End If
              iToken = iToken - 1
           Loop Until iToken = 1

         ' Extract the Nth token (Which is the next token at this point)
           iCurTokenLocation = InStr(sAllTokens, sDelim)
           If iCurTokenLocation > 0 Then
              sGetToken = Left(sAllTokens, iCurTokenLocation - 1)
              Exit Function
           Else
              sGetToken = sAllTokens
              Exit Function
           End If
        End If
    End Function

    Friday, May 25, 2007 6:10 PM

  • Code 120 :  4 different types of sorts (Bubble,Comb,Selection,Exchange)
    '''''''''''''''''''''''''''''''''''''
    Bubble sort
    '''''''''''''''''''''''''''''''''''''''
    Dim I, J  As Integer
        Dim Swapped As Boolean
        Dim Temp As String
        I = Arrsize
        Do
            Swapped = False
            For J = 0 To I - 1
                lstbubble.AddItem Array2(1) & "," & Array2(2) & "," & Array2(3) & "," & Array2(4) & "," & Array2(5)
            
                Bubcom = Bubcom + 1
                If Array2(J) > Array2(J + 1) Then 'swap
                
                    Temp = Array2(J)
                    Array2(J) = Array2(J + 1)
                    Array2(J + 1) = Temp
                    
                    Swapped = True
                    Bubbleswap = Bubbleswap + 1
                    'lstbubble.AddItem Array2(1) & "," & Array2(2) & "," & Array2(3) & "," & Array2(4) & "," & Array2(5)
                End If
            
            Next J
        
            I = I - 1
        Loop Until Not Swapped
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Exchange sort
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        Dim Front, Back, I As Integer
        Dim Temp As String
        
       
        For Front = 0 To Arrsize
            For Back = Front To Arrsize
                Excom = Excom + 1
                
                If Array(Front) > Array(Back) Then
                    Temp = Array(Front)
                    Array(Front) = Array(Back)
                    Array(Back) = Temp
                Exswap = Exswap + 1
                End If
            Next Back
        Next Front
    ''''''''''''''''''''''''''''''''''''''''''''''
    Comb sort
    '''''''''''''''''''''''''''''''''''''''''''''' Dim I, J, Temp As Integer
        Const Shrink = 1.3
        Dim Gap As Single
        Dim Swapped As Boolean
        Gap = Arrsize - 1
        
        Do
            Gap = Int(Gap / Shrink)
            Swapped = True
            Combcom = Combcom + 1
            For J = 0 To Arrsize - Gap
                If Array3(J) > Array3(J + Gap) Then
                Temp = Array3(J)
                Array3(J) = Array3(J + Gap)
                Array3(J + Gap) = Temp
                Swapped = False
                Combswap = Combswap + 1
                End If
            Next J
        Loop Until Not Swapped And Gap = 1

        For I = 0 To Arrsize
           lstcomb.AddItem Array3(I)
        Next I
    ''''''''''''''''''''''''''''''''''''''''''''''''
    Selection sort
    ''''''''''''''''''''''''''''''''''''''''''''''
        Dim Front, Back, I, Loc As Integer
        Dim Temp As String
     
        For Front = 0 To Arrsize - 1
            Loc = Front
            
            For Back = Front To Arrsize
              Selcom = Selcom + 1
              If Array4(Loc) > Array4(Back) Then
                 Loc = Back
              End If
            Next Back
            Selswap = Selswap + 1
            Temp = Array4(Loc)
            Array4(Loc) = Array4(Front)
            Array4(Front) = Temp

        Next Front

    Friday, May 25, 2007 6:11 PM

  • Code 121 : These functions will extract an email address and url from given text
    'Call the functions as follows:
    '   txtInput = GetHTML (txtInput)
    '   txtInput = GetEmail (txtInput)


    Public Function GetEmail(Inp As String) As String

    Dim chrAt As String
    Dim chrOpen As String
    Dim chrClose As String
    Dim phrHREF As String
    Dim phrMailTo As String
    Dim strFirst As String
    Dim strLast As String
    Dim strEmail As String

    chrAt = InStr(1, Inp$, "@")
    chrOpen = InStr(1, Inp$, "<")
    chrClose = InStr(1, Inp$, ">")

    phrHREF = InStr(1, Inp$, "<a href=")
    phrMailTo = InStr(1, Inp$, Chr$(34) & "mailto:")

    strFirst = InStr(1, Inp$, "<a href=" & Chr$(34) & "mailto:")
    strLast = InStr(1, Inp$, Chr$(34) & ">")

    If chrOpen Then
        If chrClose Then
            If phrHREF Then
                If phrMailTo Then
                    If strFirst Then
                        If strLast Then
                        ' Start retreiving email address
                            Inp$ = Mid$(Inp$, phrMailTo + 8)
                            GetEmail$ = Mid(Inp$, 1, InStr(1, Inp$, Chr$(34)) - 1)
                        ' End retreiving email address
                        End If
                    End If
                End If
            End If
        End If
    End If

    End Function


    Public Function GetURL(Inp As String) As String

    Dim chrOpen As String
    Dim chrClose As String
    Dim phrHREF As String
    Dim strFirst As String
    Dim strLast As String
    Dim strEmail As String
    Dim strHTTP As String

    chrOpen = InStr(1, Inp$, "<")
    chrClose = InStr(1, Inp$, ">")

    phrHREF = InStr(1, Inp$, "<a href=")

    strFirst = InStr(1, Inp$, "<a href=" & Chr$(34))
    strLast = InStr(1, Inp$, Chr$(34) & ">")
    strHTTP = InStr(1, Inp$, "http://")

    If chrOpen Then
        If chrClose Then
            If phrHREF Then
                If strFirst Then
                    If strLast Then
                    ' Start retreiving URL
                        Inp$ = Mid$(Inp$, strHTTP)
                        GetURL$ = Mid(Inp$, 1, InStr(1, Inp$, Chr$(34)) - 1)
                    ' End retreiving URL
                    End If
                End If
            End If
        End If
    End If

    End Function

    Friday, May 25, 2007 6:13 PM

  • Code 121 : Take a string, and convert all words to have the first letter be a capital
    Public Function UpAllWords(ByVal TEXTIN As String) As String
    ' Put this code into a module of your choice

    Dim TextinS() As String
    Dim Letter As String
    Dim FinalWord As String
    Dim MyItem As Integer
    Dim c As Integer

    TextinS = Split(TEXTIN, " ")

    MyItem = UBound(TextinS)
    For c = 0 To MyItem

    Letter = Left(TextinS(c), 1)
    Letter = UCase(Letter)
    FinalWord = (Right(Letter, 1)) & Mid(TextinS(c), 2)
    TextinS(c) = FinalWord

    If UBound(TextinS) = c Then
        UpAllWords = UpAllWords & TextinS(c)
    Else
        UpAllWords = UpAllWords & TextinS(c) & " "
    End If

    Next c

    End Function
    Friday, May 25, 2007 6:15 PM

  • Code 123 : A very efficient way to return a file name from a full path
    Public Function FileNameOnly(strPathName As String) As String
        Dim lngIndex As Long            ' Backslash character positon
        Dim strRemnant As Variant       ' What remains after trimming off
                                        ' everything to the left
                                        ' of the last backslash character.
        
        strRemnant = strPathName
        
        Do
            lngIndex = InStr(strRemnant, "\")
            If lngIndex = 0 Then Exit Do    ' There are no more backslash characters: we have the name.
            strRemnant = Right$(strRemnant, Len(strRemnant) - lngIndex)
        Loop
        
        FileNameOnly = strRemnant           ' Sock it to me!
    End Function

    Friday, May 25, 2007 6:18 PM

  • Code 124 : Search and change color for multiple sub-strings in RichTextBox
        'declare the temp variables
        Dim lWhere, lPos As Long
        Dim sTmp, sSearch As String
        
        'set lPos to 1 for mid()
        lPos = 1
        'this is the searched string
        sSearch = "DATA"
            
        'loop the whole text
        Do While lPos < Len(Me.RichTextBox1.Text)
            
            'get sub string from the text
            'this is because the InStr() returns the
            'position of first occurence of the string...
            sTmp = Mid(Me.RichTextBox1.Text, lPos, Len(Me.RichTextBox1.Text))
            
            'find the string in sub string
            lWhere = InStr(sTmp, sSearch)
            'accumulate the lPos to be relative to the actual text
            lPos = lPos + lWhere
            
            If lWhere Then   ' If found,
                Me.RichTextBox1.SelStart = lPos - 2   ' set selection start and
                Me.RichTextBox1.SelLength = Len(sSearch)   ' set selection length.   Else
                Me.RichTextBox1.SelColor = RGB(255, 0, 0) 'change color to red
            Else
                Exit Do 'we are ready
            End If
        Loop
    Friday, May 25, 2007 6:20 PM

  • Code 125 : Removes duplicate spaces within strings
    Public Function SquishSpaces( ByVal strText As String ) As String

        Const TWO_SPACES As String = "  "
       
        Dim intPos As Integer
        Dim strTemp As String
       
        intPos = InStr(1, strText, TWO_SPACES, vbBinaryCompare)
        Do While intPos > 0
            strTemp = LTrim$(Mid$(strText, intPos + 1))
            strText = Left$(strText, intPos) & strTemp
            intPos = InStr(1, strText, TWO_SPACES, vbBinaryCompare)
        Loop
       
       SquishSpaces = strText   

    End Function

    Friday, May 25, 2007 6:23 PM

  • Code 126 : routine to print a long text string splitting it in short text lines starting in "X" position
    'A simple routine to print a long text string splitting it in short
    'text lines starting in "X" position
    '
    'It is useful when you have a multi-line text box and need to print
    'it's content within a limited area on a paper form.
    '
    'The easiest way is looking for line advance character [Chr(10)] but
    'you can use any character you wish.

    'Public declarations
      Dim LongText as String, ShortLine as String

      Public Sub PrintLongText(LongText As String)
         Do While InStr(1, LongText, Chr(10), 0)
            Pos = InStr(1, LongText, Chr(10), 0)
            ShortLine = Left(LongText, Pos)
            LongText = Right(LongText, Len(LongText) - Pos)
            Printer.Print Tab(X); ShortLine;
         Loop
         Printer.Print Tab(X); LongText
      End Sub

    'Call the routine
      PrintLongText TexBox.text
    Friday, May 25, 2007 6:26 PM

  • Code 127 : Simple recursive function
    'The function below goes on adding the numbers in a string untill it
    'becomes a single number between 0 and 9,e.g., 1234=1+2+3+4=10=1
    Private Function ReX(ByVal AnyStr As String) As String
      Dim n As Integer, i As Integer
      For i = 1 To Len(AnyStr)
        n = n + Val(Mid(AnyStr, i, 1))
      Next
      If Len(Str(n)) > 2 Then n = Val(ReX(Str(n)))
      ReX = Right(Str(n), 1)
    End Function

    Friday, May 25, 2007 6:28 PM

  • Code 128 : Check Spelling Using Excel's Spell Checker
    Private Sub cmdSpell_Click()
    Dim XlSpell As Object
    Set XlSpell = CreateObject("Excel.sheet")
    Set XlSpell = XlSpell.application.activeworkbook.activesheet
    XlSpell.Range("A1").Value = txtspell.Text
    XlSpell.CheckSpelling
    txtspell.Text = XlSpell.Range("A1").Value
    Set XlSpell = Nothing
    AppActivate Caption
    End Sub
    Friday, May 25, 2007 6:32 PM

  • Code 129 : A simple Substitution function. Works on HEX data
    Function GenerateSBox(ByVal SBoxSeed As Integer) As String


    Dim A(256) As Integer

    ' MOD 256 it to 0>=n<=255

    SBoxSeed = SBoxSeed Mod 256

    ' Fill the array with stuff
    ' -------------------------
    For Z = 0 To 255
        A(Z) = (154 + Z) Mod 256
    Next Z

    ' Generate the Substitution Box using the "Stuff" in the array
    ' ------------------------------------------------------------
    For P = 0 To SBoxSeed
        For x = (67 + P) To 3 Step -1
            For Z = 0 To 255 Step (4 + x)
                s = Z + x
                If s > 255 Then s = s Mod 256
                C = A(s)
                B = A(Z)
                A(s) = B
                A(Z) = C
            Next Z
        Next x
    Next P

    ' Convert the Array to a Hex string
    ' ---------------------------------

    H:
    For Z = 0 To 255
        L = ""
        If Len(Trim(Hex(A(Z)))) < 2 Then L = "0"
        TOT = TOT & L & Hex(A(Z))
    Next Z

    GenerateSBox = TOT

    End Function

    Friday, May 25, 2007 6:35 PM

  • Code 130 : code to properly pluralize peoples names
    Public Sub PluralizeIt(playerName)
    Dim stringLen As Long
    Dim S As String
    Dim letter As String
    S = "s"
    stringLen = Len(playerName)
    letter = Mid(playerName, stringLen, 1)
    If letter = S Then
        playerName = playerName & "'"
    Else
        playerName = playerName & "'s"
    End If


    End Sub

    Friday, May 25, 2007 6:36 PM

  • Code 131 : This function will extract the initials of someone's name
    Public Function ExtractInitials(InString As String) As String

    Dim OutString As String, CurrentLetter As String, Scap As String, ourstring As String
    Dim CurrentWord As String, TCaps As String
    Dim StrCount As Integer, I As Byte

    OutString = ""

    If InString = "" Then
        ExtractInitials = ""
        Exit Function
    End If

    CurrentWord = ""

    For StrCount = 1 To Len(InString)
        CurrentLetter = Mid(InString, StrCount, 1)
        CurrentWord = CurrentWord + CurrentLetter
            If InStr(" .,/\;:-!?[]()#", CurrentLetter) <> 0 Or _
                StrCount = Len(InString) Then
                TCaps = UCase(Left(CurrentWord, 1))
                    For I = 2 To Len(CurrentWord)
                        TCaps = TCaps & Mid(CurrentWord, I, 1)
                        Scap = Left(TCaps, 1)
                    Next
                'OutString = OutString & TCaps
                ourstring = ourstring & Scap
                CurrentWord = ""
            End If
    Next
    If Len(ourstring) > 3 Then
        MsgBox "The name cannot be greater then 3 initials, please correct"
        Exit Function
    End If
    ExtractInitials = ourstring

    End Function

    Friday, May 25, 2007 6:39 PM

  • Code 132 : Simple secure password textbox example

    Dim strPassword As String 'Stores the password typed into the locked textbox

    Private Sub Form_Load()
        Text1.Locked = True 'The control is locked, but we can still set focus and 'type' into it.
        Text1.PasswordChar = "*" 'Sets the textbox as a password box using * as the mask character
    End Sub

    Private Sub Text1_KeyDown(KeyCode As Integer, Shift As Integer)
        Select Case KeyCode
            Case Is = vbKeyBack
                If Text1.Text = "" Then 'If nothing in Text1 (or in strPassword), ignore the backspace subroutine
                  Else
                    strPassword = Left(strPassword, (Len(strPassword) - 1)) 'Erase the last character from strPassword
                    Text1.Text = Left(Text1.Text, (Len(Text1.Text) - 1)) 'Erase the last 'character' from Text1
                    Label1.Caption = strPassword 'Update Label1
                End If
            Case 9 To 47, 112 To 127
            
            Case Else
                Text1.Text = Text1.Text & Text1.PasswordChar 'Add a 'character' into Text1.Text
                strPassword = strPassword & Chr(KeyCode) 'Add the new character to strPassword
                Label1.Caption = strPassword 'Update Label1
        End Select
    End Sub

    Friday, May 25, 2007 6:41 PM

  • Code 133 : Scrambles or descrambles a string according to the ROT13 standard
    'The following should be placed in a module:

    Public Function Rot13(ByVal j As String) As String
    Dim c As Byte
    Dim t As String
    t = j
    For i = 1 To Len(j)
    t = Right(t, Len(j) - i + 1)
    c = Asc(t)
    If (c > 64) And (c < 78) Then
    Rot13 = Rot13 + Chr(c + 13)
    ElseIf (c > 77) And (c < 91) Then
    Rot13 = Rot13 + Chr(c - 13)
    ElseIf (c > 96) And (c < 110) Then
    Rot13 = Rot13 + Chr(c + 13)
    ElseIf (c > 109) And (c < 123) Then
    Rot13 = Rot13 + Chr(c - 13)
    Else
    Rot13 = Rot13 + Chr(c)
    End If
    Next i
    End Function

    Friday, May 25, 2007 6:43 PM

  • Code 134 : Convert any Numerical String Format to valid numerical string
    Public Function SwitchDot(Txt As String) As String
        Dim dblTstErr As Double
        Dim Ctr As Integer, Nb As Integer
        On Error Resume Next
        Nb = 0
        For Ctr = 1 To Len(Txt)
            If Mid(Txt, Ctr, 1) = "." Then
                Nb = Nb + 1
            End If
        Next
        If Nb > 1 Or Nb = 0 Then
            Nb = 0
            For Ctr = 1 To Len(Txt)
                If Mid(Txt, Ctr, 1) = "," Then
                    Nb = Nb + 1
                End If
            Next
        End If
        If Nb > 1 Then
            Nb = 0
            For Ctr = 1 To Len(Txt)
                If Mid(Txt, Ctr, 1) = "," Then
                    Nb = Nb + 1
                End If
            Next
            If Nb > 1 Then
                Nb = 0
                For Ctr = 1 To Len(Txt)
                    If Mid(Txt, Ctr, 1) = "." Then
                        Nb = Nb + 1
                    End If
                Next
            End If
        End If
        If Nb = 1 Or Nb = 0 Then
            SwitchDot = Txt
            dblTstErr = CDbl(SwitchDot)
            If Err <> 0 Then
                Err = 0
                SwitchDot = Replace(Txt, ",", ".")
                dblTstErr = CDbl(SwitchDot)
                If Err <> 0 Then
                    Err = 0
                    If InStr(1, Txt, ".") > 0 Then
                        SwitchDot = Replace(Txt, ",", " ")
                        dblTstErr = CDbl(SwitchDot)
                        If Err <> 0 Then
                            Err = 0
                            SwitchDot = Replace(SwitchDot, ".", ",")
                            dblTstErr = CDbl(SwitchDot)
                            If Err <> 0 Then
                                SwitchDot = "0"
                            End If
                        End If
                    End If
                    If Err <> 0 Then
                        Err = 0
                        If InStr(1, Txt, ",") > 0 Then
                            SwitchDot = Replace(Txt, ".", " ")
                            dblTstErr = CDbl(SwitchDot)
                            If Err <> 0 Then
                                Err = 0
                                SwitchDot = Replace(SwitchDot, ",", ".")
                                dblTstErr = CDbl(SwitchDot)
                                If Err <> 0 Then
                                    SwitchDot = "0"
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        Else
            SwitchDot = "0"
        End If
    End Function

    Friday, May 25, 2007 6:45 PM

  • Code 135 : Look at the encoded text such as word document
    Private Sub Form_Load()
               CurrentLog = -1
               Screen.MousePointer = 11
               fIlenum = FreeFile
               Open "G:\Encoded.dot" For Binary Access Read As fIlenum
               editor.TextRTF = Input(LOF(fIlenum), fIlenum)
               Close (fIlenum)
               Screen.MousePointer = 0
               
    End Sub
    Friday, May 25, 2007 6:48 PM

  • Code 136 : Clear/Change caption on all labels/command buttons, text on all textboxes
    'You can use any control events

    Private Sub Command1_Click()
        For Each controlx in Form1.Controls
        If TypeOf controlx is Textbox Then controlx.Text = ""
        If TypeOf controlx is Label Then controlx.Caption = ""
        If TypeOf controlx if CommandButtons Then controlx.Caption = "Click"
        Next controlx
    End Sub

    Friday, May 25, 2007 6:50 PM
  • Code 137 : Scrolling text (no depedencies)

    Declarations
    public Cancld
    'Place cancld = 1 in a cancel button to stop the scroll effect


    Code 137 : Scrolling text (no depedencies)

    Code
    ' this code will scroll text in a label named "Label1" with am interval of 3000 between each "scroll shot"

    cancld = 0

    Do
      u = Label1.Caption
      Y = Mid$(u, 1, 1)
      Label1.Caption = Mid$(Label1.Caption, 2, Len(Label1.Caption)) & Y
      For v = 1 To 3000
        DoEvents
      Next v
      Form1.Refresh
    Loop Until cancld = 1

    Friday, May 25, 2007 6:54 PM

  • Code 138 : Generate an Oracle-compliant SoundEx() string
    Private Function SoundEx(ByVal WordString As String, Optional SoundExLen As Integer = 4) As String
    Dim Counter As Integer
    Dim CurrChar As String

    If SoundExLen > 10 Then
        SoundExLen = 10
    ElseIf SoundExLen < 4 Then
        SoundExLen = 4
    End If
    SoundExLen = SoundExLen - 1

    WordString = UCase(WordString)

    For Counter = 1 To Len(WordString)
        If Asc(Mid(WordString, Counter, 1)) < 65 Or Asc(Mid(WordString, Counter, 1)) > 90 Then
           Mid(WordString, Counter, 1) = " "
        End If
    Next Counter
    WordString = Trim(WordString)

    SoundEx = WordString

    SoundEx = Replace(SoundEx, "A", "0")
    SoundEx = Replace(SoundEx, "E", "0")
    SoundEx = Replace(SoundEx, "I", "0")
    SoundEx = Replace(SoundEx, "O", "0")
    SoundEx = Replace(SoundEx, "U", "0")
    SoundEx = Replace(SoundEx, "Y", "0")
    SoundEx = Replace(SoundEx, "H", "0")
    SoundEx = Replace(SoundEx, "W", "0")
    SoundEx = Replace(SoundEx, "B", "1")
    SoundEx = Replace(SoundEx, "P", "1")
    SoundEx = Replace(SoundEx, "F", "1")
    SoundEx = Replace(SoundEx, "V", "1")
    SoundEx = Replace(SoundEx, "C", "2")
    SoundEx = Replace(SoundEx, "S", "2")
    SoundEx = Replace(SoundEx, "G", "2")
    SoundEx = Replace(SoundEx, "J", "2")
    SoundEx = Replace(SoundEx, "K", "2")
    SoundEx = Replace(SoundEx, "Q", "2")
    SoundEx = Replace(SoundEx, "X", "2")
    SoundEx = Replace(SoundEx, "Z", "2")
    SoundEx = Replace(SoundEx, "D", "3")
    SoundEx = Replace(SoundEx, "T", "3")
    SoundEx = Replace(SoundEx, "L", "4")
    SoundEx = Replace(SoundEx, "M", "5")
    SoundEx = Replace(SoundEx, "N", "5")
    SoundEx = Replace(SoundEx, "R", "6")

    CurrChar = Left(SoundEx, 1)
    For Counter = 2 To Len(SoundEx)
        If Mid(SoundEx, Counter, 1) = CurrChar Then
            Mid(SoundEx, Counter, 1) = " "
        Else
            CurrChar = Mid(SoundEx, Counter, 1)
        End If
    Next Counter
    SoundEx = Replace(SoundEx, " ", "")

    SoundEx = Mid(SoundEx, 2)
    SoundEx = Replace(SoundEx, "0", "")

    SoundEx = SoundEx & String(SoundExLen, "0")
    SoundEx = Left(WordString, 1) & Left(SoundEx, SoundExLen)
    End Function

    Friday, May 25, 2007 6:56 PM

  • Code 139 : Reverses Text
    Sub Rev()

    Dim leng, i, x
    leng = Len(Text1)
    For i = 0 To leng
    x = leng - i - 1
    Text2 = Text2 & Mid(Text1, x, 1)
    Next

    End Sub

    Friday, May 25, 2007 6:59 PM

  • Code 140 : A nifty littel password generator
    Private Sub Command1_Click()
        Const Abc = "ABCDEFGHIJLMNOPQRSTUVWXYZ"
        Dim i, x, z, a
        Randomize
        For z = 1 To 12
            a = Int((Rnd * 2) + 1)
            If a = 1 Then
                i = Int((Rnd * 25) + 1)
                x = Mid(Abc, i, 1)
            End If
            If a = 2 Then
                x = Int((Rnd * 9) + 1)
            End If
            Text1 = Text1 & x
        Next
    End Sub
    Friday, May 25, 2007 7:02 PM

  • Code 141 : Make a label blink
    ' add this code into the timer:

    If lblBlink.Visible = True Then
       lblBlink.Visible = False
    Else
       lblBlink.Visible = True
    End If


    Friday, May 25, 2007 7:05 PM

  • Code 142 : SQL single quote headaches vanish with one line of code
    Replace the single quote with chr 146. Looks like the real thing and your SQL statement loves it.

    YourString = Replace(YourString, "'", Chr(146))

    Friday, May 25, 2007 7:07 PM

  • Code 143 : Convert a String to an Integer
    Public Function Str2Int(s As String) As Integer
        Dim temp, ch As String
        Dim i, mult As Integer
        
        temp = s
        i = 0
        mult = 1
        
        While Len(temp) <> 0
            ch = Right(temp, 1)
            i = i + mult * (Asc(ch) - Asc("0"))
            mult = mult * 10
            temp = Left(temp, Len(temp) - 1)
        Wend
        
        Str2Int = i
    End Function

    Friday, May 25, 2007 7:09 PM

  • Code 144 : The complete validation for your project including date

    put this code in your module and call it from your form
    Public Sub KeyPress(KeyAscii As Integer)
        If KeyAscii = vbKeyReturn Then
            SendKeys ("{TAB}")
        End If
    End Sub

    Public Function caps(s1 As String) As String
        caps = UCase(s1)
    End Function

    Public Sub novalidation(KeyAscii As Integer)
        If Not (KeyAscii > 47 And KeyAscii < 59) Then
            If Not KeyAscii = vbKeyBack Then
                KeyAscii = 0
            End If
        End If
    End Sub

    Public Sub datevalidation(KeyAscii As Integer)
        If Not (KeyAscii > 47 And KeyAscii < 59) Then
            If KeyAscii = 45 Or KeyAscii = 47 Then
                Exit Sub
            End If
            If Not KeyAscii = vbKeyBack Then
                KeyAscii = 0
            End If
        End If
    End Sub

    Public Sub alphabets(KeyAscii As Integer)
        If Not (KeyAscii > 96 And KeyAscii < 123) Then
            If Not (KeyAscii > 64 And KeyAscii < 91) Then
                If Not KeyAscii = Asc(" ") Then
                    If Not KeyAscii = vbKeyBack Then
                        KeyAscii = 0
                    End If
                End If
            End If
        End If
    End Sub

    Public Sub numbersonly(KeyAscii As Integer)
        If Not (KeyAscii > 47 And KeyAscii < 58) Then
                    If Not KeyAscii = vbKeyBack Then
                        KeyAscii = 0
                    End If
        End If
    End Sub

    Friday, May 25, 2007 7:12 PM

  • Code 145 : Count elapsed time between two times in one line of code
    Private Sub Command1_Click()
        Label1.Caption = Time
        
    End Sub

    Private Sub Command2_Click()
         Label2.Caption = Time
         
    End Sub

    Private Sub Command3_Click()
       
        Form1.Caption = Format(TimeValue(Label2.Caption) - TimeValue _(Label1.Caption), "HH:MM:SS")

    End Sub

    Friday, May 25, 2007 7:15 PM

  • Code 146 : Correct way to insert and center text on a picture
    Label1.Font.Name = Text1.Font.Name
    Label1.Font.Size = Text1.Font.Size
    Label1.Font.Bold = Text1.Font.Bold
    Label1.Caption = Text1.Text
    Picture1.Font.Size = Text1.Font.Size
    Picture1.Font.Name = Text1.Font.Name
    Picture1.Font.Bold = Text1.Font.Bold
    Picture1.Font.Italic = Text1.Font.Italic
    Picture1.Font.Underline = Text1.Font.Underline
    Picture1.Font.Strikethrough = Text1.FontStrikethru
    Picture1.ForeColor = Text1.ForeColor

    Picture1.CurrentX = (Picture1.ScaleWidth / 2) - (label1.width / 2)
    Picture1.CurrentY = (Picture1.ScaleHeight / 2) - (label1.height / 2)

    Picture1.Print Text1.Text
    Picture1.Picture=Picture1.Image

    Friday, May 25, 2007 7:18 PM

  • Code 147 : Round up currency amounts to next quarter
    Private Sub cmdRound_Click()
    Dim TotCost As Single
    Dim srTotal As String
    Dim Quarters As Integer

        TotCost = Val(txtCost.Text)  'insert entered value into var
        srTotal = CCur(TotCost) 'round value to two decimals and convert to string
        srTotal = Format(srTotal, "currency") 'force string to give 2 decimal places
       
        'round up to next highest quarter dollar
        If Val(Right$(srTotal, 2)) > 75 Then
            srTotal = Int(srTotal) + 1
        ElseIf Val(Right$(srTotal, 2)) > 50 Then
            Quarters = 3
            srTotal = Int(srTotal) + (0.25 * Quarters)
        ElseIf Val(Right$(srTotal, 2)) > 25 Then
            Quarters = 2
            srTotal = Int(srTotal) + (0.25 * Quarters)
        ElseIf Val(Right(srTotal, 2)) > 0 Then
            Quarters = 1
            srTotal = Int(srTotal) + (0.25 * Quarters)
        End If
        
        srTotal = Format(srTotal, "currency") 'convert string to currency again
        lblRounded.Caption = srTotal            'display rounded value in label
        
    End Sub

    Friday, May 25, 2007 7:21 PM

  • Code 148 : simple routine to remove all non-alphanumeric charaters from a string
    Private Function CleanWords(ByVal Words As String) As String

        Const ALPHA = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz "
        Const SNG_SPACE = " "
        Const DBL_SPACE = "  "
        
        Dim iPos As Integer
        Dim sChar As String, sWork As String
        Dim lCntr As Long
        
        'Set the working variable
        sWork = Trim(Words)
        
        'Remove all charaters that are NOT in the ALPHA const
        For lCntr = 0 To 255
            If InStr(ALPHA, Chr(lCntr)) = 0 Then
                sWork = Replace(sWork, Chr(lCntr), SNG_SPACE)
            End If
        Next lCntr
        
        'Remove all double spaces created
        iPos = InStr(sWork, DBL_SPACE)
        While iPos > 0
            sWork = Replace(sWork, DBL_SPACE, SNG_SPACE)
            iPos = InStr(sWork, DBL_SPACE)
        Wend
        
        'Return the cleaned string
        CleanWords = sWork
        
    End Function

    Friday, May 25, 2007 7:23 PM

  • Code 149 : A very cool 3d text
        Dim i, x, y
        Me.FontSize = 26
        Me.ForeColor = 0: x = CurrentX: y = CurrentY
        For i = 0 To 444
            Print "Sanket Shah" ' Here goes your text.
            x = x + 1: y = y + 1: CurrentX = x: CurrentY = y
        Next i
            Me.ForeColor = 255
            Print "Sanket Shah"

    Friday, May 25, 2007 7:26 PM

  • Code 150 : Converts string into legal file name
    Public Function MakeIntoLegalFileName(ByVal FileName As String) As String
        Dim I As Integer
        Dim S As String
        
        I = 1
        
        Do While I <= Len(FileName)
            S = Mid(FileName, I, 1)
            If S = "\" Or S = "/" Or S = ":" Or S = "*" Or S = "?" Or S = "<" Or _
                S = ">" Or S = "|" Or S = Chr(34) Then
                If I > 1 Then
                    FileName = Left(FileName, I - 1) & Right(FileName, Len(FileName) - I)
                Else
                    FileName = Right(FileName, Len(FileName) - 1)
                End If
            End If
            I = I + 1
        Loop
        
        MakeIntoLegalFileName = FileName
    End Function
    Friday, May 25, 2007 7:28 PM

  • Code 151 : Verifies if a string you enter is a palendrome or not
    Dim strWord As String
    Dim strReverse As String
    Dim i As Integer

    strWord = Text1.Text

    For i = Len(strWord) To 1 Step -1
         strReverse = strReverse & Mid$(strWord, i, 1)
    Next i

    If UCase(strReverse) = UCase(strWord) Then
         MsgBox "This IS a palendrome.", vbExclamation = vbOKOnly, "Yes Indeed"
         Beep
         Exit Sub
    Else
         MsgBox "This IS NOT a palendrome.", vbCritical = vbOKOnly, "Sorry"
    End If

    Friday, May 25, 2007 7:31 PM

  • Code 152 : Converts a Decimal Base number into different Bases
    label1.Caption = "Binary:"
    label2.Caption = "Octal:"
    label3.Caption = "Hex:"
    label4.Caption = "ASCII:"
    If text1.Text < 1000000000# Then text3.Text = Oct$(text1.Text)
    If text1.Text < 1000000000# Then text4.Text = Hex$(text1.Text)
    If text1.Text > 255 Or text1.Text < 0 Then text5.Text = "NA"
    If text1.Text < 256 And text1.Text > 0 Then text5.Text = Chr$(text1.Text)

    Friday, May 25, 2007 7:33 PM

  • Code 153 : Convert a decimal number to a radian, or a radian to decimal
    Function Rad2Dec(rads As Long)
         Rad2Dec = ((rads * 180) / 3.141592654)
    End Function


    Function Dec2Rad(decs As Long)
         Dec2Rad = ((decs * 3.141592654) / 180)
    End Function

    Friday, May 25, 2007 7:38 PM

  • Code 154 : Decimal to fraction
    Option Explicit

    Private Sub Command1_Click()
       Dim upperPart As Long
       Dim lowerPart As Long
       
       Call Dec2Frac(Val(Text1.Text) / Val(Text2.Text), upperPart, lowerPart)
       Text3.Text = upperPart & "/" & lowerPart
    End Sub

    Private Sub Dec2Frac(ByVal f As Double, upperPart As Long, lowerPart As Long)
       Dim df As Double
       upperPart = 1
       lowerPart = 1
       
       df = upperPart / lowerPart
       While (df <> f)
          If (df < f) Then
             upperPart = upperPart + 1
          Else
             lowerPart = lowerPart + 1
             upperPart = f * lowerPart
          End If
          df = upperPart / lowerPart
       Wend
    End Sub

    Friday, May 25, 2007 7:40 PM
  • Man you are awesome, really good code. I dont know how to thank you.
    When this thread gets to 10 pages, start another thread for the continuation to this one Smile

    You really rox, you are getting better and better; )
    Friday, May 25, 2007 7:44 PM
  • Code 155 : Returns true if the number is a prime number

    Public Function IsPrime(ByVal n As Long) As Boolean
       Dim i As Long
      
       IsPrime = False
      
       If n <> 2 And (n And 1) = 0 Then Exit Function 'test if div 2
       If n <> 3 And n Mod 3 = 0 Then Exit Function 'test if div 3
       For i = 6 To Sqr(n) Step 6
          If n Mod (i - 1) = 0 Then Exit Function
          If n Mod (i + 1) = 0 Then Exit Function
       Next
      
       IsPrime = True

    End Function



    Friday, May 25, 2007 7:45 PM

  • Code 156 : Validating Credit Card Numbers
    Public Function IsValidCreditCardNumber(ByVal sCardNo As String) As Boolean
       
       Const MAX_DIGITS = 20  ' actually don't know any card using more than 16 digits
       
       Dim anDigits(1 To MAX_DIGITS) As Byte
       Dim nDigits As Long
       
       Dim ofsCurrentDigit As Long
       Dim ofsCurrentCharacter As Long
       
       Dim CurrentCharacter As String
       
       Dim Multiplier As Long
       Dim CheckSum As Long
       Dim DigitValue As Long
       
       Dim ValidDigits As String
       
       If Len(Trim$(sCardNo)) < 1 Then
          Result = False
          GoTo Exit_Point
       End If
       
       ValidDigits = "0123456789"
       
       For ofsCurrentCharacter = 1 To Len(sCardNo)
          CurrentCharacter = Mid$(sCardNo, ofsCurrentCharacter, 1)
          If InStr(1, ValidDigits, CurrentCharacter, vbBinaryCompare) Then
             nDigits = nDigits + 1
             If nDigits > MAX_DIGITS Then
                Result = False
                GoTo Exit_Point
             End If
             anDigits(nDigits) = Val(CurrentCharacter)
          End If
       Next ofsCurrentCharacter
       
       CheckSum = anDigits(nDigits)
       
       For ofsCurrentDigit = nDigits - 1 To 1 Step -1
          
          If Multiplier = 2 Then
             Multiplier = 1
          Else
             Multiplier = 2
          End If
          DigitValue = anDigits(ofsCurrentDigit) * Multiplier
          CheckSum = CheckSum + DigitValue
          If DigitValue > 9 Then
             CheckSum = CheckSum - 9
          End If
          
       Next ofsCurrentDigit
       
       Result = ((CheckSum Mod 10) = 0)
       
    Exit_Point:
       
       IsValidCreditCardNumber = Result
       Exit Function
       
    End Function


    Friday, May 25, 2007 7:49 PM

  • Code 157 : determines the greatest common factor between two numbers
    [There are two functions. The other one is below Math_GCF].
    --------------------------------------------------------------------------------
    Public Function Math_GCF(number1 As Double, number2 As Double) As Double
    If number1 > number2 Then a = number2
    If number2 > number1 Then a = number1
    If number1 = number2 Then a = number1
    n1 = number1: n2 = number2
    h = n2 / n1
    h2 = n1 / n2
    If n1 > n2 Then
        If Math_IsInteger(Val(h2)) Then Math_GCF = n2: Exit Function
    End If
    If n2 > n1 Then
        If Math_IsInteger(Val(h)) Then Math_GCF = n1: Exit Function
    End If
    y = Math_LCM(number1, number2)
    y = Val(y)
    x = 1
    Do: DoEvents
    y = Math_LCM(Val(n1), Val(n2)) / Val(x)
    b = n1 / x
    c = n2 / x
    If Math_IsInteger(Val(y)) Then
        If Math_IsInteger(Val(b)) Then
            If Math_IsInteger(Val(c)) Then
                GCF = x
            End If
        End If
    End If
    x = x + 1
    Loop Until x = a
    Math_GCF = GCF
    If n1 > n2 Then
        Y1 = Math_LCM(Val(n1), Val(n2))
        Y1 = Val(Y1) / Val(n2)
        b = n1 / n2
        c = n2 / n2
        If Math_IsInteger(Val(Y1)) Then
            If Math_IsInteger(Val(b)) Then
                If Math_IsInteger(Val(c)) Then
                    GCF = n2
                End If
            End If
        End If
    End If
    If n1 < n2 Then
        Y1 = Math_LCM(Val(n1), Val(n2))
        Y1 = Val(Y1) / Val(n1)
        b = n1 / n1
        c = n2 / n1
        If Math_IsInteger(Val(Y1)) Then
            If Math_IsInteger(Val(b)) Then
                If Math_IsInteger(Val(c)) Then
                    GCF = n1
                End If
            End If
        End If
    End If
    Math_GCF = GCF
    End Function
    --------------------------------------------------------------------------------
    Public Function Math_IsInteger(number as double) as double
    n1 = Trim(str(number))
    n = InStr(1, n1, ".")
    If n = 0 Then Math_IsInteger = True
    If n > 0 Then Math_IsInteger = False
    End Function

    Sunday, May 27, 2007 3:46 AM
  • Code 158 : Finding real roots of quadratic equation

    '-------To find Real Roots of a Quadratic Eqaution--------------'

    Private Type QuaEqu
        x1 As Double
        x2 As Double
    End Type

    Dim d As Double

    Private Function RootsOfQuaEqu(ByVal a As Single, ByVal b As Single, ByVal c As Single) As QuaEqu
        d = (b * b - 4 * a * c)
        If d < 0 Then
            MsgBox "Roots are Imaginary"
            Exit Function
        End If
        RootsOfQuaEqu.x1 = (-b + Sqr(d)) / (2 * a)
        RootsOfQuaEqu.x2 = (-b - Sqr(d)) / (2 * a)
    End Function


    Sunday, May 27, 2007 3:48 AM
  • Code 159 : Generates unique non repeating random numbers within a range

    Declaration
    Dim arrNum15() As Integer


    Code 159 : Generates unique non repeating random numbers within a range

    Code
    Create a new project and place a button on it called cmdDisplay.  Place the following code under the cmdDisplay_click event.  Run the project and click the
    button.  Unique random numbers between 1 and 15 will be displayed.
    --------------------------------------------------------------------------------

    Private Sub cmdDisplay_Click()
    Static count As Integer
    Dim intNum As Integer

    ReDim Preserve arrNum15(1 To 15) As Integer
    count = count + 1
    Randomize
    intNum = Int((15 * Rnd) + 1) ' a random number between 1
                                 ' and 15 is generated
                                 
    If count <> 1 Then

    'This loop compares all the previous random numbers to the currently
    'generated one to see whether it already exists.  if so a new one is generated.

        For i = 1 To count - 1
            Do Until arrNum15(i) <> intNum
                If arrNum15(i) = intNum Then
                    intNum = Int((15 * Rnd) + 1)
                    i = 1 'to start checking from array element 1
                End If
            Loop
        Next i
    End If
    arrNum15(count) = intNum ' assign value to the appropriate array element
    If count = 15 Then
        count = 0
        Print "*************"
        Exit Sub
    End If
    Print intNum ' to print the numbers on the form
    End Sub


    Sunday, May 27, 2007 7:28 AM
  • Hello friends,

    I'm starting 3rd part of this thread in continuation on special request of "Harshil Patel".

    To all those who are interested, please check out the thread and participate in it. I can't do everything on own. Some help is needed from all the participants.

    The link for the newly created thread is :

    http://forums.microsoft.com/SamVaad/ShowPost.aspx?PostID=1653817&SiteID=43
    Sunday, May 27, 2007 7:35 AM

All replies


  • Code 37 - creates an Access database file with three tables

    Dim ws As Workspace
    Dim db As Database

    Set ws = DBEngine.Workspaces(0)
    Set db = ws.CreateDatabase(App.Path & "\Database.mdb", dbLangGeneral)
        
    Dim dbsNorthwind As Database
    Dim tdfNew As TableDef
    Dim tdfNew2 As TableDef
    Dim tdfNew3 As TableDef
    Dim idxNew As Index
    Dim idxLoop As Index
    Dim fldLoop As Field
    Dim prpLoop As Property

    Set dbsNorthwind = OpenDatabase(App.Path & "\Database.mdb")

    Set tdfNew = dbsNorthwind.CreateTableDef("Name")
        tdfNew.Fields.Append tdfNew.CreateField("ID", dbLong)
        tdfNew.Fields("id").Attributes = tdfNew.Fields("id").Attributes + dbAutoIncrField
        tdfNew.Fields.Append tdfNew.CreateField("First Name", dbText)
        tdfNew.Fields.Append tdfNew.CreateField("Last Name", dbText)
        dbsNorthwind.TableDefs.Append tdfNew
        
    Set tdfNew2 = dbsNorthwind.CreateTableDef("Phone Number")
        tdfNew2.Fields.Append tdfNew2.CreateField("ID", dbLong)
        tdfNew2.Fields("id").Attributes = tdfNew2.Fields("id").Attributes + dbAutoIncrField
        tdfNew2.Fields.Append tdfNew2.CreateField("First Name", dbText)
        tdfNew2.Fields.Append tdfNew2.CreateField("Last Name", dbText)
        tdfNew2.Fields.Append tdfNew2.CreateField("Number", dbText)
        dbsNorthwind.TableDefs.Append tdfNew2

    Set tdfNew3 = dbsNorthwind.CreateTableDef("Email Address")
        tdfNew3.Fields.Append tdfNew3.CreateField("ID", dbLong)
        tdfNew3.Fields("id").Attributes = tdfNew3.Fields("id").Attributes + dbAutoIncrField
        tdfNew3.Fields.Append tdfNew3.CreateField("First Name", dbText)
        tdfNew3.Fields.Append tdfNew3.CreateField("Last Name", dbText)
        tdfNew3.Fields.Append tdfNew3.CreateField("E-Mail", dbText)
        dbsNorthwind.TableDefs.Append tdfNew3

    With tdfNew
        Set idxNew = .CreateIndex("IDIndex")
            idxNew.Fields.Append idxNew.CreateField("ID")
            idxNew.Primary = True
            .Indexes.Append idxNew
        Set idxNew = .CreateIndex("FirstNameIndex")
            idxNew.Fields.Append idxNew.CreateField("First Name")
            .Indexes.Append idxNew
        Set idxNew = .CreateIndex("LastNameIndex")
            idxNew.Fields.Append idxNew.CreateField("Last Name")
            .Indexes.Append idxNew
            
    With tdfNew2
        Set idxNew = .CreateIndex("IDIndex")
            idxNew.Fields.Append idxNew.CreateField("ID")
            idxNew.Primary = True
            .Indexes.Append idxNew
        Set idxNew = .CreateIndex("FirstNameIndex")
            idxNew.Fields.Append idxNew.CreateField("First Name")
            .Indexes.Append idxNew
        Set idxNew = .CreateIndex("LastNameIndex")
            idxNew.Fields.Append idxNew.CreateField("Last Name")
            .Indexes.Append idxNew
        Set idxNew = .CreateIndex("NumberIndex")
            idxNew.Fields.Append idxNew.CreateField("Number")
            .Indexes.Append idxNew


    With tdfNew3
        Set idxNew = .CreateIndex("IDIndex")
            idxNew.Fields.Append idxNew.CreateField("ID")
            idxNew.Primary = True
            .Indexes.Append idxNew
        Set idxNew = .CreateIndex("FirstNameIndex")
            idxNew.Fields.Append idxNew.CreateField("First Name")
            .Indexes.Append idxNew
        Set idxNew = .CreateIndex("LastNameIndex")
            idxNew.Fields.Append idxNew.CreateField("Last Name")
            .Indexes.Append idxNew
        Set idxNew = .CreateIndex("EmailIndex")
            idxNew.Fields.Append idxNew.CreateField("E-Mail")
            .Indexes.Append idxNew

        Debug.Print .Indexes.Count & " Indexes in " & _
            .Name & " TableDef"

        For Each idxLoop In .Indexes

            With idxLoop
                Debug.Print "    " & .Name

                Debug.Print "        Fields"
                For Each fldLoop In .Fields
                    Debug.Print "            " & fldLoop.Name
                Next fldLoop

                Debug.Print "        Properties"

                For Each prpLoop In .Properties
                    Debug.Print "            " & prpLoop.Name & _
                        " = " & IIf(prpLoop = "", "[empty]", _
                        prpLoop)
                Next prpLoop
            End With

        Next idxLoop

    End With
    End With
    End With

    dbsNorthwind.Close

    Tuesday, May 8, 2007 9:18 AM

  • Code 38 - Getting CPU back for ADO

    Dim cmd As ADODB.Command
    Set cmd = New ADODB.Command

            cmd.ActiveConnection = "DSN=test"
            cmd.CommandTimeout = 180
            cmd.CommandText = "sp_name"
            cmd.CommandType = adCmdStoredProc
            cmd.Execute , , adAsyncExecute'<--- start ASYNCHROUS

    'You can also make a dumy progress bar to show proggres
    Do While (cmd.State And adStateExecuting) = adStateExecuting
                DoEvents
    Loop

    Tuesday, May 8, 2007 9:22 AM

  • Code 39 - Concise code to populate ADO recordset from MSAccess query with multiple parameters

    'Set reference to ADO library first.
    'In my test, the parameter query in MSAccess looks like this (for testing purpose only):
    'SELECT Titles.Title, Titles.[Year Published], Titles.PubID, Publishers.Name, 'Publishers.State
    'FROM Publishers INNER JOIN Titles ON Publishers.PubID = Titles.PubID
    'WHERE (((Titles.[Year Published])>=[SatartDate] And (Titles.[Year 'Published])<=[EndDate])
    'AND ((Publishers.State)=[StateParam]) AND '((Publishers.PubID)<=[PubIDParam]));
    '
    '
      Dim Cnn As New ADODB.Connection
      Dim Rst As New ADODB.Recordset
      '
      'Open a Connection using an ODBC DSN. You can not use Jet OLEDB Provider here.
      Cnn.Open "DSN=adoobj;UID=;PWD=;"
      '
      Set Rst = Cnn.Execute("Qry_MultiPrm #1/1/98#, #12/12/00#, 'MA', 8", , mdStoredProc)
      '
      Do While Not Rst.EOF
        Debug.Print Rst(0)
        Rst.MoveNext
      Loop
     
      Set Rst = Nothing
      Set Cnn = Nothing
      '

    Tuesday, May 8, 2007 9:23 AM

  • Code 40 - Code for converting the Parameterized ADO Command object into a SQL String that can be executed in Query-Analyzer for better error diagnostics

    '   The following code is for converting the Parameterized ADO Command object into a SQL String
    '   that can be executed in Query-Analyzer

    Public Function Cmd2SQL(objCmd As ADODB.Command) As String
    '-------------------------------------------------------
    ' Name:        Cmd2SQL
    ' Description: Takes and ADO Command object and translates it into a SQL string
    '              that you can run in Query-Analyzer to get a better error message or use
    '              in your application
    ' Parameters:  objCmd As ADODB.Command
    ' Returns:     String - the parameter text with or without quotation wrappers
    '-------------------------------------------------------
     Dim strSQL As String
     Dim n As Integer
     
        ' Take out all extra characters in CommandText
        strSQL = objCmd.CommandText
        strSQL = Replace(strSQL, "?", "")
        strSQL = Replace(strSQL, "{", "")
        strSQL = Replace(strSQL, "}", "")
        strSQL = Replace(strSQL, " ", "")
        strSQL = Replace(strSQL, "call", "")
        strSQL = Replace(strSQL, "(", "")
        strSQL = Replace(strSQL, ")", "")
        strSQL = Replace(strSQL, ",", "")
        strSQL = Replace(strSQL, "=", "")

     ' Convert parameter names to SQL @parameters
      For n = 0 To objCmd.Parameters.Count - 1
        If objCmd.Parameters(n).Name <> "RETURN_VALUE" Then
            strSQL = strSQL & " @" & objCmd.Parameters(n).Name & " = " & _
            WrapWithApos(objCmd.Parameters(n)) & ", "
        End If
      Next n

     ' Take off trailing comma
     Cmd2SQL = Left(strSQL, Len(RTrim(strSQL)) - 1)

    End Function

    Private Function WrapWithApos(prm As ADODB.Parameter) As String
    '-------------------------------------------------------
    ' Name:        WrapWithApos
    ' Description: Interrogates parameter for special cases then calls the Quote
    '              function to wrap the parameter value with quotes if applicable
    ' Parameters:  prm As ADODB.Parameter
    ' Returns:     String - the parameter text with or without quotation wrappers
    '-------------------------------------------------------
     Dim strText As String

        If IsNull(prm.Value) Then
            strText = "NULL"
        ElseIf IsDate(prm.Value) Then
            strText = "'" & prm.Value & "'"
        Else
            strText = prm.Value
        End If

        If prm.Value <> "NULL" Then
            If Quote(prm.Type) = True Then
                strText = "'" & RTrim(strText) & "'"
            End If
        End If
     WrapWithApos = RTrim(strText)
    End Function

    Private Function Quote(intPrmType As Integer) As Boolean
    '-------------------------------------------------------
    ' Name:        Quote
    ' Description: This function determines if a ADO Command Object Parameter should
    '              be wrapped with quotes when it is converted to a SQL string or not
    ' Parameters:  Parameter Type as integer
    ' Returns:     Boolean
    '               True - this is a string param and should be wrapped with quotes
    '               False - this is a numeric param and should not
    '-------------------------------------------------------
     Dim bolVarQuote As Boolean

        Select Case intPrmType
            Case Is = adNumeric
            Case Is = adVarBinary
            Case Is = adUnsignedTinyInt
            Case Is = adSmallInt
            Case Is = adBoolean
            Case Is = adSingle
            Case Is = adCurrency
            Case Is = adInteger
            Case Is = adDouble
            Case Is = adBinary
            Case Is = adVarBinary
            Case Is = adLongVarBinary

            Case Is = adLongVarWChar
                bolVarQuote = True
            Case Is = adVarChar
                bolVarQuote = True
            Case Is = adWChar
                bolVarQuote = True
            Case Is = adDBTimeStamp
                bolVarQuote = True
            Case Else
                bolVarQuote = True
            End Select
        Quote = bolVarQuote
    End Function

    Tuesday, May 8, 2007 9:25 AM
  • Thanks m8 for starting a new thread, i also felt that a new thread was required Smile

    Also nice code to start off with a new thread Smile
    Wednesday, May 9, 2007 9:15 AM
  • How to draw spiral in VB

    Using a loop and the mathematical formula for a spiral, you can use
    pset(x,y)
    to plot the points returned by the formulas. The variables
    a and b determine the shape of the spiral. Generally, smaller numbers
    mean a tighter spiral. The following code shows an exponential spiral
    wherein the distance from the origin increases drastically with each
    rotation:

    Option Explicit
    Private Const Pi As Double = 3.14159265358979
    Private Const e As Double = 2.718281828

    Private Sub cmdDraw_Click()
    Dim cX As Long, X As Long
    Dim cy As Long, Y As Long
    'get the center of the form.
    cX = Me.ScaleWidth / 2
    cy = Me.ScaleHeight / 2
    a = 0.15
    b = 0.15

    'loop round to plot the points of the spiral.
    For i = 0 To 23040
    ang = (Pi / 720) * i
    X = cX + (a * (Cos(ang)) * (e ^ (b * ang)))
    Y = cy - (a * (Sin(ang)) * (e ^ (b * ang)))
    Me.PSet (X, Y)
    Next i


    End Sub

    Private Sub Form_Load()
    'set the form up.
    Me.ScaleMode = vbPixels
    Me.AutoRedraw = True
    Me.WindowState = vbMaximized

    End Sub

    Thursday, May 10, 2007 12:53 AM

  • Code 41 : Shell out to default web browser
    Declarations

    'used for shelling out to the default web browser
    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
    Public Const conSwNormal = 1




    Code 41 : Shell out to default web browser

    ShellExecute hwnd, "open", "http://www.google.com", vbNullString, vbNullString, conSwNormal



    Sunday, May 20, 2007 8:22 AM

  • Code 42 : Determine if a computer is connected to the Internet

    Declarations

    Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
    Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
    '
    Public Const RAS95_MaxEntryName = 256
    Public Const RAS95_MaxDeviceType = 16
    Public Const RAS95_MaxDeviceName = 32
    '
    Public Type RASCONN95
        dwSize As Long
        hRasCon As Long
        szEntryName(RAS95_MaxEntryName) As Byte
        szDeviceType(RAS95_MaxDeviceType) As Byte
        szDeviceName(RAS95_MaxDeviceName) As Byte
    End Type
    '
    Public Type RASCONNSTATUS95
        dwSize As Long
        RasConnState As Long
        dwError As Long
        szDeviceType(RAS95_MaxDeviceType) As Byte
        szDeviceName(RAS95_MaxDeviceName) As Byte
    End Type




    Code 42 : Determine if a computer is connected to the Internet

    Code

    'A call to the function IsConnected returns true if the computer has established a connection to the internet.

    Public Function IsConnected() As Boolean
    Dim TRasCon(255) As RASCONN95
    Dim lg As Long
    Dim lpcon As Long
    Dim RetVal As Long
    Dim Tstatus As RASCONNSTATUS95
    '
    TRasCon(0).dwSize = 412
    lg = 256 * TRasCon(0).dwSize
    '
    RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)
    If RetVal <> 0 Then
                        MsgBox "ERROR"
                        Exit Function
                        End If
    '
    Tstatus.dwSize = 160
    RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)
    If Tstatus.RasConnState = &H2000 Then
                             IsConnected = True
                             Else
                             IsConnected = False
                             End If

    End Function



    Sunday, May 20, 2007 8:24 AM

  • Code 43 : Launch default mail program to send an email message

    Declarations

    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




    Code 43 : Launch default mail program to send an email message

    Code

        ShellExecute hwnd, "open", "mailto:sanket.shah@rediffmail.com", vbNullString, vbNullString, SW_SHOW



    Sunday, May 20, 2007 8:28 AM

  • Code 44 : Create an Internet shortcut

    'Call the CreateInternetShortCut function to create a shortcut. 
    'Here is an example...   
    CreateInternetShortCut "C:\windows\desktop\test.url", "http://www.google.com"

    Sub CreateInternetShortCut(URLFile As String, URLTarget As String)

    'An Internet Shortcut takes on the form of
    '   [InternetShortcut]
    '   URL=http://sanket.textilestudies.com  

        Dim intFreeFile As Integer

        'get free file number
        intFreeFile = FreeFile
       
        'print the URL file
        Open URLFile For Output As intFreeFile
        Print #intFreeFile, "[InternetShortcut]"
        Print #intFreeFile, "URL=" & URLTarget
        Close intFreeFile
       
    End Sub

    Sunday, May 20, 2007 8:34 AM

  • Code 45 : Dial Internet using Dial Up Networking (DUN) to connect

    Declarations

    Const Internet_Autodial_Force_Unattended As Long = 2

    Public Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
    Public Declare Function InternetAutodialHangup Lib "wininet.dll" (ByVal dwReserved As Long) As Long




    Code 45 : Dial Internet using Dial Up Networking (DUN) to connect

    Code

    Dim lResult As Long
    lResult = InternetAutodial(Internet_Autodial_Force_Unattended, 0&)



    Sunday, May 20, 2007 8:36 AM

  • Code 46 : Close dial-up internet connection
    Declarations

    Const Internet_Autodial_Force_Unattended As Long = 2

    Public Declare Function InternetAutodial Lib "wininet.dll" (ByVal dwFlags As Long, ByVal dwReserved As Long) As Long
    Public Declare Function InternetAutodialHangup Lib "wininet.dll" (ByVal dwReserved As Long) As Long




    Code 46 : Close dial-up internet connection
    Code

    Dim lResult As Long
    lResult = InternetAutodialHangup(0&)


    Sunday, May 20, 2007 8:38 AM

  • Code 47 : Send Mail from Visual Basic Using OLE Messaging

    ' 1) Open a new project in Visual Basic.
    ' 2) On the Tools menu, choose References and select the Microsoft CDO 1.21 Library.
    ' 3) Add a CommandButton to the default form. Accept the default name, Command1.
    ' 4) Copy the following code into the General Declarations section of the default form:


    Option Explicit


    Private Sub Command1_Click()
      Dim objSession As Object
      Dim objMessage As Object
      Dim objRecipient As Object


      'Create the Session Object
      Set objSession = CreateObject("mapi.session")


      'Logon using the session object
      'Specify a valid profile name if you want to
      'Avoid the logon dialog box
      objSession.Logon profileName:="MS Exchange Settings"


      'Add a new message object to the OutBox
      Set objMessage = objSession.Outbox.Messages.Add


      'Set the properties of the message object
      objMessage.subject = "This is a test."
      objMessage.Text = "This is the message text."


      'Add a recipient object to the objMessage.Recipients collection
      Set objRecipient = objMessage.Recipients.Add


      'Set the properties of the recipient object
      objRecipient.Name = "sanket.shah@rediffmail.com"  '<---Replace this with a valid
                                      'display name or e-mail alias
      objRecipient.Type = mapiTo
      objRecipient.Resolve

      'Send the message
      objMessage.Send showDialog:=False
      MsgBox "Message sent successfully!"

      'Logoff using the session object
      objSession.Logoff
    End Sub


    Sunday, May 20, 2007 8:41 AM

  • Code 48 : How to ping an IP address using VB

    '1) Place a command button on the form and place this code in the Click event
       Dim ECHO As ICMP_ECHO_REPLY
       Dim pos As Integer
      
      'ping an ip address, passing the
      'address and the ECHO structure
       Call Ping("202.54.10.2", ECHO)
      
      'display the results from the ECHO structure
       Form1.Print GetStatusCode(ECHO.status)
       Form1.Print ECHO.Address
       Form1.Print ECHO.RoundTripTime & " ms"
       Form1.Print ECHO.DataSize & " bytes"
      
       If Left$(ECHO.Data, 1) <> Chr$(0) Then
          pos = InStr(ECHO.Data, Chr$(0))
          Form1.Print Left$(ECHO.Data, pos - 1)
       End If

       Form1.Print ECHO.DataPointer

    '2) Add a .BAS module and paste this code in that module
    '3) Click the command button
    Option Explicit

    Public Const IP_STATUS_BASE = 11000
    Public Const IP_SUCCESS = 0
    Public Const IP_BUF_TOO_SMALL = (11000 + 1)
    Public Const IP_DEST_NET_UNREACHABLE = (11000 + 2)
    Public Const IP_DEST_HOST_UNREACHABLE = (11000 + 3)
    Public Const IP_DEST_PROT_UNREACHABLE = (11000 + 4)
    Public Const IP_DEST_PORT_UNREACHABLE = (11000 + 5)
    Public Const IP_NO_RESOURCES = (11000 + 6)
    Public Const IP_BAD_OPTION = (11000 + 7)
    Public Const IP_HW_ERROR = (11000 + 8)
    Public Const IP_PACKET_TOO_BIG = (11000 + 9)
    Public Const IP_REQ_TIMED_OUT = (11000 + 10)
    Public Const IP_BAD_REQ = (11000 + 11)
    Public Const IP_BAD_ROUTE = (11000 + 12)
    Public Const IP_TTL_EXPIRED_TRANSIT = (11000 + 13)
    Public Const IP_TTL_EXPIRED_REASSEM = (11000 + 14)
    Public Const IP_PARAM_PROBLEM = (11000 + 15)
    Public Const IP_SOURCE_QUENCH = (11000 + 16)
    Public Const IP_OPTION_TOO_BIG = (11000 + 17)
    Public Const IP_BAD_DESTINATION = (11000 + 18)
    Public Const IP_ADDR_DELETED = (11000 + 19)
    Public Const IP_SPEC_MTU_CHANGE = (11000 + 20)
    Public Const IP_MTU_CHANGE = (11000 + 21)
    Public Const IP_UNLOAD = (11000 + 22)
    Public Const IP_ADDR_ADDED = (11000 + 23)
    Public Const IP_GENERAL_FAILURE = (11000 + 50)
    Public Const MAX_IP_STATUS = 11000 + 50
    Public Const IP_PENDING = (11000 + 255)
    Public Const PING_TIMEOUT = 200
    Public Const WS_VERSION_REQD = &H101
    Public Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
    Public Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
    Public Const MIN_SOCKETS_REQD = 1
    Public Const SOCKET_ERROR = -1

    Public Const MAX_WSADescription = 256
    Public Const MAX_WSASYSStatus = 128

    Public Type ICMP_OPTIONS
        Ttl             As Byte
        Tos             As Byte
        Flags           As Byte
        OptionsSize     As Byte
        OptionsData     As Long
    End Type

    Dim ICMPOPT As ICMP_OPTIONS

    Public Type ICMP_ECHO_REPLY
        Address         As Long
        status          As Long
        RoundTripTime   As Long
        DataSize        As Integer
        Reserved        As Integer
        DataPointer     As Long
        Options         As ICMP_OPTIONS
        Data            As String * 250
    End Type

    Public Type HOSTENT
        hName As Long
        hAliases As Long
        hAddrType As Integer
        hLen As Integer
        hAddrList As Long
    End Type

    Public Type WSADATA
        wVersion As Integer
        wHighVersion As Integer
        szDescription(0 To MAX_WSADescription) As Byte
        szSystemStatus(0 To MAX_WSASYSStatus) As Byte
        wMaxSockets As Integer
        wMaxUDPDG As Integer
        dwVendorInfo As Long
    End Type


    Public Declare Function IcmpCreateFile Lib "icmp.dll" () As Long

    Public Declare Function IcmpCloseHandle Lib "icmp.dll" _
       (ByVal IcmpHandle As Long) As Long
      
    Public Declare Function IcmpSendEcho Lib "icmp.dll" _
       (ByVal IcmpHandle As Long, _
        ByVal DestinationAddress As Long, _
        ByVal RequestData As String, _
        ByVal RequestSize As Integer, _
        ByVal RequestOptions As Long, _
        ReplyBuffer As ICMP_ECHO_REPLY, _
        ByVal ReplySize As Long, _
        ByVal Timeout As Long) As Long
       
    Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long

    Public Declare Function WSAStartup Lib "WSOCK32.DLL" _
       (ByVal wVersionRequired As Long, _
        lpWSADATA As WSADATA) As Long
       
    Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long

    Public Declare Function gethostname Lib "WSOCK32.DLL" _
       (ByVal szHost As String, _
        ByVal dwHostLen As Long) As Long
       
    Public Declare Function gethostbyname Lib "WSOCK32.DLL" _
       (ByVal szHost As String) As Long
      
    Public Declare Sub RtlMoveMemory Lib "kernel32" _
       (hpvDest As Any, _
        ByVal hpvSource As Long, _
        ByVal cbCopy As Long)


    Public Function GetStatusCode(status As Long) As String

       Dim msg As String

       Select Case status
          Case IP_SUCCESS:               msg = "ip success"
          Case IP_BUF_TOO_SMALL:         msg = "ip buf too_small"
          Case IP_DEST_NET_UNREACHABLE:  msg = "ip dest net unreachable"
          Case IP_DEST_HOST_UNREACHABLE: msg = "ip dest host unreachable"
          Case IP_DEST_PROT_UNREACHABLE: msg = "ip dest prot unreachable"
          Case IP_DEST_PORT_UNREACHABLE: msg = "ip dest port unreachable"
          Case IP_NO_RESOURCES:          msg = "ip no resources"
          Case IP_BAD_OPTION:            msg = "ip bad option"
          Case IP_HW_ERROR:              msg = "ip hw_error"
          Case IP_PACKET_TOO_BIG:        msg = "ip packet too_big"
          Case IP_REQ_TIMED_OUT:         msg = "ip req timed out"
          Case IP_BAD_REQ:               msg = "ip bad req"
          Case IP_BAD_ROUTE:             msg = "ip bad route"
          Case IP_TTL_EXPIRED_TRANSIT:   msg = "ip ttl expired transit"
          Case IP_TTL_EXPIRED_REASSEM:   msg = "ip ttl expired reassem"
          Case IP_PARAM_PROBLEM:         msg = "ip param_problem"
          Case IP_SOURCE_QUENCH:         msg = "ip source quench"
          Case IP_OPTION_TOO_BIG:        msg = "ip option too_big"
          Case IP_BAD_DESTINATION:       msg = "ip bad destination"
          Case IP_ADDR_DELETED:          msg = "ip addr deleted"
          Case IP_SPEC_MTU_CHANGE:       msg = "ip spec mtu change"
          Case IP_MTU_CHANGE:            msg = "ip mtu_change"
          Case IP_UNLOAD:                msg = "ip unload"
          Case IP_ADDR_ADDED:            msg = "ip addr added"
          Case IP_GENERAL_FAILURE:       msg = "ip general failure"
          Case IP_PENDING:               msg = "ip pending"
          Case PING_TIMEOUT:             msg = "ping timeout"
          Case Else:                     msg = "unknown  msg returned"
       End Select
      
       GetStatusCode = CStr(status) & "   [ " & msg & " ]"
      
    End Function


    Public Function HiByte(ByVal wParam As Integer)

        HiByte = wParam \ &H100 And &HFF&

    End Function


    Public Function LoByte(ByVal wParam As Integer)

        LoByte = wParam And &HFF&

    End Function


    Public Function Ping(szAddress As String, ECHO As ICMP_ECHO_REPLY) As Long

       Dim hPort As Long
       Dim dwAddress As Long
       Dim sDataToSend As String
       Dim iOpt As Long
      
       sDataToSend = "Echo This"
       dwAddress = AddressStringToLong(szAddress)
      
       Call SocketsInitialize
       hPort = IcmpCreateFile()
      
       If IcmpSendEcho(hPort, _
                       dwAddress, _
                       sDataToSend, _
                       Len(sDataToSend), _
                       0, _
                       ECHO, _
                       Len(ECHO), _
                       PING_TIMEOUT) Then
      
            'the ping succeeded,
            '.Status will be 0
            '.RoundTripTime is the time in ms for
            '               the ping to complete,
            '.Data is the data returned (NULL terminated)
            '.Address is the Ip address that actually replied
            '.DataSize is the size of the string in .Data
             Ping = ECHO.RoundTripTime
       Else: Ping = ECHO.status * -1
       End If
                          
       Call IcmpCloseHandle(hPort)
       Call SocketsCleanup
      
    End Function
      

    Function AddressStringToLong(ByVal tmp As String) As Long

       Dim i As Integer
       Dim parts(1 To 4) As String
      
       i = 0
      
      'we have to extract each part of the
      '123.456.789.123 string, delimited by
      'a period
       While InStr(tmp, ".") > 0
          i = i + 1
          parts(i) = Mid(tmp, 1, InStr(tmp, ".") - 1)
          tmp = Mid(tmp, InStr(tmp, ".") + 1)
       Wend
      
       i = i + 1
       parts(i) = tmp
      
       If i <> 4 Then
          AddressStringToLong = 0
          Exit Function
       End If
      
      'build the long value out of the
      'hex of the extracted strings
       AddressStringToLong = Val("&H" & Right("00" & Hex(parts(4)), 2) & _
                             Right("00" & Hex(parts(3)), 2) & _
                             Right("00" & Hex(parts(2)), 2) & _
                             Right("00" & Hex(parts(1)), 2))
      
    End Function


    Public Function SocketsCleanup() As Boolean

        Dim X As Long
       
        X = WSACleanup()
       
        If X <> 0 Then
            MsgBox "Windows Sockets error " & Trim$(Str$(X)) & _
                   " occurred in Cleanup.", vbExclamation
            SocketsCleanup = False
        Else
            SocketsCleanup = True
        End If
       
    End Function


    Public Function SocketsInitialize() As Boolean

        Dim WSAD As WSADATA
        Dim X As Integer
        Dim szLoByte As String, szHiByte As String, szBuf As String
       
        X = WSAStartup(WS_VERSION_REQD, WSAD)
       
        If X <> 0 Then
            MsgBox "Windows Sockets for 32 bit Windows " & _
                   "environments is not successfully responding."
            SocketsInitialize = False
            Exit Function
        End If
       
        If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
           (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
            HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
           
            szHiByte = Trim$(Str$(HiByte(WSAD.wVersion)))
            szLoByte = Trim$(Str$(LoByte(WSAD.wVersion)))
            szBuf = "Windows Sockets Version " & szLoByte & "." & szHiByte
            szBuf = szBuf & " is not supported by Windows " & _
                              "Sockets for 32 bit Windows environments."
            MsgBox szBuf, vbExclamation
            SocketsInitialize = False
            Exit Function
           
        End If
       
        If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
            szBuf = "This application requires a minimum of " & _
                     Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
            MsgBox szBuf, vbExclamation
            SocketsInitialize = False
            Exit Function
        End If
       
        SocketsInitialize = True
           
    End Function

    Sunday, May 20, 2007 8:46 AM

  • Code 49 : Add Images to Menu Items (Along with the Text)

    Declarations

    Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
    Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
    Public Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
    Public Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long

    Public Const MF_BITMAP = &H4




    Code 49 : Add Images to Menu Items (Along with the Text)

    Public Sub AddImageToMenuItem(hMenu As Long, lSubMenuPos As Long, lMenuItemPos As Long, _
                                  imlImageList As ImageList, lImagePos As Long)
    ' Add the selected bitmap to the given menu item.
    '
    ' hMenu - the menu handle for the menu you want to modify.
    ' lSubMenuPos - the position of the submenu (0 based).
    ' lMenuItemPos - the position of the menu item (0 based).
    ' imlImageList - the imagelist from which you will get the images.
    ' lImagePos - the position in the image list where the image is stored.
        Dim hSubMenu As Long
        Dim lMenuID As Long
        Dim lRet As Long
     
        On Error GoTo AddImageToMenuItem_Error
     
        ' Get the submenu handle.
        hSubMenu = GetSubMenu(hMenu, lSubMenuPos)
     
        ' Get the menu item id.
        lMenuID = GetMenuItemID(hSubMenu, lMenuItemPos)
       
        ' Make the call that puts the Bitmap in.
        lRet = SetMenuItemBitmaps(hMenu, lMenuID, MF_BITMAP, imlImageList.ListImages(lImagePos).Picture, imlImageList.ListImages(lImagePos).Picture)
     
        Exit Sub
     
    AddImageToMenuItem_Error:
       ' Appropriate error handling.
    End Sub




    Private Sub AddMenuBitmapsPrototype()
        Dim hMenu As Long
       
        hMenu = GetMenu(Me.hwnd)
       
        Call AddImageToMenuItem(hMenu, 0, 0, imlMainToolBarImageList, 1)
    End Sub


    Images should be 13x13 or smaller to fit properly into the menu.
    This takes images from an ImageList control, but, of course, you can modify
    this to use any control that has a Picture property.
    Can be modified to take a Key instead of a position for the images in the ImageList.



    Sunday, May 20, 2007 8:48 AM

  • Code 50 : Turns on Cap's Lock through your program

    Sub CapsON ()
    Call SetKeyboardState(VbKeyCaps)
    End sub

    Sunday, May 20, 2007 8:49 AM

  • Code 51 : Automatically calls up Dial Up Networking and "Clicks" Connect

    'Place the following code under a command button or in a menu, etc...

    Dim X
    '"TATA Broadband" is the name under the icon in Dial-up Networking
    X = Shell("rundll32.exe rnaui.dll,RnaDial " & "TATA Broadband", 1)
    DoEvents
    'You can type in your password before the { below.
    SendKeys "{enter}", True
    DoEvents
    'End Sub

    Sunday, May 20, 2007 8:51 AM

  • Code 52 : Find IP address ginving the hostname

    Declarations


    'Here's sample code for gethostbyname()

    'Add a textbox (Text1) And a Command button (Command1) To a New form And use the following code:

    'Usage: Fill in the textbox with the name you want to resolve and click the command button to resolve the name.

    Private Const WS_VERSION_REQD = &H101
    Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
    Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
    Private Const MIN_SOCKETS_REQD = 1
    Private Const SOCKET_ERROR = -1
    Private Const WSADescription_Len = 256
    Private Const WSASYS_Status_Len = 128

    Private Type HOSTENT
       hName As Long
       hAliases As Long
       hAddrType As Integer
       hLength As Integer
       hAddrList As Long
    End Type

    Private Type WSADATA
       wversion As Integer
       wHighVersion As Integer
       szDescription(0 To WSADescription_Len) As Byte
       szSystemStatus(0 To WSASYS_Status_Len) As Byte
       iMaxSockets As Integer
       iMaxUdpDg As Integer
       lpszVendorInfo As Long
    End Type

    Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
    Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired&, lpWSAData As WSADATA) As Long
    Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
    Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname$) As Long
    Private Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)





    Code 52 : Find IP address ginving the hostname

    Code


    Function hibyte(ByVal wParam As Integer)
      
       hibyte = wParam \ &H100 And &HFF&
      
    End Function

    Function lobyte(ByVal wParam As Integer)
      
       lobyte = wParam And &HFF&
      
    End Function

    Sub SocketsInitialize()
      
       Dim WSAD As WSADATA
       Dim iReturn As Integer
       Dim sLowByte As String, sHighByte As String, sMsg As String
      
       iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
      
       If iReturn <> 0 Then
          MsgBox "Winsock.dll is not responding."
          End
       End If
      
       If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then
          sHighByte = Trim$(Str$(hibyte(WSAD.wversion)))
          sLowByte = Trim$(Str$(lobyte(WSAD.wversion)))
          sMsg = "Windows Sockets version " & sLowByte & "." & sHighByte
          sMsg = sMsg & " is not supported by winsock.dll "
          MsgBox sMsg
          End
       End If
      
       If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
          sMsg = "This application requires a minimum of "
          sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
          MsgBox sMsg
          End
       End If
      
    End Sub

    Sub SocketsCleanup()
       Dim lReturn As Long
      
       lReturn = WSACleanup()
      
       If lReturn <> 0 Then
          MsgBox "Socket error " & Trim$(Str$(lReturn)) & " occurred in Cleanup "
          End
       End If
      
    End Sub

    Sub Form_Load()
      
       SocketsInitialize
      
    End Sub

    Private Sub Form_Unload(Cancel As Integer)
      
       SocketsCleanup
      
    End Sub

    Private Sub Command1_click()
       Dim hostent_addr As Long
       Dim host As HOSTENT
       Dim hostip_addr As Long
       Dim temp_ip_address() As Byte
       Dim i As Integer
       Dim ip_address As String
      
       hostent_addr = gethostbyname(Text1)
      
       If hostent_addr = 0 Then
          MsgBox "Can't resolve name."
          Exit Sub
       End If
      
       RtlMoveMemory host, hostent_addr, LenB(host)
       RtlMoveMemory hostip_addr, host.hAddrList, 4
      
       ReDim temp_ip_address(1 To host.hLength)
       RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
      
       For i = 1 To host.hLength
          ip_address = ip_address & temp_ip_address(i) & "."
       Next
       ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
      
       MsgBox ip_address
      
    End Sub




    Sunday, May 20, 2007 8:53 AM

  • Code 53 : SMTP Mail Program

    'you MUST put the Winsock1 control on your form
    'and this will work VERY quickly!!

    Dim Response As String, Reply As Integer, DateNow As String
    Dim first As String, Second As String, Third As String
    Dim Fourth As String, Fifth As String, Sixth As String
    Dim Seventh As String, Eighth As String
    Dim Start As Single, Tmr As Single



    Sub SendEmail(MailServerName As String, FromName As String, FromEmailAddress As String, ToName As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String)
              
        Winsock1.LocalPort = 0 ' Must set local port to 0 (Zero) or you can only send 1 e-mail pre program start
        
    If Winsock1.State = sckClosed Then ' Check to see if socet is closed
        DateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600"
        first = "mail from:" + Chr(32) + FromEmailAddress + vbCrLf ' Get who's sending E-Mail address
        Second = "rcpt to:" + Chr(32) + ToEmailAddress + vbCrLf ' Get who mail is going to
        Third = "Date:" + Chr(32) + DateNow + vbCrLf ' Date when being sent
        Fourth = "From:" + Chr(32) + FromName + vbCrLf ' Who's Sending
        Fifth = "To:" + Chr(32) + ToNametxt + vbCrLf ' Who it going to
        Sixth = "Subject:" + Chr(32) + EmailSubject + vbCrLf ' Subject of E-Mail
        Seventh = EmailBodyOfMessage + vbCrLf ' E-mail message body
        Ninth = "mouse mailer" + vbCrLf ' What program sent the e-mail, customize this
        Eighth = Fourth + Third + Ninth + Fifth + Sixth  ' Combine for proper SMTP sending

        Winsock1.Protocol = sckTCPProtocol ' Set protocol for sending
        Winsock1.RemoteHost = MailServerName ' Set the server address
        Winsock1.RemotePort = 25 ' Set the SMTP Port
        Winsock1.Connect ' Start connection
        
        WaitFor ("220")
        
        StatusTxt.Caption = "Connecting...."
        StatusTxt.Refresh
        
        Winsock1.SendData ("HELO worldcomputers.com" + vbCrLf)

        WaitFor ("250")

        StatusTxt.Caption = "Connected"
        StatusTxt.Refresh

        Winsock1.SendData (first)

        StatusTxt.Caption = "Sending Message"
        StatusTxt.Refresh

        WaitFor ("250")

        Winsock1.SendData (Second)

        WaitFor ("250")

        Winsock1.SendData ("data" + vbCrLf)
        
        WaitFor ("354")


        Winsock1.SendData (Eighth + vbCrLf)
        Winsock1.SendData (Seventh + vbCrLf)
        Winsock1.SendData ("." + vbCrLf)

        WaitFor ("250")

        Winsock1.SendData ("quit" + vbCrLf)
        
        StatusTxt.Caption = "Disconnecting"
        StatusTxt.Refresh

        WaitFor ("221")

        Winsock1.Close
    Else
        MsgBox (Str(Winsock1.State))
    End If
       
    End Sub
    Sub WaitFor(ResponseCode As String)
        Start = Timer ' Time event so won't get stuck in loop
        While Len(Response) = 0
            Tmr = Start - Timer
            DoEvents ' Let System keep checking for incoming response **IMPORTANT**
            If Tmr > 50 Then ' Time in seconds to wait
                MsgBox "SMTP service error, timed out while waiting for response", 64, MsgTitle
                Exit Sub
            End If
        Wend
        While Left(Response, 3) <> ResponseCode
            DoEvents
            If Tmr > 50 Then
                MsgBox "SMTP service error, impromper response code. Code should have been: " + ResponseCode + " Code recieved: " + Response, 64, MsgTitle
                Exit Sub
            End If
        Wend
    Response = "" ' Sent response code to blank **IMPORTANT**
    End Sub


    Private Sub Command1_Click()
        SendEmail txtEmailServer.Text, txtFromName.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtToEmailAddress.Text, txtEmailSubject.Text, txtEmailBodyOfMessage.Text
        'MsgBox ("Mail Sent")
        StatusTxt.Caption = "Mail Sent"
        StatusTxt.Refresh
        Beep
        
        Close
    End Sub

    Private Sub Command2_Click()
        
        End
        
    End Sub

    Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)

        Winsock1.GetData Response ' Check for incoming response *IMPORTANT*

    End Sub

    Sunday, May 20, 2007 9:04 AM

  • Code 54 : Retreve a web page's source through your program using The Inet OCX

    Function OpenUrl (URL)
    Dim P() as byte
    Dim T as string
    B = Inet1.OpenUrl(URL)
    For i = 1 to len(B)
    T = T + UBound(P(T))
    next i
    End function

    Sunday, May 20, 2007 9:06 AM

  • Code 55 : Use the Microsoft Internet Control to determine when a web page was last modified

    'set a reference to the Microsoft Internet Control and then use the code below.

        Dim strHeader As String
       
        'set protocol to HTTP
        Inet1.Protocol = icHTTP
       
        'open URL
        Inet1.OpenURL ("http://www.microsoft.com")
       
        ' Retrieve the date page was last modified
        strHeader = Inet1.GetHeader("Last-modified")
       
        MsgBox strHeader

    Sunday, May 20, 2007 9:07 AM

  • Code 56 : This function returns any of the various components of the URL that are present

    Declarations

    Public Type typURL 'http://sit:sitter@proxy.spiderit.net:881/prox/proxycfg.php3?openpage
        Protocol    As String   'contains the protocol if specified (e.g. http://, ftp:// etc.)
        ServerName  As String   'contains the servername (e.g. proxy.spiderit.net)
        Filename    As String   'contains the filename (e.g. proxycfg.php3)
        Dir         As String   'contains the directory (e.g. /prox/)
        Filepath    As String   'contains the whole filepath (e.g. /prox/proxycfg.php3)
        Username    As String   'contains the username (e.g. sit)
        Password    As String   'contains the password (e.g. sitter)
        Query       As String   'contains the querystring (e.g. openpage)
        ServerPort  As Integer  'contains the serverport (e.g. 881)
    End Type

    Public Const strNOCONTENT As String = "NOCONTENT"
    Public Const intDEFAULTPORT As Integer = 80

    Function ParseURL(URL As String) As typURL
    Dim strTemp As String
    Dim strServerAuth As String
    Dim strServerNPort As String
    Dim strAuth As String


    strTemp = URL

    '********
    '- Parse protocol
    If (InStr(1, strTemp, "://") > 0) Then
        'URL contains protocol
        ParseURL.Protocol = Left(strTemp, InStr(1, strTemp, "://") - 1)
        strTemp = Right(strTemp, Len(strTemp) - (Len(ParseURL.Protocol) + 3)) 'delete protocol + ://
    Else
        'URL do not contains the protocol
        ParseURL.Protocol = strNOCONTENT
    End If

    '********
    '- Parse authenticate information
    If (InStr(1, strTemp, "/") > 0) Then
        'extract servername and user and password if there are directory infos
        strServerAuth = Left(strTemp, InStr(1, strTemp, "/") - 1)
        strTemp = Right(strTemp, Len(strTemp) - (Len(strServerAuth) + 1))
    Else
        'extract servername and user and password if there are no directory infos
        strServerAuth = strTemp
        strTemp = "/"
    End If

    If (InStr(1, strServerAuth, "@") > 0) Then
        'there are user and password informations
        strAuth = Left(strServerAuth, InStr(1, strServerAuth, "@") - 1)
        strServerNPort = Right(strServerAuth, Len(strServerAuth) - (Len(strAuth) + 1))
    Else
        'there are no user and password informations
        strAuth = ""
        strServerNPort = strServerAuth
    End If

    If (InStr(1, strAuth, ":") > 0) And (Len(strAuth) > 0) Then
        'split username and password on ":" splitter
        ParseURL.Username = Left(strAuth, InStr(1, strAuth, ":") - 1)
        ParseURL.Password = Right(strAuth, Len(strAuth) - InStr(1, strAuth, ":"))
    ElseIf (InStr(1, strAuth, ":") <= 0) And (Len(strAuth) > 0) Then
        'only username was submitted
        ParseURL.Username = strAuth
        ParseURL.Password = strNOCONTENT
    Else
        'no authenticate information was submitted
        ParseURL.Username = strNOCONTENT
        ParseURL.Password = strNOCONTENT
    End If

    If (InStr(1, strServerNPort, ":") > 0) Then
        'Servername contains port
        ParseURL.ServerPort = Int(Right(strServerNPort, Len(strServerNPort) - InStr(1, strServerNPort, ":")))
        ParseURL.ServerName = Left(strServerNPort, InStr(1, strServerNPort, ":") - 1)
    Else
        ParseURL.ServerPort = intDEFAULTPORT
        ParseURL.ServerName = strServerNPort
    End If

    If (InStr(1, strTemp, "?") > 0) Then
        ParseURL.Query = Right(strTemp, Len(strTemp) - InStr(1, strTemp, "?"))
        strTemp = Left(strTemp, InStr(1, strTemp, "?") - 1)
    Else
        ParseURL.Query = strNOCONTENT
    End If

    For i = Len(strTemp) To 1 Step -1
        If (Mid(strTemp, i, 1) = "/") Then
            ParseURL.Filename = Right(strTemp, Len(strTemp) - i)
            ParseURL.Dir = Left(strTemp, i)
            If Not (Left(ParseURL.Dir, 1) = "/") Then
                ParseURL.Dir = "/" & ParseURL.Dir
            End If
            Exit For
        End If
    Next
       
    ParseURL.Filepath = "/" & strTemp
    If Not (Left(ParseURL.Filepath, 1) = "/") Then
        ParseURL.Filepath = "/" & ParseURL.Filepath
    End If

    End Function




    Code 56 : This function returns any of the various components of the URL that are present

    Code

    Private Sub Form_Load()
    Const strURL As String = "http://web:logon@intranet.q-tec.org:89/euro/rechner/euro.php3?startpage"
    msgtext = ParseURL(strURL).Protocol & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Username & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Password & vbCrLf
    msgtext = msgtext & ParseURL(strURL).ServerName & vbCrLf
    msgtext = msgtext & ParseURL(strURL).ServerPort & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Filepath & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Dir & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Filename & vbCrLf
    msgtext = msgtext & ParseURL(strURL).Query & vbCrLf
    MsgBox msgtext, vbInformation
    End Sub



    Sunday, May 20, 2007 9:19 AM

  • Code 57 : Gives the right URL after Download Complete

    Private Sub WebBrowser1_DownloadComplete()
    Combo2.Text = WebBrowser1.LocationURL
    End Sub

    Sunday, May 20, 2007 9:22 AM

  • Code 58 : Verify a given port

    Public Function VerifyPort (PortStr As String) As Boolean
    'Put this in a module, or change "Public" to
    '"Private" and put it in a form.

    Trim(PortStr)

    'If there's nothing in the box assume the
    'user has cleared it and return no errors.
    If Len(PortStr) = 0 Then
        VerifyPort = False
        Exit Function
    End If

    'Check to see if the string can be converted
    'to an integer.
    If IsNumeric(PortStr) = False Then
        MsgBox "Error: Integer values only.", vbInformation, "Error!"
        VerifyPort = False
        Exit Function
    End If

    'IsNumeric doesn't search for commas, so check
    'if the user entered a comma.
    For i = 1 To Len(PortStr)
        If InStr(i, PortStr, ",") Then
            MsgBox "Error: Integer values only.", vbInformation, "Error!"
            VerifyPort = False
            Exit Function
        End If
    Next i

    'If the port is or starts with a zero, return
    'an error.
    If Val(PortStr) = 0 Then
        MsgBox "Error: Ports 1 - 65535 Only.", vbInformation, "Error!"
        VerifyPort = False
        Exit Function
    End If
    If Left(PortStr, 1) = "0" Then
        MsgBox "Error: Ports 1 - 65535 Only.", vbInformation, "Error!"
        VerifyPort = False
        Exit Function
    End If

    'Check if the port exceeds the maximum range.
    If Val(txtRemotePort.Text) > 65535 Then
        MsgBox "Error: Ports 1 - 65535 only.", vbInformation, "Error!"
        txtLocalPort.Text = "65535"
        VerifyPort = False
        Exit Function
    End If

    VerifyPort = True
    End Function

    Sunday, May 20, 2007 9:23 AM

  • Code 59 : Gets the URL string from the ie browser edit window

    Declarations

    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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function SendMessageLong& Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
    Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
    Const WM_USER = &H400
    Const EM_LIMITTEXT = WM_USER + 21
    Private Const WM_GETTEXT = &HD
    Private Const WM_GETTEXTLENGTH = &HE
    Private Const EM_GETLINECOUNT = &HBA
    Private Const EM_LINEINDEX = &HBB
    Private Const EM_LINELENGTH = &HC1




    Code 59 : Gets the URL string from the ie browser edit window

    Code

    Private Sub GetURLstring_Click() 

     On Error GoTo CallErrorA
        Dim iPos As Integer
        Dim sClassName As String
        Dim GetAddressText As String
        Dim lhwnd As Long
        Dim WindowHandle As Long
       
       lhwnd = 0
       sClassName = ("IEFrame")
       lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
       sClassName = ("WorkerA")
       lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
       sClassName = ("ReBarWindow32")
       lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
       sClassName = ("ComboBoxEx32")
       lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
       sClassName = ("ComboBox")
       lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
       sClassName = ("Edit")
       lhwnd = FindWindowEx(lhwnd, 0, sClassName, vbNullString)
           
            WindowHandle& = lhwnd
            Dim buffer As String, TextLength As Long
            TextLength& = SendMessage(WindowHandle&, WM_GETTEXTLENGTH, 0&, 0&)
            buffer$ = String(TextLength&, 0&)
            Call SendMessageByString(WindowHandle&, WM_GETTEXT, TextLength& + 1, buffer$)
            MsgBox buffer$

       Exit Sub
    CallErrorA:
        MsgBox Err.Description
        Err.Clear

    End Sub



    Sunday, May 20, 2007 9:26 AM

  • Code 60 : Find Your Ip

    Code for .bas file

    Option Explicit

    Public Const MAX_WSADescription = 256
    Public Const MAX_WSASYSStatus = 128
    Public Const ERROR_SUCCESS       As Long = 0
    Public Const WS_VERSION_REQD     As Long = &H101
    Public Const WS_VERSION_MAJOR    As Long = WS_VERSION_REQD \ &H100 And &HFF&
    Public Const WS_VERSION_MINOR    As Long = WS_VERSION_REQD And &HFF&
    Public Const MIN_SOCKETS_REQD    As Long = 1
    Public Const SOCKET_ERROR        As Long = -1

    Public Type HOSTENT
       hName      As Long
       hAliases   As Long
       hAddrType  As Integer
       hLen       As Integer
       hAddrList  As Long
    End Type

    Public Type WSADATA
       wVersion      As Integer
       wHighVersion  As Integer
       szDescription(0 To MAX_WSADescription)   As Byte
       szSystemStatus(0 To MAX_WSASYSStatus)    As Byte
       wMaxSockets   As Integer
       wMaxUDPDG     As Integer
       dwVendorInfo  As Long
    End Type


    Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long

    Public Declare Function WSAStartup Lib "WSOCK32.DLL" _
       (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
       
    Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long

    Public Declare Function gethostname Lib "WSOCK32.DLL" _
       (ByVal szHost As String, ByVal dwHostLen As Long) As Long
       
    Public Declare Function gethostbyname Lib "WSOCK32.DLL" _
       (ByVal szHost As String) As Long
       
    Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
       (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
    Public Function GetIPAddress() As String

       Dim sHostName    As String * 256
       Dim lpHost    As Long
       Dim HOST      As HOSTENT
       Dim dwIPAddr  As Long
       Dim tmpIPAddr() As Byte
       Dim i         As Integer
       Dim sIPAddr  As String
       
       If Not SocketsInitialize() Then
          GetIPAddress = ""
          Exit Function
       End If
       If gethostname(sHostName, 256) = SOCKET_ERROR Then
          GetIPAddress = ""
          MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & _
                  " has occurred. Unable to successfully get Host Name."
          SocketsCleanup
          Exit Function
       End If
       sHostName = Trim$(sHostName)
       lpHost = gethostbyname(sHostName)
        
       If lpHost = 0 Then
          GetIPAddress = ""
          MsgBox "Windows Sockets are not responding. " & _
                  "Unable to successfully get Host Name."
          SocketsCleanup
          Exit Function
       End If
       CopyMemory HOST, lpHost, Len(HOST)
       CopyMemory dwIPAddr, HOST.hAddrList, 4
       ReDim tmpIPAddr(1 To HOST.hLen)
       CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
       For i = 1 To HOST.hLen
          sIPAddr = sIPAddr & tmpIPAddr(i) & "."
       Next
       GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
       
       SocketsCleanup
        
    End Function

    Public Function HiByte(ByVal wParam As Integer)

        HiByte = wParam \ &H100 And &HFF&
     
    End Function
    Public Function LoByte(ByVal wParam As Integer)

        LoByte = wParam And &HFF&

    End Function
    Public Sub SocketsCleanup()

        If WSACleanup() <> ERROR_SUCCESS Then
            MsgBox "Socket error occurred in Cleanup."
        End If
        
    End Sub

    Public Function SocketsInitialize() As Boolean

       Dim WSAD As WSADATA
       Dim sLoByte As String
       Dim sHiByte As String
       
       If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
          MsgBox "The 32-bit Windows Socket is not responding."
          SocketsInitialize = False
          Exit Function
       End If
       
       
       If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
            MsgBox "This application requires a minimum of " & _
                    CStr(MIN_SOCKETS_REQD) & " supported sockets."
            
            SocketsInitialize = False
            Exit Function
       End If
       
       
       If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
         (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
          HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
          
          sHiByte = CStr(HiByte(WSAD.wVersion))
          sLoByte = CStr(LoByte(WSAD.wVersion))
          
          MsgBox "Sockets version " & sLoByte & "." & sHiByte & _
                 " is not supported by 32-bit Windows Sockets."
          
          SocketsInitialize = False
          Exit Function
          
       End If
        SocketsInitialize = True
    End Function




    Code 60 : Find Your Ip

    Code

    Private Sub Form_Load()
       Text1.Text = GetIPAddress()
       If Text1.Text = "127.0.0.1" Then
    Label1.Caption = "You are of Line"
       Else
    Label1.Caption = "You are on Line"
       End If
    End Sub



    Sunday, May 20, 2007 9:29 AM

  • Code 61 : An alternate FTP method
    Sub PoorMansFTP

    Dim strTempDir As String
    Dim strTempFtpFile As String
    Dim strFileName As String
    Dim strSiteAddress As String
    Dim strUserName As String
    Dim strPassword As String
    Dim strRemoteDirectory As String

    strSiteAddress = "www.yourdomain.com"
    strUserName = "Username goes here"
    strPassword = "Password goes here or assigned in some other way"
    strRemoteDirectory = "upload directory, ie. wwwroot/path/path"

    strTempDir = Environ("Temp")
    If Len(strTempDir) = 0 Then strTempDir = "C:"
    strTempFtpFile = strTempDir & "\fdty.l34"
    strFileName = "C:\SomePath\SomeFileToUpload.xxx"



    '''Write FTP commands into a file
    Open strTempFtpFile For Output As #1

        Print #1, "open " & strSiteAddress
        Print #1, "user " & strUserName
        Print #1, strPassword   '''some servers may require "PW " & strPassword
                                '''but most automatically ask for it
        Print #1, "type binary"
        Print #1, "cd " & strRemoteDirectory
        Print #1, "put " & strHtmlFileName
        Print #1, "Quit"

    Close #1

    ''' call ftp.exe with -n parameter, which will supress the automatic feedback
    ''' from the server, and -s which contains the path to the file to use for
    ''' ftp commands.
    Call Shell("ftp -n -s:" & strTempFtpFile, vbHide)

    End Sub

    Sunday, May 20, 2007 9:32 AM

  • Code 62 : small code gets you IP address and Host name
    'Make 2 TextBoxes
    'Put this in Form load >>>>


    Text1.Text = Winsock1.LocalIP
    Text2.Text = Winsock1.LocalHostName


    Sunday, May 20, 2007 9:37 AM

  • Code 63 : WebBrowser > Opens New Window using your program
    'Microsoft IE/Shdocvw.dll needed
    Private Sub webbrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean)
        Dim F As New observe
        F.Show
        Set ppDisp = F.webbrowser1.object
    End Sub
    Sunday, May 20, 2007 9:39 AM

  • Code 64 : guaranteed way to view the source code of a webpage
    text1.text = webbrowser1.document.documentelement.innerhtml
    Sunday, May 20, 2007 9:42 AM

  • Code 65 : Adding Hyperlink Using the Label Control

    'add textbox(text1) and label(label1)
    'then add the following:

    Option Explicit


    Private Const clrLinkActive = vbBlue
    Private Const clrLinkHot = vbRed
    Private Const clrLinkInactive = vbBlack

    Private Const SW_SHOWNORMAL As Long = 1
    Private Const SW_SHOWMAXIMIZED As Long = 3
    Private Const SW_SHOWDEFAULT As Long = 10

    Private Type POINTAPI
       X As Long
       Y As Long
    End Type

    Private Declare Function GetCursorPos Lib "user32" _
      (lpPoint As POINTAPI) As Long

    Private Declare Function ScreenToClient Lib "user32" _
      (ByVal hwnd As Long, _
       lpPoint As POINTAPI) As Long

    Private Declare Function GetDesktopWindow Lib "user32" () As Long

    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 Sub Form_Load()

    Text1.Text = "http://www.google.com/"
    Label1.AutoSize = True
         
    End Sub


    Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    With Label1
    .ForeColor = clrLinkInactive
    .FontUnderline = False
    End With
    End Sub

    Private Sub label1_Click()

       Dim sURL As String

      'open the URL using the default browser
       sURL = Label1.Caption

       Call RunShellExecute("open", sURL, 0&, 0&, SW_SHOWNORMAL)
      
    End Sub


    Private Sub RunShellExecute(sTopic As String, sFile As Variant, _
                               sParams As Variant, sDirectory As Variant, _
                               nShowCmd As Long)

      'execute the passed operation, passing
      'the desktop as the window to receive
      'any error messages
       Call ShellExecute(GetDesktopWindow(), _
                         sTopic, _
                         sFile, _
                         sParams, _
                         sDirectory, _
                         nShowCmd)

    End Sub


    Private Sub Text1_Change()

      'reflect changes to the textbox
       Label1.Caption = Text1.Text

    End Sub


    Private Sub Text1_GotFocus()

       Dim pos As String
      
      'if the textbox has the URL double
      'slashes, select only the text after
      'them for editing convenience
       pos = InStr(Text1.Text, "//")
      
       If pos Then
      
          With Text1
             .SelStart = pos + 1
             .SelLength = Len(.Text)
          End With
         
       End If


    End Sub


    Private Sub label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
       
       With Label1
      
             .ForeColor = clrLinkActive
             .FontUnderline = True
      
       End With
      
    End Sub

    Sunday, May 20, 2007 9:45 AM

  • Code 66 : Setup a DSN-Less database in Active Server Pages

    'DBName.mdb is the name of your database

    <% conn.Open "driver={Microsoft Access Driver (*.mdb)}; dbq=c:\database\DBName.mdb;uid=Admin" %>

    Sunday, May 20, 2007 9:47 AM

  • Code 67 : Retrieve Server Variables
    <%
    For Each Item In Request.ServerVariables
    Response.Write Item & " - " & Request.ServerVariables(Item) & "<BR>"
    Next
    %>
    Sunday, May 20, 2007 9:51 AM

  • Code 68 : Loop through Submitted items that were POSTed from a form
    <%
    For Each Item in Request.Form
    Response.Write Item & " - " & Request(Item) & "<BR>"
    Next
    %>
    Sunday, May 20, 2007 9:54 AM

  • Code 69 : Populate a combo box with information from a database Code Snippet
    <BR>This is an HTML ListBox<BR>   
    <SELECT NAME="ListBox" SIZE=1>
    <% Set conn = Server.CreateObject("ADODB.Connection") %>
    <% conn.Open "DSN=AdvWorks"  ' connect to the database %>
    <% Set rs = conn.Execute("SELECT City FROM Customers") %>
    <% Do While Not rs.EOF  ' define the ListBox OPTIONs %>
    <OPTION VALUE="<%= rs("City") %>"> <%= rs("City") %>
    <% rs.MoveNext %>   
    <% Loop %>   
    <% rs.Close %>   
    <% conn.Close %>
    Sunday, May 20, 2007 9:56 AM

  • Code 70 : Lists all file within the current directoryCode Snippet
    <html>
    <head><title></title></head>
    <body>
    <%
      Dim fso, f, f1, fc, s
      Set fso = CreateObject("Scripting.FileSystemObject")
        TheFile = Server.MapPath(Request.ServerVariables("SCRIPT_NAME"))
        loc = InStrRev(TheFile,"\")
        TheFile = Left(TheFile,loc)
      Set f = fso.GetFolder(TheFile)
      Set fc = f.Files
      For Each f1 in fc
        'change the file extensions to view different files.
        if right(f1,5) = ".html" or right(f1,4) = ".htm" then
                s = s & "<A HREF='" & f1.name & "'>" & f1.name & "</A>"
            s = s &  "<BR>"
        End If
      Next
      ShowFileList = s

    %>
    <%
    response.write ShowFileList
    %>
    </body>
    </html>
    Sunday, May 20, 2007 9:58 AM

  • Code 71 : Using the Ad Rotator component from MicrsoftCode Snippet
    <%
    Set AdRotator = Server.CreateObject("MSWC.AdRotator")
    AdText = AdRotator.GetAdvertisement("/banners/ads.txt")
    BeginLoc = InStr(AdText, "<A")
    TELoc = InStr(BeginLoc + 3, AdText, " ")
    AdText = Left(AdText,TELoc) & "TARGET=NewWin " & Right(AdText,(Len(AdText)-TELoc))
    response.write AdText
    %>
    Sunday, May 20, 2007 9:59 AM

  • Code 72 : How to call a stored procedure from active server pagesCode Snippet
    <%@ language="VBScript"%>
    <% option explicit%>
    <!-- #include virtual="adovbs.inc"-->
    'Open the Connection
    set conn = Server.CreateObject("ADODB.Connection")
    conn.open "dsn=dsn;uid=username;pwd=password"
    'Now call the stored Procedure
    Set cmd=Server.CreateObject("ADODB.Command")
    set cmd.activeconnection=conn
    cmd.commandtext="Procedure_name"
       cmd.commandtype=adcmdStoredProc
       cmd.parameters.refresh
       cmd.parameters(1).value = Value1
       cmd.parameters(2).value = Value2
       .
       .
       cmd.parameters(n).value = Valuen
    'for the ouput from stored procdure
      cmd.execute
      returnvalue = cmd.parameters(0).value      
    ' and for resultset
      set rs = cmd.execute.
      conn.close

        


    Sunday, May 20, 2007 10:02 AM

  • Code 73 : Detecting Browser TypeCode Snippet
    <%
       Set MyBrowser=server.createobject("MSWC.Browsertype")
       response.write MyBrowser.Browser
    %>
    Sunday, May 20, 2007 10:04 AM

  • Code 74 : Populates a table with records returned from a databaseCode Snippet
    strConnectionString = "SystemDSN"    'I used a system DSN
    Set connection = Server.CreateObject("ADODB.Connection")
    connection.Open strConnectionString
    <html>

    <table border="1" cellpadding="4" cellspacing="3" width="598" bordercolorlight="#000080">


    <%Set RS = Server.CreateObject("ADODB.Recordset")

    strSQL = "SELECT * FROM tblYourTable WHERE field = whatever "
    RS.Open strSQL, connection
        %>
        <%While NOT RS.EOF%>
            <td width="129" align="center"><font face="Arial"><font size="2"><%=RS("field1")%></font></font></td>
            <td width="65" align="center"><font face="Arial"><font size="2"><%=RS("field2")%></font></font></td>
            <td width="79" align="center"><font face="Arial"><font size="2"><%=RS("field3")%></font></font></td>
            <td width="86" align="center"><font face="Arial"><font size="2"><%=RS("field4")%></font></font></td>
            <td width="72" align="center"><font face="Arial"><font size="2"><%=RS("field5")%></font></font></td>
            <td width="77" align="center"><font face="Arial"><font size="2"><%=RS("field6")%></font></font></td>
        </tr>
        <%RS.MoveNext
        Wend
        RS.Close
        %>
        
    </table>
    </html>

    Sunday, May 20, 2007 10:06 AM

  • Code 75 : When an error occurs on one of your ASP pages, this sub will email you a notification of that error and show the user friendly error page.
    <%@ TRANSACTION=Required %> ' You must have this line!


    <%
    '*******************************************************************************
    'This section traps errors and emails you a report of it and displays a user friendly error page.
    '*******************************************************************************

    sub OnTransactionAbort()
         response.clear
         response.write "An error was encountered processing your information."&"<br>"
         response.write "Please click the HOME button in your browser and try again."&"<br>"
         response.write "A notice of this error has been sent to the web administrators."&"<br>"
         response.write "Thank you for your patience."
         
         SET objMail=Server.CreateObject("CDONTS.Newmail")
         objMail.From    = "error@yourplace.com"
        objMail.To        = "webmaster@yourplace.com" 'your email address    
         objMail.Subject = "!!Error At Web Site!!"
         objMail.Body    = "On " & now() &_
            ", the following error was " &_
            "generated in page " &_
            Request.ServerVariables( "SCRIPT_NAME" ) &_
            ": " & vbnewline & vbnewline &_
            err.Description
         objMail.Importance = 2
         objMail.Send
         Set objMail = Nothing
    end sub %>

    Sunday, May 20, 2007 10:08 AM

  • Code 76 : Use Page Counter component to count how many times the current page was hit
    <%@ Language=VBScript %>
    <HTML>
    <HEAD>
    <TITLE>ASP 2.0 Demo - The Page Counter Component</TITLE>
    </HEAD>
    <BODY>
    <H2>ASP 2.0 Demo -The Page Counter Component</H2>
    <HR>
    This sample show how to use <B>Page Counter</B> component to count how many times the current page was hit. This component is implemented in file <B>PAGECNT.DLL</B>. Make sure you have it on your server and installed properly. You can use the Personal Web Server to test this ASP page.
    <P>
    <font color=blue>How to: Click the Refresh or Reload menu button to see the result ! </font>
    <HR>
    <P>
     <%
      Dim objPC
      Dim lngHitCount
      On Error Resume Next
      Set objPC=Server.CreateObject("IISSample.PageCounter")
      If IsObject(objPC)=False Then
        Response.Write "The Page Counter component object can not be created at this time. "
        Response.Write "Either you do not have this component on the server machine or it "
        Response.Write "is not installed properly."
        Response.Write "You may try to fix this problem by installing IIS Resource Kit."
      Else
        Response.Write "The Page Counter component object is created successfully !<P>"
        lngHitCount=objPC.PageHit()
        Response.Write("Number of times (reset one) this page was hit - ")   
        Response.Write cstr(lngHitCount)
        Response.Write("<BR>")
        If ((lngHitCount Mod 10)=0) Then
           Response.Write("<font color=red><P>You hit the lucky number.</font><BR>")
           If (lngHitCount>=100) Then    ' Reset count.
         objPC.Reset
             Response.Write("The page counter was reset every time it reaches 100 !")
           End If
        End If
      End If
      %>
    <P>
    </BODY>
    </HTML>

    Sunday, May 20, 2007 10:10 AM

  • Code 77 : MyInfo Component Sample
    <%@ Language=VBScript %>
    <HTML>
    <HEAD>
    <TITLE>ASP 2.0 Demo - The MyInfo Component </TITLE>
    </HEAD>
    <BODY>
    <H2>ASP 2.0 Demo - The MyInfo Component </H2>
    <HR>
    The <B>MyInfo Component</B> can be used to keep track of personal information, provided by the server administrator.
    <P>
    This component is implemented in <B>MYINFO.DLL.</B>
    <P>At the begining, you may have nothing in the MyInfo for some properties, but you can add your own and modify them.
    <P>
    <B><font color=blue>How to: You can click the Reload or Refresh menu button to see the result.</font></B>
    <HR>
    <P>
     <%
      Dim objMyInfo
      On Error Resume Next
      Set objMyInfo=Server.CreateObject("MSWC.MyInfo")
      If IsObject(objMyInfo)=False Then
        Response.Write "The MyInfo object can not be created on this machine. Either you do not "
        Response.Write "have this component on the server machine or it is not installed properly."
        Response.Write "You may try to fix this problem by installing IIS Resource Kit."
      Else
        Response.Write "The MyInfo object is created successfully !<P>"
        Response.Write "Before I change my info, I have following:<BR>"    
        Response.Write("<BR>My favorite color is - " + objMyInfo.FavoriteColor)
        Response.Write("<BR>My startdate is - " + objMyInfo.StartDate)
        Response.Write("<BR>My email address is - " + objMyInfo.Email)
        Response.Write("<BR>Last time MyInfo was reset is - " + objMyInfo.MyInfoReset)
        '
        ' Reset my info.
        If objMyInfo.FavoriteColor="blue" Then
          objMyInfo.FavoriteColor="purple"
        Else
          objMyInfo.FavoriteColor="blue"
        End if
        '
        If objMyInfo.StartDate="1/1/1999" Then
          objMyInfo.StartDate="1/1/2000"
        Else
          objMyInfo.StartDate="1/1/1999"
        End If
        '
        If objMyInfo.Email="sanket.1985@gmail.com" Then
          objMyInfo.Email="sanket.shah@rediffmail.com"
        Else
          objMyInfo.Email="sanket.shah@hotmail.com"
        End if
        '
        objMyInfo.MyInfoReset=Now
        '
        ' Display new values.
        Response.Write "<P>After I change my info, I have following:<BR>"    
        Response.Write("<BR>My new favorite color is - " + objMyInfo.FavoriteColor)
        Response.Write("<BR>My new startdate is - " + objMyInfo.StartDate)
        Response.Write("<BR>My new email address is - " + objMyInfo.Email)
      End if  
     %>
    <P>
    </BODY>
    </HTML>

    Sunday, May 20, 2007 10:13 AM

  • Code 78 : ASP sample of Registry Access component

    <%@ Language=VBScript %>
    <HTML>
    <HEAD>
    </HEAD>
    <TITLE>ASP 2.0 Demo - Registry Access Component</TITLE>
    <BODY>
    <H2>ASP 2.0 Demo - Registry Access Component</H2>
    <HR>
    The <B>Registry Access</B> component provides access to the registry on a local or remote computer.
    <P>
    <HR>
    <P>
     <%
      Dim objRegAccess
      Dim strIEVersion
      On Error Resume Next
      Set objRegAccess=Server.CreateObject("IISSample.RegistryAccess")
      If IsObject(objRegAccess)=False Then
        Response.Write "The Registry Access component object can not be created at this time. "
        Response.Write "Either you do not have this component on the server machine or it "
        Response.Write "is not installed properly."
        Response.Write "You may try to fix this problem by installing IIS Resource Kit."
      Else
        Response.Write "The Registry Access component object is created successfully !<P>"
        strIEVersion=objRegAccess.Get("HKLM\Software\Microsoft\Internet Explorer\Version Vector\IE")
        Response.Write("Internet Explorer version - " + strIEVersion)
        Response.Write("<P>")
        If Trim(strIEVersion) <> "" Then
          Response.Write("You got something useful !")
        End if
      End if
     %>
    </BODY>
    </HTML>

    Sunday, May 20, 2007 10:16 AM
  • Man Sanket you areawesome Smile

    really good codes Smile

    Do you know how to automize some activities in the websites ?

    Like automated logging into mail.yahoo.com and then entering the user and pass, and then also checking that INBOX(X) text, and checking whats the value of X. etc etc ?

    I want to automize some few things. If you have any idea about it, do let me know.
    Sunday, May 20, 2007 10:49 AM
  • Hey Harshil, I'm already on way to automate that procedure. Wait for some time and I'll let you know.
    Sunday, May 20, 2007 7:12 PM
  • Thanks a lot my friend. , you are so kind.Smile

    Btw how was your quiz ? hope it went good.
    Monday, May 21, 2007 3:56 AM
  • Hey Harshil,

    My quiz really went good. How was yours ?
    Thursday, May 24, 2007 2:47 PM

  • Code 79 : Shell out to a 32-bit application and wait until task completes

    Declarations

    '*** Monitoring a DOS Shell
    Private Declare Function OpenProcess Lib "Kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
    Private Declare Function GetExitCodeProcess Lib "Kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
    Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
    Const STILL_ACTIVE = &H103
    Const PROCESS_QUERY_INFORMATION = &H400




    Code 79 : Shell out to a 32-bit application and wait until task completes


    Sub Shell32Bit(ByVal JobToDo As String)

             Dim hProcess As Long
             Dim RetVal As Long
             'The next line launches JobToDo as icon,

             'captures process ID
             hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(JobToDo, 1))

             Do

                 'Get the status of the process
                 GetExitCodeProcess hProcess, RetVal

                 'Sleep command recommended as well as DoEvents
                 DoEvents: Sleep 100

             'Loop while the process is active
             Loop While RetVal = STILL_ACTIVE


    End Sub



    Thursday, May 24, 2007 2:48 PM
  • Code 80 : Close all windows and logon as a different user
    Declarations

    Private Const EWX_LogOff As Long = 0
    Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long




    Code 80 : Close all windows and logon as a different user
    Code

    'close all programs and log on as a different user
    lngResult = ExitWindowsEx(EWX_LogOff, 0&)




    Thursday, May 24, 2007 2:51 PM

  • Code 81 : Shut down the computer

    Declarations

    Private Const EWX_SHUTDOWN As Long = 1
    Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long




    Code 81 : Shut down the computer

    Code

    'shut down the computer
    lngResult = ExitWindowsEx(EWX_SHUTDOWN, 0&)



    Thursday, May 24, 2007 3:01 PM

  • Code 82 : Reboot the computer

    Declarations

    Private Const EWX_REBOOT As Long = 2
    Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long




    Code 82 : Reboot the computer

    'reboot the computer
    lngResult = ExitWindowsEx(EWX_REBOOT, 0&)



    Thursday, May 24, 2007 3:03 PM

  • Code 83 : Find free disk space on a computer

    Declarations

    Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long

    Public Type DiskInformation
        lpSectorsPerCluster As Long
        lpBytesPerSector As Long
        lpNumberOfFreeClusters As Long
        lpTotalNumberOfClusters As Long
    End Type




    Code 83 : Find free disk space on a computer

    Code

    Dim info As DiskInformation
    Dim lAnswer As Long
    Dim lpRootPathName As String
    Dim lpSectorsPerCluster As Long
    Dim lpBytesPerSector As Long
    Dim lpNumberOfFreeClusters As Long
    Dim lpTotalNumberOfClusters As Long
    Dim lBytesPerCluster As Long
    Dim lNumFreeBytes As Double
    Dim sString As String

    lpRootPathName = "c:\"
    lAnswer = GetDiskFreeSpace(lpRootPathName, lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters)
    lBytesPerCluster = lpSectorsPerCluster * lpBytesPerSector
    lNumFreeBytes = lBytesPerCluster * lpNumberOfFreeClusters
    sString = "Number of Free Bytes : " & lNumFreeBytes & vbCr & vbLf
    sString = sString & "Number of Free Kilobytes: " & (lNumFreeBytes / 1024) & "K" & vbCr & vbLf
    sString = sString & "Number of Free Megabytes: " & Format(((lNumFreeBytes / 1024) / 1024), "0.00") & "MB"

    MsgBox sString



    Thursday, May 24, 2007 3:05 PM

  • Code 84 : Determine when your visual basic application gains or loses focus

    Declarations

    Option Explicit

    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

    Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
      (ByVal hwnd As Long, ByVal nIndex As Long, _
      ByVal dwNewLong As Long) As Long

    Public Const WM_ACTIVATEAPP = &H1C
    Public Const GWL_WNDPROC = -4

    Global lpPrevWndProc As Long
    Global gHW As Long




    Code 84 : Determine when your visual basic application gains or loses focus

    Code

    'Paste the following code into the code window for Form1:

    Sub Form_Load()
       'Store handle to this form's window
       gHW = Me.hWnd

       'Call procedure to begin capturing messages for this window
       Hook
    End Sub

    Private Sub Form_Unload(Cancel As Integer)
       'Call procedure to stop intercepting the messages for this window
       Unhook
    End Sub

    '******************************************************************
    'Paste the following code into the main module:
    Public Sub Hook()
       'Establish a hook to capture messages to this window
       lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, _
         AddressOf WindowProc)
    End Sub

    Public Sub Unhook()
       Dim temp As Long

       'Reset the message handler for this window
       temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
    End Sub



    Thursday, May 24, 2007 3:06 PM

  • Code 84 : Determine the number of lines in a multi-line text box

    Declarations

    Public 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

    Public Const EM_GETLINECOUNT = &HBA




    Code 84 : Determine the number of lines in a multi-line text box

    Code

        Dim lngLineCount As Long
        On Error Resume Next
     
       'get/show the number of lines in the edit control
        lngLineCount = SendMessageLong(Text1.hwnd, EM_GETLINE, 0&, 0&)
        Label1 = Format$(lngLineCount, "##,###")



    Thursday, May 24, 2007 3:09 PM
  • Code 86 : generate GUIDs (Globally Unique Identifiers)

    Declarations
    Public Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(7) As Byte
    End Type

    Public Declare Function CoCreateGuid Lib "OLE32.DLL" (pGuid As GUID) As Long
    Public Const S_OK = 0 ' return value from CoCreateGuid


    Code 86 : generate GUIDs (Globally Unique Identifiers)

    Code
    Function GetGUID() As String
        
        Dim lResult As Long
        Dim lguid As GUID
        Dim MyguidString As String
        Dim MyGuidString1 As String
        Dim MyGuidString2 As String
        Dim MyGuidString3 As String
        Dim DataLen As Integer
        Dim StringLen As Integer
        Dim i%
        
        On Error GoTo error_olemsg
        
        lResult = CoCreateGuid(lguid)
        
        If lResult = S_OK Then
            MyGuidString1 = Hex$(lguid.Data1)
            StringLen = Len(MyGuidString1)
            DataLen = Len(lguid.Data1)
            MyGuidString1 = LeadingZeros(2 * DataLen, StringLen) & MyGuidString1        'First 4 bytes (8 hex digits)
            
            MyGuidString2 = Hex$(lguid.Data2)
            StringLen = Len(MyGuidString2)
            DataLen = Len(lguid.Data2)
            MyGuidString2 = LeadingZeros(2 * DataLen, StringLen) & Trim$(MyGuidString2)        'Next 2 bytes (4 hex digits)
            
            MyGuidString3 = Hex$(lguid.Data3)
            StringLen = Len(MyGuidString3)
            DataLen = Len(lguid.Data3)
            MyGuidString3 = LeadingZeros(2 * DataLen, StringLen) & Trim$(MyGuidString3)        'Next 2 bytes (4 hex digits)
            
            GetGUID = MyGuidString1 & MyGuidString2 & MyGuidString3
            
            For i% = 0 To 7
               MyguidString = MyguidString & Format$(Hex$(lguid.Data4(i%)), "00")
            Next i%
            
            'MyGuidString contains last 8 bytes of Guid (16 hex digits)
            GetGUID = GetGUID & MyguidString
        Else
            GetGUID = "00000000" ' return zeros if function unsuccessful
        End If
        
        Exit Function

    error_olemsg:
             MsgBox "Error " & Str(Err) & ": " & Error$(Err)
             GetGUID = "00000000"
             Exit Function

    End Function

    Function LeadingZeros(ExpectedLen As Integer, ActualLen As Integer) As String
        LeadingZeros = String$(ExpectedLen - ActualLen, "0")
    End Function


    Thursday, May 24, 2007 3:11 PM

  • Code 87 : Sets the volume label for a drive

    Declarations

    Declare Function SetVolumeLabel Lib "kernel32" Alias "SetVolumeLabelA" (ByVal lpRootPathName As String, ByVal lpVolumeName As String) As Long

    Public Function SetLabel(RootName As String, NewLabel As String)

    If RootName ="" Then

    Exit Function

    End If

    Call SetVolumeLabel(RootName,NewLabel)

    End Function




    Code 87 : Sets the volume label for a drive

    Code

    Private Sub Command1_Click()
    Call SetLabel("c:\windows","Sanket")
    End Sub



    Thursday, May 24, 2007 3:14 PM

  • Code 88 : Enum the supported display resolutions, change resolution and detect the display change message from Windows

    Declarations

    Public Const GWL_WNDPROC = (-4)
    Public Const WM_DISPLAYCHANGE = &H7E

    Public Const DISP_CHANGE_SUCCESSFUL = 0
    Public Const DISP_CHANGE_RESTART = 1
    Public Const DISP_CHANGE_FAILED = -1
    Public Const DISP_CHANGE_BADMODE = -2
    Public Const DISP_CHANGE_NOTUPDATED = -3
    Public Const DISP_CHANGE_BADFLAGS = -4
    Public Const DISP_CHANGE_BADPARAM = -5
    Public Const CDS_UPDATEREGISTRY = 1
    Public Const DM_BITSPERPEL = &H40000
    Public Const DM_PELSHEIGHT = &H100000
    Public Const DM_PELSWIDTH = &H80000


    Public Type DevMode
        dmDeviceName As String * 32
        dmSpecVersion As Integer
        dmDriverVersion As Integer
        dmSize As Integer
        dmDriverExtra As Integer
        dmFields As Long
        dmOrientation As Integer
        dmPaperSize As Integer
        dmPaperLength As Integer
        dmPaperWidth As Integer
        dmScale As Integer
        dmCopies As Integer
        dmDefaultSource As Integer
        dmPrintQuality As Integer
        dmColor As Integer
        dmDuplex As Integer
        dmYResolution As Integer
        dmTTOption As Integer
        dmCollate As Integer
        dmFormName As String * 32
        dmLogPixels As Integer
        dmBitsPerPel As Long
        dmPelsWidth As Long
        dmPelsHeight As Long
        dmDisplayFlags As Long
        dmDisplayFrequency As Long
        dmICMMethod As Long         ' Windows 95 only
        dmICMIntent As Long         ' Windows 95 only
        dmMediaType As Long         ' Windows 95 only
        dmDitherType As Long        ' Windows 95 only
        dmICCManufacturer As Long   ' Windows 95 only
        dmICCModel As Long          ' Windows 95 only
        dmPanningWidth As Long  ' Windows 95 only
        dmPanningHeight As Long ' Windows 95 only
    End Type

    Public 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 Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lpDevMode As DevMode, ByVal dwFlags As Long) As Long

    Public Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As DevMode) As Long




    Code 88 : Enum the supported display resolutions, change resolution and detect the display change message from Windows

    Code

    '----------------------------------------------------------
    'Procedure for Enum the supported resolutions
    '----------------------------------------------------------
    Private Sub EnumRes()
       
        Dim utDevMode As DevMode, fEnd As Boolean
        Dim sDeviceName As String, iMode As Long
        Dim oItem As New ListItem
       
        utDevMode.dmSize = Len(utDevMode)
        iMode = 0
       
        Do

            fEnd = EnumDisplaySettings(sDeviceName, iMode, utDevMode)

            'Do sth with the utDevMode structure
            'The fields dmPelsWidth, dmPelsHeight, dmBitsPerPel are most useful

            iMode = iMode + 1

        Loop Until Not fEnd
       
    End Sub


    '----------------------------------------------------------
    'Code for changing display resolution
    '----------------------------------------------------------
    Private Sub ChangeIt(lPelsWidth As Long, lPelsHeight As Long, lBitsPerPel As Long)

        Dim utDevMode   As DevMode
        Dim iRes        As Long
        Dim sMsg        As String
        Dim oItem       As ListItem
       
        If lvSettings.SelectedItem Is Nothing Then Exit Sub
       
        With utDevMode
            .dmSize = Len(utDevMode)
            .dmPelsWidth = lPelsWidth
            .dmPelsHeight = lPelsHeight
            .dmBitsPerPel = lBitsPerPel
            .dmFields = DM_BITSPERPEL Or DM_PELSHEIGHT Or DM_PELSWIDTH
        End With
       
        iRes = ChangeDisplaySettings(utDevMode, CDS_UPDATEREGISTRY)

        Select Case iRes
            Case Is = DISP_CHANGE_SUCCESSFUL
                sMsg = "Display setting has been changed successfully."
            Case Is = DISP_CHANGE_RESTART
                sMsg = "You have to restart your computer in order to carry out the new setting."
            Case Is = DISP_CHANGE_FAILED
                sMsg = "Sorry, failed to change the display setting."
        End Select
       
        If sMsg <> vbNullString Then MsgBox sMsg, , "Display"
       
    End Sub


    '----------------------------------------------------------
    'To detect the change notification of display resolution
    'from Windows, put the code below into a module, except
    'Hook & Unhook in a form.
    'To begin to capture the notification, call Hook
    'To end capturing the notification, call Unhook
    '----------------------------------------------------------

    Public lPreWndProc As Long

    Public Type TLoHiLong
        lo As Integer
        hi As Integer
    End Type

    Public Type TAllLong
        all As Long
    End Type


    '----------------------------------------------------------
    'Procedure for Subclassing
    '----------------------------------------------------------
    Public Function MyWndProc _
        (ByVal hwnd As Long, _
        ByVal lMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long
       
        If lMsg = WM_DISPLAYCHANGE Then
            Debug.Print "DisplayChange"
            Debug.Print "BitsPerPel: ", wParam
            Debug.Print "lParam: ", lParam
            Debug.Print "loword of lParam: ", LoWord(lParam)
            Debug.Print "HiWord of lParam: ", HiWord(lParam)
        End If
       
        MyWndProc = CallWindowProc(lPreWndProc, hwnd, lMsg, wParam, lParam)

    End Function

    Public Function LoWord(dw As Long) As Integer
        Dim lohi As TLoHiLong
        Dim all As TAllLong
        all.all = dw
        LSet lohi = all
        LoWord = lohi.lo
    End Function

    Public Function HiWord(dw As Long) As Integer
        Dim lohi As TLoHiLong
        Dim all As TAllLong
        all.all = dw
        LSet lohi = all
        HiWord = lohi.hi
    End Function

    '----------------------------------------------------------
    'Code for Subclassing
    '----------------------------------------------------------
    Private Sub Hook()
        lPreWndProc = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf MyWndProc)
    End Sub

    Private Sub Unhook()
        Call SetWindowLong(Me.hwnd, GWL_WNDPROC, lPreWndProc)
    End Sub


    '----------------------------------------------------------
    'Note:
    '   The HiWord & LoWord functions are from
    '   the book Hardcore Visual Basic by
    '   B.Mckinney, Microsoft PRESS
    '----------------------------------------------------------



    Thursday, May 24, 2007 3:16 PM

  • Code 89 : Calls the "Open File Dialog" without need for an OCX

    Declarations

    Private Type OPENFILENAME
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
    End Type

    Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long




    Code 89 : Calls the "Open File Dialog" without need for an OCX

    Code

    'Place the following code in under a command button or in a menu, etc...

        Dim ofn As OPENFILENAME
        ofn.lStructSize = Len(ofn)
        ofn.hwndOwner = Form1.hWnd
        ofn.hInstance = App.hInstance
        ofn.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + "*.txt" + Chr$(0) + "Rich Text Files (*.rtf)" + Chr$(0) + "*.rtf" + Chr$(0)
            ofn.lpstrFile = Space$(254)
            ofn.nMaxFile = 255
            ofn.lpstrFileTitle = Space$(254)
            ofn.nMaxFileTitle = 255
            ofn.lpstrInitialDir = curdir
            ofn.lpstrTitle = "Our File Open Title"
            ofn.flags = 0
            Dim a
            a = GetOpenFileName(ofn)

            If (a) Then
                    MsgBox "File to Open: " + Trim$(ofn.lpstrFile)
            Else
                    MsgBox "Cancel was pressed"
            End If



    Thursday, May 24, 2007 3:19 PM

  • Code 90 : Create GetMouseFocus / LostMouseFocus in yours controls

    Declarations
    Public Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
    Public Declare Function ReleaseCapture Lib "user32" () As Long




    Code 90 : Create GetMouseFocus / LostMouseFocus in yours controls

    Code
    'Put this code in MouseMove event. In this example, I put a CommandButton on a
    'form with the name Command1

    Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Static CtrMov As Boolean
    With Command1 'Change this 'Command1' to your control name
        If (X < 0) Or (Y < 0) Or (X > .Width) Or (Y > .Height) Then
            ReleaseCapture
            CtrMov = False
            
            'Put here your code to LostMouseFocus
            'For example:
            Me.Print "LostMouseFocus"
            
        Else
            SetCapture .hwnd
            If CtrMov = False Then
                CtrMov = True
                            
                'Put here your code to GetMouseFocus
                'For example:
                Me.Print "GetMouseFocus"
            
            End If
        End If
    End With
    End Sub



    Thursday, May 24, 2007 3:23 PM

  • Code 91 : make a transparent area of different shape

    Declarations
    Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
    Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) 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 CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
    Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long




    Code 91 : make a transparent area of different shape

    Code
    Private Function fMakeATranspArea(AreaType As String, pCordinate() As Long) As Boolean


    Const RGN_DIFF = 4

    Dim lOriginalForm As Long
    Dim ltheHole As Long
    Dim lNewForm As Long
    Dim lFwidth As Single
    Dim lFHeight As Single
    Dim lborder_width As Single
    Dim ltitle_height As Single


     On Error GoTo Trap
        lFwidth = ScaleX(Width, vbTwips, vbPixels)
        lFHeight = ScaleY(Height, vbTwips, vbPixels)
        lOriginalForm = CreateRectRgn(0, 0, lFwidth, lFHeight)
        
        lborder_width = (lFHeight - ScaleWidth) / 2
        ltitle_height = lFHeight - lborder_width - ScaleHeight

    Select Case AreaType
     
        Case "Elliptic"
     
                ltheHole = CreateEllipticRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))

        Case "RectAngle"
       
                ltheHole = CreateRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))

          
        Case "RoundRect"
                 
                   ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(5), pCordinate(6))

        Case "Circle"
                   ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(3), pCordinate(4))
        
        Case Else
               MsgBox "Unknown Shape!!"
               Exit Function

           End Select

        lNewForm = CreateRectRgn(0, 0, 0, 0)
        CombineRgn lNewForm, lOriginalForm, _
            ltheHole, RGN_DIFF
        
        SetWindowRgn hWnd, lNewForm, True
        Me.Refresh
        fMakeATranspArea = True
    Exit Function

    Trap:
         MsgBox "error Occurred. Error # " & Err.Number & ", " & Err.Description


    End Function

    ' 3'To Call
    Dim lParam(1 To 6) As Long

    lParam(1) = 100
    lParam(2) = 100
    lParam(3) = 250
    lParam(4) = 250
    lParam(5) = 50
    lParam(6) = 50

    'Call fMakeATranspArea("RoundRect", lParam())
    'Call fMakeATranspArea("RectAngle", lParam())
    Call fMakeATranspArea("Circle", lParam())
    'Call fMakeATranspArea("Elliptic", lParam())


    Thursday, May 24, 2007 3:25 PM

  • Code 92 : capture the screen or the active window of your computer Programmatically

    Declarations

    Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
      ByVal dwFlags As Long, ByVal dwExtraInfo As Long)




    Code 92 : capture the screen or the active window of your computer Programmatically

    Code
    Public Function fSaveGuiToFile(ByVal theFile As String) As Boolean


    Dim lString As String

    On Error goto Trap
    'Check if the File Exist
        If Dir(theFile) <> "" Then Exit Function

        'To get the Entire Screen
        Call keybd_event(vbKeySnapshot, 1, 0, 0)

          'To get the Active Window
        'Call keybd_event(vbKeySnapshot, 0, 0, 0)
     
        SavePicture Clipboard.GetData(vbCFBitmap), theFile

    fSaveGuiToFile = True
    Exit Function

    Trap:
    'Error handling
    MsgBox "Error Occured in fSaveGuiToFile. Error #: " & Err.Number & ", " & Err.Description

    End Function


    Thursday, May 24, 2007 3:28 PM

  • Code 93 : Create Multi-Column Menus in Visual Basic Using the WIN32

    Declarations
    Private Type MENUITEMINFO
          cbSize As Long
          fMask As Long
          fType As Long
          fState As Long
          wID As Long
          hSubMenu As Long
          hbmpChecked As Long
          hbmpUnchecked As Long
          dwItemData As Long
          dwTypeData As String
          cch As Long
    End Type

    Private Const MF_MENUBARBREAK = &H20& ' columns with a separator line
    Private Const MF_MENUBREAK = &H40&    ' columns w/o a separator line
    Private Const MF_STRING = &H0&
    Private Const MF_HELP = &H4000&
    Private Const MFS_DEFAULT = &H1000&
    Private Const MIIM_ID = &H2
    Private Const MIIM_SUBMENU = &H4
    Private Const MIIM_TYPE = &H10
    Private Const MIIM_DATA = &H20

    Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal B As Boolean, lpMenuItemInfo As MENUITEMINFO) As Long
    Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As Long
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long




    Code 93 : Create Multi-Column Menus in Visual Basic Using the WIN32

    Code
    ' 1.Open a new Standard EXE Project. Form1 is created by default.
    ' 2.Add a CommandButton to Form1.
    ' 3.On the Tools menu, click Menu Editor. Create a menu consisting of at least two top level menus containing at least four submenu items each.
    ' 4.Add the following code to Form1:
             
    Private Sub Command1_Click()

        ' Splitting a menu here demonstrates that this can be done dynamically.
        Dim mnuItemInfo As MENUITEMINFO, hMenu As Long, hSubMenu As Long
        Dim BuffStr As String * 80   ' Define as largest possible menu text.
        
        hMenu = GetMenu(Me.hwnd)   ' retrieve menu handle.
        BuffStr = Space(80)
        With mnuItemInfo   ' Initialize the UDT.
               .cbSize = Len(mnuItemInfo)   ' 44
               .dwTypeData = BuffStr & Chr(0)
               .fType = MF_STRING
               .cch = Len(mnuItemInfo.dwTypeData)   ' 80
               .fState = MFS_DEFAULT
               .fMask = MIIM_ID Or MIIM_DATA Or MIIM_TYPE Or MIIM_SUBMENU
        End With

        ' Use item break point position for the '3' below (zero-based list).
        hSubMenu = GetSubMenu(hMenu, 0)
        If GetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
           MsgBox "GetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
        Else
           mnuItemInfo.fType = mnuItemInfo.fType Or MF_MENUBARBREAK
           If SetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
              MsgBox "SetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
           End If
        End If
        DrawMenuBar (Me.hwnd)   ' Repaint top level Menu.

    End Sub



    Private Sub Form_Load()

        ' This works for either an API-created menu or a native VB Menu.
        Dim mnuItemInfo As MENUITEMINFO, hMenu As Long, hSubMenu As Long
        Dim BuffStr As String * 80   ' Define as largest possible menu text.
        
        hMenu = GetMenu(Me.hwnd)   ' Retrieve menu handle.
        BuffStr = Space(80)
        
        With mnuItemInfo   ' Initialize the UDT
               .cbSize = Len(mnuItemInfo)   ' 44
               .dwTypeData = BuffStr & Chr(0)
               .fType = MF_STRING
               .cch = Len(mnuItemInfo.dwTypeData)   ' 80
               .fState = MFS_DEFAULT
               .fMask = MIIM_ID Or MIIM_DATA Or MIIM_TYPE Or MIIM_SUBMENU
        End With

        ' Use item break point position for the '3' below (zero-based list).
        hSubMenu = GetSubMenu(hMenu, 1)
        If GetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
           MsgBox "GetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
        Else
           mnuItemInfo.fType = mnuItemInfo.fType Or MF_MENUBREAK
           If SetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
              MsgBox "SetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
           End If
        End If
        DrawMenuBar (Me.hwnd)   ' Repaint top level Menu.

    End Sub



    Thursday, May 24, 2007 3:31 PM
  • Code 94 : Stay on Top option

    Declarations
    'Add this into your module

    Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

    Global Const conHwndTopmost = -1
    Global Const conHwndNoTopmost = -2
    Global Const conSwpNoActivate = &H10
    Global Const conSwpShowWindow = &H40


    Code 94 : Stay on Top option

    Code
    'Stick an checkbox on your form, call it chkStayOnTop
    'Make sure you define your form properties after the conHwndTopmost statement
    Select Case chkStayOnTop.Checked

    Case False
    mnuStayOnTop.Checked = True
    SetWindowPos hwnd, conHwndTopmost, 100, 100, 205, 141, conSwpNoActivate Or conSwpShowWindow
            
    Case True
    chkStayOnTop.Checked = False
    SetWindowPos hwnd, conHwndNoTopmost, 100, 100, 205, 141, conSwpNoActivate Or conSwpShowWindow

    End Select


    Thursday, May 24, 2007 3:33 PM

  • Code 95 : Automatically drops down the list portion of a ComboBox control whenever the ComboBox receives the focus

    Declarations

    Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long




    Code 95 : Automatically drops down the list portion of a ComboBox control whenever the ComboBox receives the focus

    Code
    Private Sub Combo1_GotFocus()
       Const CB_SHOWDROPDOWN = &H14F
       Dim Tmp
       Tmp = SendMessage(Combo1.hwnd, CB_SHOWDROPDOWN, 1, ByVal 0&)
    End Sub



    Thursday, May 24, 2007 3:43 PM

  • Code 96 : Retrieve and Set windows 32 Regional Settings

    Declarations
    Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
    Declare Function SetLocaleInfo Lib "kernel32" Alias "SetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String) As Boolean
    Declare Function GetUserDefaultLCID% Lib "kernel32" ()

    Public Const LOCALE_ICENTURY = &H24
    Public Const LOCALE_ICOUNTRY = &H5
    Public Const LOCALE_ICURRDIGITS = &H19
    Public Const LOCALE_ICURRENCY = &H1B
    Public Const LOCALE_IDATE = &H21
    Public Const LOCALE_IDAYLZERO = &H26
    Public Const LOCALE_IDEFAULTCODEPAGE = &HB
    Public Const LOCALE_IDEFAULTCOUNTRY = &HA
    Public Const LOCALE_IDEFAULTLANGUAGE = &H9
    Public Const LOCALE_IDIGITS = &H11
    Public Const LOCALE_IINTLCURRDIGITS = &H1A
    Public Const LOCALE_ILANGUAGE = &H1
    Public Const LOCALE_ILDATE = &H22
    Public Const LOCALE_ILZERO = &H12
    Public Const LOCALE_IMEASURE = &HD
    Public Const LOCALE_IMONLZERO = &H27
    Public Const LOCALE_INEGCURR = &H1C
    Public Const LOCALE_INEGSEPBYSPACE = &H57
    Public Const LOCALE_INEGSIGNPOSN = &H53
    Public Const LOCALE_INEGSYMPRECEDES = &H56
    Public Const LOCALE_IPOSSEPBYSPACE = &H55
    Public Const LOCALE_IPOSSIGNPOSN = &H52
    Public Const LOCALE_IPOSSYMPRECEDES = &H54
    Public Const LOCALE_ITIME = &H23
    Public Const LOCALE_ITLZERO = &H25
    Public Const LOCALE_NOUSEROVERRIDE = &H80000000
    Public Const LOCALE_S1159 = &H28
    Public Const LOCALE_S2359 = &H29
    Public Const LOCALE_SABBREVCTRYNAME = &H7
    Public Const LOCALE_SABBREVDAYNAME1 = &H31
    Public Const LOCALE_SABBREVDAYNAME2 = &H32
    Public Const LOCALE_SABBREVDAYNAME3 = &H33
    Public Const LOCALE_SABBREVDAYNAME4 = &H34
    Public Const LOCALE_SABBREVDAYNAME5 = &H35
    Public Const LOCALE_SABBREVDAYNAME6 = &H36
    Public Const LOCALE_SABBREVDAYNAME7 = &H37
    Public Const LOCALE_SABBREVLANGNAME = &H3
    Public Const LOCALE_SABBREVMONTHNAME1 = &H44
    Public Const LOCALE_SCOUNTRY = &H6
    Public Const LOCALE_SCURRENCY = &H14
    Public Const LOCALE_SDATE = &H1D
    Public Const LOCALE_SDAYNAME1 = &H2A
    Public Const LOCALE_SDAYNAME2 = &H2B
    Public Const LOCALE_SDAYNAME3 = &H2C
    Public Const LOCALE_SDAYNAME4 = &H2D
    Public Const LOCALE_SDAYNAME5 = &H2E
    Public Const LOCALE_SDAYNAME6 = &H2F
    Public Const LOCALE_SDAYNAME7 = &H30
    Public Const LOCALE_SDECIMAL = &HE
    Public Const LOCALE_SENGCOUNTRY = &H1002
    Public Const LOCALE_SENGLANGUAGE = &H1001
    Public Const LOCALE_SGROUPING = &H10
    Public Const LOCALE_SINTLSYMBOL = &H15
    Public Const LOCALE_SLANGUAGE = &H2
    Public Const LOCALE_SLIST = &HC
    Public Const LOCALE_SLONGDATE = &H20
    Public Const LOCALE_SMONDECIMALSEP = &H16
    Public Const LOCALE_SMONGROUPING = &H18
    Public Const LOCALE_SMONTHNAME1 = &H38
    Public Const LOCALE_SMONTHNAME10 = &H41
    Public Const LOCALE_SMONTHNAME11 = &H42
    Public Const LOCALE_SMONTHNAME12 = &H43
    Public Const LOCALE_SMONTHNAME2 = &H39
    Public Const LOCALE_SMONTHNAME3 = &H3A
    Public Const LOCALE_SMONTHNAME4 = &H3B
    Public Const LOCALE_SMONTHNAME5 = &H3C
    Public Const LOCALE_SMONTHNAME6 = &H3D
    Public Const LOCALE_SMONTHNAME7 = &H3E
    Public Const LOCALE_SMONTHNAME8 = &H3F
    Public Const LOCALE_SMONTHNAME9 = &H40
    Public Const LOCALE_SMONTHOUSANDSEP = &H17
    Public Const LOCALE_SNATIVECTRYNAME = &H8
    Public Const LOCALE_SNATIVEDIGITS = &H13
    Public Const LOCALE_SNATIVELANGNAME = &H4
    Public Const LOCALE_SNEGATIVESIGN = &H51
    Public Const LOCALE_SPOSITIVESIGN = &H50
    Public Const LOCALE_SSHORTDATE = &H1F
    Public Const LOCALE_STHOUSAND = &HF
    Public Const LOCALE_STIME = &H1E
    Public Const LOCALE_STIMEFORMAT = &H1003



    Code 96 : Retrieve and Set windows 32 Regional Settings

    Code
    Private Sub Get_locale() ' Retrieve the regional setting

          Dim Symbol As String
          Dim iRet1 As Long
          Dim iRet2 As Long
          Dim lpLCDataVar As String
          Dim Pos As Integer
          Dim Locale As Long
          
          Locale = GetUserDefaultLCID()

    'LOCALE_SDATE is the constant for the date separator
    'as stated in declarations
    'for any other locale just change the contant in the Function
          
          iRet1 = GetLocaleInfo(Locale, LOCALE_SDATE, lpLCDataVar, 0)
          Symbol = String$(iRet1, 0)
          
          iRet2 = GetLocaleInfo(Locale, LOCALE_SDATE, Symbol, iRet1)
          Pos = InStr(Symbol, Chr$(0))
          If Pos > 0 Then
               Symbol = Left$(Symbol, Pos - 1)
               msgbox "Regional Setting = " + symbol
          End If

    End sub

    Private Sub Set_locale() 'Change the regional setting

          Dim Symbol As String
          Dim iRet As Long
          Dim Locale As Long
          
    'LOCALE_SDATE is the constant for the date separator
    'as stated in declarations
    'for any other locale just change the contant in the Function

          Locale = GetUserDefaultLCID() 'Get user Locale ID
          Symbol = "-" 'New character for the locale
          iRet = SetLocaleInfo(Locale, LOCALE_SDATE, Symbol)


        
    End Sub


    Thursday, May 24, 2007 3:46 PM

  • Code 97 : Disable/Enable Ctrl+Alt+Del and Alt+Tab

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

    Public Const SPI_SCREENSAVERRUNNING = 97



    Code 97 : Disable/Enable Ctrl+Alt+Del and Alt+Tab

    Code
    Private Sub ToggleCtrlAltDel(IsEnabled As Boolean)
       Dim lReturn  As Long
       Dim lBool As Long
       lReturn = SystemParametersInfo(SPI_SCREENSAVERRUNNING, IsEnabled, lBool, vbNull)
    End Sub


    Thursday, May 24, 2007 3:48 PM

  • Code 98 : Changing the System colors from visual basic

    Declarations
    Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long
    Public Const COLOR_ACTIVEBORDER = 10
    Public Const COLOR_ACTIVECAPTION = 2
    Public Const COLOR_APPWORKSPACE = 12
    Public Const COLOR_BACKGROUND = 1
    Public Const COLOR_BTNFACE = 15
    Public Const COLOR_BTNSHADOW = 16
    Public Const COLOR_BTNTEXT = 18
    Public Const COLOR_CAPTIONTEXT = 9
    Public Const COLOR_INACTIVEBORDER = 11
    Public Const COLOR_INACTIVECAPTION = 3
    Public Const COLOR_MENU = 4
    Public Const COLOR_MENUTEXT = 7
    Public Const COLOR_SCROLLBAR = 0
    Public Const COLOR_WINDOW = 5
    Public Const COLOR_WINDOWFRAME = 6
    Public Const COLOR_WINDOWTEXT = 8




    Code 98 : Changing the System colors from visual basic

    Code
    Public Sub elements()
    Combo1.AddItem "COLOR_ACTIVEBORDER"
    Combo1.AddItem "COLOR_ACTIVECAPTION"
    Combo1.AddItem "COLOR_APPWORKSPACE"
    Combo1.AddItem "COLOR_BACKGROUND"
    Combo1.AddItem "COLOR_BTNFACE"
    Combo1.AddItem "COLOR_BTNTEXT"
    Combo1.AddItem "COLOR_CAPTIONTEXT"
    Combo1.AddItem "COLOR_INACTIVEBORDER"
    Combo1.AddItem "COLOR_INACTIVECAPTION"
    Combo1.AddItem "COLOR_MENU"
    Combo1.AddItem "COLOR_MENUTEXT"
    Combo1.AddItem "COLOR_SCROLLBAR"
    Combo1.AddItem "COLOR_WINDOW"
    Combo1.AddItem "COLOR_WINDOWFRAME"
    Combo1.AddItem "COLOR_WINDOWTEXT"
    End Sub

    Private Sub Command1_Click()
    Dim RT As Long
    CD.ShowColor
    Call CHANGE_COLORS
    End Sub

    Private Sub Command2_Click()
    End
    End Sub

    Private Sub Form_Load()
    Call elements
    End Sub

    Public Sub CHANGE_COLORS()
    Select Case Combo1.Text
    Case "COLOR_ACTIVEBORDER"
         RT = SetSysColors(1, 10, CD.Color)
    Case "COLOR_ACTIVE_CAPTION"
         RT = SetSysColors(1, 2, CD.Color)
    Case "COLOR_APPWORKSPACE"
         RT = SetSysColors(1, 12, CD.Color)
    Case "COLOR_BACKGROUND"
         RT = SetSysColors(1, 1, CD.Color)
    Case "COLOR_BTNFACE"
         RT = SetSysColors(1, 15, CD.Color)
    Case "COLOR_BTNTEXT"
         RT = SetSysColors(1, 16, CD.Color)
    Case "COLOR_CAPTIONTEXT"
         RT = SetSysColors(1, 9, CD.Color)
    Case "COLOR_INACTIVEBORDER"
         RT = SetSysColors(1, 11, CD.Color)
    Case "COLOR_INACTIVECAPTION"
         RT = SetSysColors(1, 3, CD.Color)
    Case "COLOR_MENU"
         RT = SetSysColors(1, 4, CD.Color)
    Case "COLOR_MENUTEXT"
         RT = SetSysColors(1, 7, CD.Color)
    Case "COLOR_SCROLLBAR"
         RT = SetSysColors(1, 0, CD.Color)
    Case "COLOR_WINDOW"
         RT = SetSysColors(1, 5, CD.Color)
    Case "COLOR_WINDOWFRAME"
         RT = SetSysColors(1, 6, CD.Color)
    Case "COLOR_WINDOWTEXT"
         RT = SetSysColors(1, 8, CD.Color)
    End Select
    End Sub



    Thursday, May 24, 2007 3:50 PM

  • Code 99 : Create Database Through Visual Basic
    Private Sub Command1_Click()
    On Error GoTo procerror
    Screen.MousePointer = 11
    Dim dbname As String
    dbname = GetDBName()
    If Len(dbname) > 0 Then
       CreateDB dbname
    End If
    procexit:
    Screen.MousePointer = 0
    Exit Sub
    procerror:
    MsgBox Err.Description
    Resume procexit

    End Sub

    Public Function GetDBName() As String
    On Error GoTo procerror
    Dim filename As String
    cd.DefaultExt = "mdb"
    cd.DialogTitle = "Create Database"
    cd.Filter = "VB Databases (*.mdb)|*.mdb"
    cd.FilterIndex = 1
    cd.Flags = cdlOFNHideReadOnly Or _
               cdlOFNOverwritePrompt Or _
               cdlOFNPathMustExist
    cd.CancelError = True
    cd.ShowSave
    filename = cd.filename
    On Error Resume Next
    Kill filename

    procexit:
    GetDBName = filename
    Exit Function


    procerror:
    filename = ""
    Resume procexit
    End Function

    Public Sub CreateDB(dbname As String)
    Dim db As Database
    Set db = DBEngine(0).CreateDatabase(dbname, dbLangGeneral)
    End Sub

    Private Sub Command2_Click()
    Form2.Show
    End Sub

    Private Sub Command3_Click()
    Form3.Show
    End Sub

    Private Sub Command4_Click()
    Form4.Show
    End Sub

    Thursday, May 24, 2007 3:54 PM

  • Code 101 : Get Data From Excel To Visual Basic

    Option Explicit
    Dim db As Database
    Dim rs As Recordset
    Private filepath As String
    Private sheetname As String

    Private Sub Form_Activate()
    DoEvents
    filepath = "G:\Sanket\Project Base\Codes\Tryouts\test.xls"
    sheetname = "Sheet1$"
    Set db = OpenDatabase(filepath, False, False, "Excel 8.0;HDR=yes;")
    Set rs = db.OpenRecordset(sheetname)
    rs.MoveFirst
    Screen.MousePointer = 11
    While rs.EOF <> True
    List1.AddItem rs.Fields("Name") & "  " & rs.Fields(1) & "  " & rs.Fields(2)
    rs.MoveNext
    Wend
    Screen.MousePointer = 0
    End Sub

    Thursday, May 24, 2007 3:56 PM

  • Code 101 : Play Wav Sound Files Using API's

    Declarations
    'module (Api Functions declarations)

    Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

    Public Const SND_ALIAS = &H10000     '  name is a WIN.INI [sounds] entry
    Public Const SND_ASYNC = &H1         '  play asynchronously
    Public Const SND_LOOP = &H8         '  loop the sound until next sndPlaySound
    Public Const SND_NOWAIT = &H2000      '  don't wait if the driver is busy
    Public Const SND_SYNC = &H0         '  play synchronously (default)




    Code 101 : Play Wav Sound Files Using API's

    Code
    'Form code

    public sub cmdPlaysoundClick()

    dim ret as long
    ret=sndplaysound("F:\Songs\Dhoom-2\Title.mp3",SND_SYNC)

    End Sub



    Thursday, May 24, 2007 3:59 PM

  • Code 102 : Search a ListBox Control Quickly Using API Call

    Declarations
    Const LB_FINDSTRING = &H18F
    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



    Code 102 : Search a ListBox Control Quickly Using API Call

    Code
    Private Sub Text1_Change()
        List1.ListIndex = SendMessage(List1.hWnd, LB_FINDSTRING, -1, _
                    ByVal Text1.Text)
    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


    Thursday, May 24, 2007 4:01 PM

  • Code 103 : Tells you how long you have been in windows using the GetTickCount API

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



    Code 103 : Tells you how long you have been in windows using the GetTickCount API

    Code
    lblTime.Caption = Format(GetTickCount, "0") 'How long in windows (milliseconds)
    'lblTime.Caption = Format(GetTickCount / 60000, "0") 'How long in windows in (seconds)


    Thursday, May 24, 2007 4:05 PM
  • Code 104 : get GetKeyboardLayout language from a thread

    Declarations
    Public 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



    Code 104 : get GetKeyboardLayout language from a thread

    Code
    Public Sub FindTheardlanguage  ()

    Dim TheardId As Long
    Dim TheardLang As Long

        TheardId = get_threadId 'call function
        TheardLang = GetKeyboardLayout(ByVal TheardId)
        TheardLang = TheardLang Mod 10000
        
      Select Case TheardLang
       Case 9721 'english
        'do your stuff
        
       Case 1869 'hebrew
         'do your stuff
       
      End Select
        

    End Sub



    Public Function get_threadId() As Long
    Dim threadid As Long, processid As Long

    get_threadId = GetWindowThreadProcessId(winHWND, processid)

    End Function



    Thursday, May 24, 2007 4:11 PM

  • Code 105 : How to get the Windows directory with only one line code
    Dim Windows (Optional)

    Windows = Environ("Windir")
    'Get the Windows directory from a MS-Dos Environment, stored in c:\msdos.sys


    MsgBox Windows (Optional)
    Thursday, May 24, 2007 4:15 PM
  • Code 106 : Get the User Name of a person logged into a particular machine in Windows NT

    Declarations
    Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

    Dim counter As Long, s As String
    Dim dl As Long


    Code 106 : Get the User Name of a person logged into a particular machine in Windows NT

    Code
    counter = 200    'size of buffer
    s = String(counter, 0)

    dl = GetComputerName(s, counter)
    Text1.Text = Left(s, counter)     'gets the name of the user in a textbox



    Thursday, May 24, 2007 4:18 PM

  • Code 107 : Get the name of a particular computer

    Declarations
    Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

    Dim dl As Long
    Dim cnt As Long, s As String



    Code 107 : Get the name of a particular computer

    Code
        cnt = 200
        s = String(cnt, 0)
            
        dl = GetComputerName(s, counter)
        Text1.Text = Left(s, counter)
            
       


    Thursday, May 24, 2007 4:23 PM
  • Code 108 : Auto-searching by entering text in a combo box

    Declarations
    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 Const CB_FINDSTRING = &H14C


    Code 108 : Auto-searching by entering text in a combo box

    Code
    Enter the following code in the combo box's Change event:  
     
    Private Sub Combo1_Change()
      Dim iStart As Integer
      Dim sString As String
      Static iLeftOff As Integer
     
      iStart = 1
      iStart = Combo1.SelStart
     
      If iLeftOff <> 0 Then
        Combo1.SelStart = iLeftOff
        iStart = iLeftOff
      End If
     
      sString = CStr(Left(Combo1.Text, iStart))
      Combo1.ListIndex = SendMessage(Combo1.hwnd, _
      CB_FINDSTRING, -1, ByVal CStr(Left( _
      Combo1.Text, iStart)))
     
      If Combo1.ListIndex = -1 Then
        iLeftOff = Len(sString)
        Combo1.Text = sString
      End If
     
      Combo1.SelStart = iStart
      iLeftOff = 0
    End Sub 


    Thursday, May 24, 2007 4:25 PM
  • Code 109 : gets the state of any key on the keyboard

    Declarations
    Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer


    Code 109 : gets the state of any key on the keyboard

    Code
    'Have you ever faced the problem of not being able to
    'get key input when more than four keys are being
    'pressed? With this API it is no longer a problem!
    'This is a short sample that gets the state of any key
    'on the keyboard. The numbers passed in are the same as
    'the keycodes in Form_KeyDown. You can look these up by
    'typing "key code constants" in the VB help. The return
    'values are sort of weird. At the beginning, the value
    'of an unpressed key is 0, if it is held down after that,
    'the value is -127, unpressed again is 1, and the second
    'pressed value is -128. This cycle then repeats itself.

    Dim RetValue As Long
    Dim SendKeyCode As Long
    SendKeyCode = 37 'Left key
    RetValue = GetKeyState(SendKeyCode)
    Print RetValue



    Thursday, May 24, 2007 4:29 PM
  • Code 110 : Change Date Format of the system

    Declarations
    Public Const LOCALE_SSHORTDATE As Long = &H1F
    Public Const LOCALE_USER_DEFAULT As Long = &H400

    Public Declare Function GetLocaleInfo Lib "kernel32" _
        Alias "GetLocaleInfoA" (ByVal lLocale As Long, _
            ByVal lLocaleType As Long, ByVal sLCData As String, _
            ByVal lBufferLength As Long) As Long
    Public Declare Function SetLocaleInfo Lib "kernel32" _
        Alias "SetLocaleInfoA" (ByVal Locale As Long, _
            ByVal LCType As Long, ByVal lpLCData As String) As Long



    Code 110 : Change Date Format of the system

    Code
    'put this code at form
    'i have used for short date format similarly it can be used for long
    'date format

        Dim shortDateFormat As String
        Dim lBuffSize As String
        Dim sBuffer As String
        Dim lRetGet As Long
        Dim lRetSet As Long
        
        lBuffSize = 256
        sBuffer = String$(lBuffSize, vbNullChar)
        'get the date information in buffer
        lRetGet = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_SSHORTDATE, sBuffer, lBuffSize)
     
        If lRetGet > 0 Then
            shortDateFormat = Left$(sBuffer, lRetGet - 1)
            'this is the existing format of machine
       End If
        'to change the format if doesn't matches ur format
        'MM should be used in capital for monyhs,small m are for minutes
        If LCase(shortDateFormat) <> "dd/mm/yyyy" Then
            lRetSet = SetLocaleInfo(LOCALE_USER_DEFAULT,_ LOCALE_SSHORTDATE, "dd/MM/yyyy")
    'on sucess lretset have value greater than 0
            If lRetSet <= 0 Then
                 msgbox "date format not changed
            End If
        End If



    Thursday, May 24, 2007 4:31 PM
  • Code 111 : Adding AutoComplete to a VB Text Box

    Declarations
    'Add a label (Label1), and text box (Text1) and a command button (Command1) to
    'a form, and add the following:


    Option Explicit

    'Flags to control the operation of SHAutoComplete.
    'The first four are used to override the Internet
    'Explorer registry settings. The user can change
    'these settings manually by launching the Internet
    'Options property sheet from the Tools menu and
    'clicking the Advanced tab.The last five can be
    'used to specify which files or URLs will be
    'available for autoappend or autosuggest operations.

    'Ignore registry default and force feature on
    Private Const SHACF_AUTOSUGGEST_FORCE_ON  As Long = &H10000000

    'Ignore registry default and force feature off.
    Private Const SHACF_AUTOSUGGEST_FORCE_OFF  As Long = &H20000000

    'Ignore registry default and force feature on. (Also know as AutoComplete)
    Private Const SHACF_AUTOAPPEND_FORCE_ON  As Long = &H40000000

    'Ignore registry default and force feature off. (Also know as AutoComplete)
    Private Const SHACF_AUTOAPPEND_FORCE_OFF  As Long = &H80000000

    'Currently (SHACF_FILESYSTEM | SHACF_URLALL)
    Private Const SHACF_DEFAULT  As Long = &H0

    'Includes the File System as well as the rest
    'of the shell (Desktop\My Computer\Control Panel\)
    Private Const SHACF_FILESYSTEM  As Long = &H1

    'URLs in the User's History
    Private Const SHACF_URLHISTORY  As Long = &H2

    'URLs in the User's Recently Used list
    Private Const SHACF_URLMRU  As Long = &H4

    Private Const SHACF_URLALL  As Long = (SHACF_URLHISTORY Or SHACF_URLMRU)

    'Identifies the platform for which the DLL was built.
    Private Const DLLVER_PLATFORM_WINDOWS As Long = &H1  'Windows 95
    Private Const DLLVER_PLATFORM_NT As Long = &H2       'Windows NT

    Private Type DllVersionInfo
       cbSize As Long
       dwMajorVersion As Long
       dwMinorVersion As Long
       dwBuildNumber As Long
       dwPlatformID As Long
    End Type

    Private Declare Function SHAutoComplete _
       Lib "Shlwapi.dll" _
      (ByVal hwndEdit As Long, _
       ByVal dwFlags As Long) As Long

    Private Declare Function DllGetVersion _
       Lib "Shlwapi.dll" _
      (dwVersion As DllVersionInfo) As Long



    Code 111 : Adding AutoComplete to a VB Text Box

    Code
    Private Function GetIEVersion(DVI As DllVersionInfo) As Long
       
       DVI.cbSize = Len(DVI)
       Call DllGetVersion(DVI)

       GetIEVersion = DVI.dwMajorVersion
       
    End Function


    Private Function GetIEVersionString() As String
       
       Dim DVI As DllVersionInfo
       
       DVI.cbSize = Len(DVI)
       Call DllGetVersion(DVI)

       GetIEVersionString = "Internet Explorer " & _
                            DVI.dwMajorVersion & "." & _
                            DVI.dwMinorVersion & "." & _
                            DVI.dwBuildNumber
       
    End Function


    Private Sub Command1_Click()

       Dim DVI As DllVersionInfo

       If GetIEVersion(DVI) >= 5 Then
       
         'Turn on auto-complete
          Call SHAutoComplete(Text1.hWnd, SHACF_DEFAULT)
          
         'update the captions and set focus to the textbox
          Command1.Caption = "SHAutoComplete is On"
          Command1.Enabled = False
          Text1.SetFocus
          Text1.SelStart = Len(Text1.Text)
       
       Else
       
         'damn!
          MsgBox "Sorry ... you need IE5 to use this demo", vbExclamation
          
       End If
       
    End Sub


    Private Sub Form_Load()

      'dim a DllVersionInfo type
       Dim DVI As DllVersionInfo

      'display the version of Shlwapi
       Label1 = "Using Shlwapi.dll for " & GetIEVersionString
       
      'if not 5 or greater, can't do it
       Command1.Enabled = GetIEVersion(DVI) >= 5
       Command1.Caption = "SHAutoComplete is Off"

    End Sub



    Thursday, May 24, 2007 4:33 PM
  • Code 112 : Single Line Code to Hide the Start Button

    Declarations
    Private Declare Function ShowWindow Lib "User32" (ByVal hWnd as Long,ByVal nCmdShow as Long) as Long
    ' Please Kindly check the API Declartion for the Above Function or Declare the
    ' function using API Text Viewer


    Code 112 : Single Line Code to Hide the Start Button

    Code

    Private Sub Command1_Click
    ShowWindow 532,0 'To Hide
    ShowWindow 532,1 'To Show
    End Sub



    Thursday, May 24, 2007 4:36 PM

  • Code 113 : Find and replace one string with another
        Function FindReplace(SourceString, SearchString, ReplaceString)
            tmpString1 = SourceString
            Do Until vFixed
                tmpString2 = tmpString1
                tmpString1 = ReplaceFirstInstance(tmpString1, SearchString,ReplaceString)
                If tmpString1 = tmpString2 Then vFixed = True
            Loop
            FindReplace = tmpString1
        End Function

        Function ReplaceFirstInstance(SourceString, SearchString, ReplaceString)
            FoundLoc = InStr(1, SourceString, SearchString)
            If FoundLoc <> 0 Then
                    ReplaceFirstInstance = Left(SourceString, FoundLoc - 1) & _
                    ReplaceString & Right(SourceString, _
                    Len(SourceString) - (FoundLoc - 1) - Len(SearchString))
            Else
                ReplaceFirstInstance = SourceString
            End If
        End Function
    Thursday, May 24, 2007 4:38 PM
  • Code 114 : Quick and easy encryption
    'Encryption function
    Public Function Encrypt(ByVal Plain As String)
        Dim Letter As String
        For I = 1 To Len(Plain)
            Letter = Mid$(Plain, I, 1)
            Mid$(Plain, I, 1) = Chr(Asc(Letter) + 1)
        Next I
        Encrypt = Plain
    End Function
    'Here's the Decryption function:
    Public Function Decrypt(ByVal Encrypted As String)
    Dim Letter As String
        For I = 1 To Len(Encrypted)
            Letter = Mid$(Encrypted, I, 1)
            Mid$(Encrypted, I, 1) = Chr(Asc(Letter) - 1)
        Next I
        Decrypt = Encrypted
    End Function

    'here is sample code to test it....
    Dim strMessage As String
    strMessage = "Original:"
    strMessage = strMessage & "This is a test" & vbCrLf
    strMessage = strMessage & vbCrLf & "Encrypted:"
    strMessage = strMessage & Encrypt("This is a test") & vbCrLf
    strMessage = strMessage & vbCrLf & "Un-Encrypted:"
    strMessage = strMessage & Decrypt(Encrypt("This is a test"))
    MsgBox strMessage
    Thursday, May 24, 2007 4:42 PM
  • Man this thread is really awesome Smile No need to look anywhere else for VB help Smile

    Man i give you 100/100 credit for thi