Forum for Helpful Visual Basic 6.0 Codes... Part 2

Question

Answer 1

Sign in to vote

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

Answer 2

0

Sign in to vote

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

Answer 3

0

Sign in to vote

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

Answer 4

0

Sign in to vote

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

Answer 5

0

Sign in to vote

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

Answer 6

0

Sign in to vote

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

Answer 7

0

Sign in to vote

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

Answer 8

0

Sign in to vote

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

Answer 9

0

Sign in to vote

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

Answer 10

0

Sign in to vote

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

Answer 11

0

Sign in to vote

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

Answer 12

0

Sign in to vote

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

Answer 13

0

Sign in to vote

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

Sub CapsON ()
Call SetKeyboardState(VbKeyCaps)
End sub

Sunday, May 20, 2007 8:49 AM

Answer 14

0

Sign in to vote

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

Answer 15

0

Sign in to vote

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

Answer 16

0

Sign in to vote

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

Answer 17

0

Sign in to vote

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

Answer 18

0

Sign in to vote

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

Answer 19

0

Sign in to vote

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

Answer 20

0

Sign in to vote

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

Answer 21

0

Sign in to vote

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

Answer 22

0

Sign in to vote

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

Answer 23

0

Sign in to vote

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

Answer 24

0

Sign in to vote

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

Answer 25

0

Sign in to vote

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

Answer 26

0

Sign in to vote

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

Answer 27

0

Sign in to vote

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

Answer 28

0

Sign in to vote

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

Answer 29

0

Sign in to vote

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

Answer 30

0

Sign in to vote

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

Answer 31

0

Sign in to vote

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

Answer 32

0

Sign in to vote

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

Answer 33

0

Sign in to vote

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

Answer 34

0

Sign in to vote

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

Answer 35

0

Sign in to vote

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

Answer 36

0

Sign in to vote

Code 73 : Detecting Browser TypeCode Snippet
<%
   Set MyBrowser=server.createobject("MSWC.Browsertype")
   response.write MyBrowser.Browser 
%>

Sunday, May 20, 2007 10:04 AM

Answer 37

0

Sign in to vote

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

Answer 38

0

Sign in to vote

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

Answer 39

0

Sign in to vote

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

Answer 40

0

Sign in to vote

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

Answer 41

0

Sign in to vote

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

Answer 42

0

Sign in to vote

Man Sanket you areawesome

really good codes

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

Answer 43

0

Sign in to vote

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

Answer 44

0

Sign in to vote

Thanks a lot my friend. , you are so kind.

Btw how was your quiz ? hope it went good.

Monday, May 21, 2007 3:56 AM

Answer 45

0

Sign in to vote

Hey Harshil,

My quiz really went good. How was yours ?

Thursday, May 24, 2007 2:47 PM

Answer 46

0

Sign in to vote

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

Answer 47

0

Sign in to vote

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

Answer 48

0

Sign in to vote

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

Answer 49

0

Sign in to vote

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

Answer 50

0

Sign in to vote

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

Answer 51

0

Sign in to vote

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

Answer 52

0

Sign in to vote

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

Answer 53

0

Sign in to vote

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

Answer 54

0

Sign in to vote

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

Answer 55

0

Sign in to vote

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

Answer 56

0

Sign in to vote

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

Answer 57

0

Sign in to vote

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

Answer 58

0

Sign in to vote

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

Answer 59

0

Sign in to vote

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

Answer 60

0

Sign in to vote

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

Answer 61

0

Sign in to vote

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

Answer 62

0

Sign in to vote

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

Answer 63

0

Sign in to vote

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

Answer 64

0

Sign in to vote

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

Answer 65

0

Sign in to vote

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

Answer 66

0

Sign in to vote

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

Answer 67

0

Sign in to vote

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

Answer 68

0

Sign in to vote

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

Answer 69

0

Sign in to vote

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

Answer 70

0

Sign in to vote

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

Answer 71

0

Sign in to vote

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

Answer 72

0

Sign in to vote

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

Answer 73

0

Sign in to vote

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

Answer 74

0

Sign in to vote

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

Answer 75

0

Sign in to vote

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

Answer 76

0

Sign in to vote

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

Answer 77

0

Sign in to vote

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

Answer 78

0

Sign in to vote

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

Answer 79

0

Sign in to vote

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

Answer 80

0

Sign in to vote

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

Answer 81

0

Sign in to vote

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

Answer 82

0

Sign in to vote

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

Answer 83

0

Sign in to vote

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

Answer 84

0

Sign in to vote

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

Answer 85

0

Sign in to vote

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

Answer 86

0

Sign in to vote

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

Answer 87

0

Sign in to vote

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

Answer 88

0

Sign in to vote

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

Answer 89

0

Sign in to vote

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

Answer 90

0

Sign in to vote

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

Answer 91

0

Sign in to vote

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

Answer 92

0

Sign in to vote

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

Answer 93

0

Sign in to vote

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

Answer 94

0

Sign in to vote

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

Answer 95

0

Sign in to vote

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

Answer 96

0

Sign in to vote

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

Answer 97

0

Sign in to vote

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

Answer 98

0

Sign in to vote

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

Answer 99

0

Sign in to vote

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

Answer 100

0

Sign in to vote

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

Answer 101

0

Sign in to vote

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

Answer 102

0

Sign in to vote

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

Answer 103

0

Sign in to vote

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

Answer 104

0

Sign in to vote

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

Answer 105

0

Sign in to vote

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

Answer 106

0

Sign in to vote

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

Answer 107

0

Sign in to vote

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

Answer 108

0

Sign in to vote

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

Answer 109

0

Sign in to vote

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

Answer 110

0

Sign in to vote

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

Answer 111

0

Sign in to vote

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

Answer 112

0

Sign in to vote

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

Answer 113

0

Sign in to vote

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

Answer 114

0

Sign in to vote

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

Answer 115

0

Sign in to vote

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

Answer 116

0

Sign in to vote

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

Answer 117

0

Sign in to vote

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

Answer 118

0

Sign in to vote

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

Answer 119

0

Sign in to vote

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

Answer 120

0

Sign in to vote

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

Answer 121

0

Sign in to vote

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

Answer 122

0

Sign in to vote

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

Answer 123

0

Sign in to vote

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

Answer 124

0

Sign in to vote

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

Answer 125

0

Sign in to vote

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

Answer 126

0

Sign in to vote

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

Answer 127

0

Sign in to vote

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

Answer 128

0

Sign in to vote

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

Answer 129

0

Sign in to vote

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

Answer 130

0

Sign in to vote

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

Answer 131

0

Sign in to vote

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

Answer 132

0

Sign in to vote

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

Answer 133

0

Sign in to vote

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

Answer 134

0

Sign in to vote

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

Answer 135

0

Sign in to vote

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

Answer 136

0

Sign in to vote

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

Answer 137

0

Sign in to vote

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

Answer 138

0

Sign in to vote

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

Answer 139

0

Sign in to vote

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

Answer 140

0

Sign in to vote

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

Answer 141

0

Sign in to vote

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

Sub CapsON ()
Call SetKeyboardState(VbKeyCaps)
End sub

Sunday, May 20, 2007 8:49 AM

Answer 142

0

Sign in to vote

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

Answer 143

0

Sign in to vote

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

Answer 144

0

Sign in to vote

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

Answer 145

0

Sign in to vote

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

Answer 146

0

Sign in to vote

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

Answer 147

0

Sign in to vote

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

Answer 148

0

Sign in to vote

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

Answer 149

0

Sign in to vote

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

Answer 150

0

Sign in to vote

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

Answer 151

0

Sign in to vote

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

Answer 152

0

Sign in to vote

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

Answer 153

0

Sign in to vote

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

Answer 154

0

Sign in to vote

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

Answer 155

0

Sign in to vote

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

Answer 156

0

Sign in to vote

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

Answer 157

0

Sign in to vote

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

Answer 158

0

Sign in to vote

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

Answer 159

0

Sign in to vote

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

Answer 160

0

Sign in to vote

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

Answer 161

0

Sign in to vote

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

Answer 162

0

Sign in to vote

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

Answer 163

0

Sign in to vote

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

Answer 164

0

Sign in to vote

Code 73 : Detecting Browser TypeCode Snippet
<%
   Set MyBrowser=server.createobject("MSWC.Browsertype")
   response.write MyBrowser.Browser 
%>

Sunday, May 20, 2007 10:04 AM

Answer 165

0

Sign in to vote

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

Answer 166

0

Sign in to vote

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

Answer 167

0

Sign in to vote

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

Answer 168

0

Sign in to vote

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

Answer 169

0

Sign in to vote

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

Answer 170

0

Sign in to vote

Man Sanket you areawesome

really good codes

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

Answer 171

0

Sign in to vote

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

Answer 172

0

Sign in to vote

Thanks a lot my friend. , you are so kind.

Btw how was your quiz ? hope it went good.

Monday, May 21, 2007 3:56 AM

Answer 173

0

Sign in to vote

Hey Harshil,

My quiz really went good. How was yours ?

Thursday, May 24, 2007 2:47 PM

Answer 174

0

Sign in to vote

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

Answer 175

0

Sign in to vote

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

Answer 176

0

Sign in to vote

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

Answer 177

0

Sign in to vote

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

Answer 178

0

Sign in to vote

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

Answer 179

0

Sign in to vote

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

Answer 180

0

Sign in to vote

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

Answer 181

0

Sign in to vote

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

Answer 182

0

Sign in to vote

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

Answer 183

0

Sign in to vote

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

Answer 184

0

Sign in to vote

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

Answer 185

0

Sign in to vote

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

Answer 186

0

Sign in to vote

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

Answer 187

0

Sign in to vote

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

Answer 188

0

Sign in to vote

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

Answer 189

0

Sign in to vote

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

Answer 190

0

Sign in to vote

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

Answer 191

0

Sign in to vote

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

Answer 192

0

Sign in to vote

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

Answer 193

0

Sign in to vote

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

Answer 194

0

Sign in to vote

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

Answer 195

0

Sign in to vote

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

Answer 196

0

Sign in to vote

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

Answer 197

0

Sign in to vote

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

Answer 198

0

Sign in to vote

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

Answer 199

0

Sign in to vote

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

Answer 200

0

Sign in to vote

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

Answer 201

0

Sign in to vote

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

Answer 202

0

Sign in to vote

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

Answer 203

0

Sign in to vote

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

Answer 204

0

Sign in to vote

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

Answer 205

0

Sign in to vote

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

Answer 206

0

Sign in to vote

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

Answer 207

0

Sign in to vote

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

Answer 208

0

Sign in to vote

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

Answer 209

0

Sign in to vote

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

Answered by:

Forum for Helpful Visual Basic 6.0 Codes... Part 2

Question

Answers

All replies