Change the computer name

This will help you to change the computer name.
Works with VB6 and .net
The Code:
Declare Function SetComputerName Lib "kernel32" _
Alias "SetComputerNameA" (ByVal lpComputerName As String) As _
Long
Public Function ChangeComputerName(sNewComputerName As String) _
As Boolean

On Error Resume Next
Dim nReturn As Long

nReturn = SetComputerName(sNewComputerName)
If Err.Number = 0 Then
ChangeComputerName = nReturn <> 0
End If

End Function

Change the computer name

This will help you to change the computer name.
Works with VB6 and .net
The Code:
Declare Function SetComputerName Lib "kernel32" _
Alias "SetComputerNameA" (ByVal lpComputerName As String) As _
Long
Public Function ChangeComputerName(sNewComputerName As String) _
As Boolean

On Error Resume Next
Dim nReturn As Long

nReturn = SetComputerName(sNewComputerName)
If Err.Number = 0 Then
ChangeComputerName = nReturn <> 0
End If

End Function

Age Calculation with VB6 or .net

This is a simple utility to calculate age. e.g, if the age is 4 months then it will display in months, if age is 2 years it will display in years. Example of the DateDiff funtion in VB.

'Just place a command button and text box controls on your form.
'Enter a date of birth in the text box and it will calculate age based on the current date.
Private Sub Command1_Click()
If (Int(DateDiff("y", CDate(Text1.Text), Date)) / 365.25) > 1 Then
MsgBox Round((Int(DateDiff("y", CDate(Text1.Text), Date)) / 365.25)) & " Years"
Else
MsgBox (Mid((Int(DateDiff("y", CDate(Text1.Text), Date)) / 365.25), 1, 3)) * 10 & " Months"
End If
End Sub

A Sript to autodetect and map printers

This is part of a login script, used to automatically map printers in an Active Directory environment. It makes use of permissions set on the printer and active directory group assignments to work properly. If you have a printer “Kappa” that only “Site B” can print to, assign the “Site B” group with the ability to print, and remove the everyone entry. By creating an active directory group called “Kappa” consisting of people that can access the above said printer, this script will automatically set this printer to be their default. As a side note, the IsMember() function works recursively, allowing for nested group memberships.

The Script :

Set WSHNetwork = Wscript.CreateObject("Wscript.Network")

' set the local print server name here
Set servName = "printserv"

' remove old printers here
set cprinter=WSHnetwork.enumprinterconnections
for i=cprinter.count-1 to 1 step -2
on error resume next
if instr(cprinter.item(i),"[")<>0 or instr(cprinter.item(i),"\")<>0 then
WSHnetwork.removeprinterconnection cprinter.item(i)
end if
next


' this is the new manager for attaching printers.
' it enumerates all the printers on the server listed above
' and attempts to attach each of them.
' the ntfs settings for each device dictate which connections
' will be successful, and what is visible.
' the IsMember function (declared in the include.vbs above)
' is used to determine if a printer
' should be set as a default device.

Set cont = GetObject("WinNT://"&servName&",computer")
cont.Filter = Array("PrintQueue")
For Each printer In cont
On Error Resume Next

WScript.Echo "Adding: " & printer.Name
Output = WSHNetwork.AddWindowsPrinterConnection( printer.PrinterPath )
WScript.Echo Output
If IsMember( printer.name ) Then
WScript.Echo "Defaulting To:" & printer.Name
WSHNetwork.SetDefaultPrinter printer.PrinterPath
End If

Next


' The following code has been collected from usenet.

Function IsMember(strGroup)
If IsEmpty(objGroupList) Then
Set objGroupList = CreateObject("Scripting.Dictionary")
Call LoadGroups(objADObject)
End If
IsMember = objGroupList.Exists(strGroup)
End Function
Sub LoadGroups(oADObject)
Dim colstrGroups, objGroup, j
objGroupList.CompareMode = vbTextCompare
colstrGroups = oADObject.memberOf
If IsEmpty(colstrGroups) Then
Exit Sub
End If
If TypeName(colstrGroups) = "String" Then
Set objGroup = GetObject("LDAP://" & colstrGroups)
If Not objGroupList.Exists(objGroup.sAMAccountName) Then
objGroupList(objGroup.sAMAccountName) = True
Call LoadGroups(objGroup)
End If
Set objGroup = Nothing
Exit Sub
End If
For j = 0 To UBound(colstrGroups)
Set objGroup = GetObject("LDAP://" & colstrGroups(j))
If Not objGroupList.Exists(objGroup.sAMAccountName) Then
objGroupList(objGroup.sAMAccountName) = True
Call LoadGroups(objGroup)
End If
Next
Set objGroup = Nothing
End Sub

Google Adsense

Adsense is a contextual advertisement program run by Google, and I'm sure you've seen "Ads by Google" on a variety of websites (this is adsense in action). To get enlisted in Adsense is actually simpler that you might think. What you need to do is to create a blog (or site), publish some content (no junk please), and apply for Adsense.

Once approved, you can start making money without having to do that much. Just paste the code that Google gives you into your web-page and away you go. The code they give you is what creates the ads on your blog, or website. And when someone clicks on these ads they go to the advertiser's site listed in the adsense ads. The advertiser is then charged per-click by Google, then Google pays you a share of the money they get. It's as easy as that - and all done for you as part of the Adsense great service.

I mentioned "contextual advertisement" previously, what this means is that Adsense is smart enough to deliver ads that are relevant to your content automatically. Let's say you have a blog about dog training, you'll see ads about dog training on it. Google technology analyzes your content, decides what it's all about, then finds the ads that are most suitable for the content on your site.

By making Adsense ads relevant to your site, Google accomplishes two things: Ads can enhance overall experience of a visitor to your blog because they are relevant to your content, and they will link to other sites he will be interested in. And the best part is, you'll get paid for that person clicking the links in the adsense ads.

Google Groups Traffic for blogs and sites

Did you know that Google Groups can make for your blog more than 500 visitors daily for 1 week in just 3 hours ?

It can be strange, Google part ? Yes I made about 150 visitors in the first time and it was really strange. Google Groups will give you high traffic!

How to do:
first you need a Google Account then redirect to http://groups.google.com/
There start posting, try to use a good title and make your link appearent.
People that comes to the group will open and diret to your blog and then you get new visitors.
Strategy : Post only in groups that have a large number of members.
More : Google sendby email your post to members (thar registred to email posts!) This will help you make extra visitors.
Quantity : 1 post can make 5 visitors in a 1000 members group.
Try to make as much as you can to get extra visitors.
Famous Groups:
http://groups.google.com/group/Blogger-Review
http://groups.google.com/group/grkist
http://groups.google.com/group/sap2jobs
http://groups.google.com/group/Free-Ads-For-You

Add and Retrieve Multiple Values to the Registry

This demo shows how to add and retrieve multiple settings to the registry. The two encapsulated procedures make it easy to quickly add these functions to any app. The demo uses the code for storing to the registry and showing most recently accessed files. It insures only one occurrence of a given value and arranges the values with the most currently accessed value on top.

Download Sample

Registry Handler for VB6

Methods: - DeleteKey --> Deletes key AND all underlying keys
- DeleteValue
- EnumKeys --> Enumerate all keys from a specified key
- EnumValues --> Enumerate all values from a specified key
- GetRegValue --> Reads a value from any specified key
- WriteRegValue --> Writes a value to any specified key

Download Sample

Register/ Unregister Multiple OCXs/DLLs at The Same Time

This utility allows you to register or unregister 1 or more self-registering Dlls and ocx's at the same time.
Download Sample

Read and modify the registry

Modifying the registry with VB.net is quite easy but with VB 6 and VB 5 it's difficult so I browse and found this sample that can helps you.
Download Sample

Call Webservice from VB6

I needed to call a webservice I built in C# from an old application made in VB6. Using SOAP was not an option, so I decided to use MSXML2 to prepare and send my own XML code. MSXML2 comes with IE6, and most users already have it installed, but just in case, I used late binding for MSXML2. Comments preceed each block of code. See comments in Command1_Click method for further details.

Private Sub Command1_Click()
' Start Internet Explorer and type in the url of your webservice page
' i.e.: http://localhost/myweb/mywebService.asmx
' In that page, click on the link to the method you want to call from your application
' Select in upper POST section the xml code from
' Copy this into the strXml variable, escape all quotes and replace "string" your parameter value
' Copy the url to your webservice page (asmx) to the strUrl variable
' Copy the SOAPAction value to the strSoapAction variable

Dim strSoapAction As String
Dim strUrl As String
Dim strXml As String
Dim strParam As String

txtOutput.Text = ""
strParam = "MyParameterString"
strUrl = "http://localhost/myweb/mywebService.asmx"
strSoapAction = "http://tempuri.org/MyMethod"


strXml = "" & _
"" & _
"" & _
"" & _
"" & strParam & "" & _
"" & _
"" & _
""

' Call PostWebservice and put result in text box
Debug.Print PostWebservice(strUrl, strSoapAction, strXml)

End Sub


Private Function PostWebservice(ByVal AsmxUrl As String, ByVal SoapActionUrl As String, ByVal XmlBody As String) As String
Dim objDom As Object
Dim objXmlHttp As Object
Dim strRet As String
Dim intPos1 As Integer
Dim intPos2 As Integer

On Error GoTo Err_PW

' Create objects to DOMDocument and XMLHTTP
Set objDom = CreateObject("MSXML2.DOMDocument")
Set objXmlHttp = CreateObject("MSXML2.XMLHTTP")

' Load XML
objDom.async = False
objDom.loadXML XmlBody

' Open the webservice
objXmlHttp.open "POST", AsmxUrl, False

' Create headings
objXmlHttp.setRequestHeader "Content-Type", "text/xml; charset=utf-8"
objXmlHttp.setRequestHeader "SOAPAction", SoapActionUrl

' Send XML command
objXmlHttp.send objDom.xml

' Get all response text from webservice
strRet = objXmlHttp.responseText

' Close object
Set objXmlHttp = Nothing

' Extract result
intPos1 = InStr(strRet, "Result>") + 7
intPos2 = InStr(strRet, " If intPos1 > 7 And intPos2 > 0 Then
strRet = Mid(strRet, intPos1, intPos2 - intPos1)
End If

' Return result
PostWebservice = strRet

Exit Function
Err_PW:
PostWebservice = "Error: " & Err.Number & " - " & Err.Description

End Function

Calling an API Function From VB.NET

This snippet calls the GetSystemDirectory API function in VB.NET and shows how to use the StringBuilder class to create a string buffer for API functions that require it. See comments within code for more information.

Put this at the top of your module.
'Required in all cases when calling API functions
Imports System.Runtime.InteropServices

'Required in this example and any API function which
'use a string buffer. Provides the StringBuilder class

Imports System.Text

'Put these declarations right under the class declaration
'(e.g., in a Form, right under Public Class Form1)

SetLastError:=True, CharSet:=CharSet.Unicode, _
ExactSpelling:=True, _
CallingConvention:=CallingConvention.StdCall)> _
Public Shared Function GetSystemDirectory(ByVal Buffer _
As StringBuilder, ByVal Size As Integer) As Long
' Leave function empty - DLLImport attribute
' forces calls to GetSystemDirectory to
' be forwarded to GetSystemDirectory in KERNEL32.DLL
End Function

Public Const MAX_PATH As Integer = 256

'How to call the API function:

Dim s As New StringBuilder(MAX_PATH)

GetSystemDirectory(s, MAX_PATH)
msgbox(s.ToString(), , "System Directory")

Accessing LDAP using VB.NET

Option Explicit On
Imports System.DirectoryServices

Public Function GetLDAPUsers(ByVal ldapServerName As String, ByVal pFindWhat As String) As ArrayList
Dim oSearcher As New DirectorySearcher
Dim oResults As SearchResultCollection
Dim oResult As SearchResult
Dim RetArray As New ArrayList
Dim mCount As Integer
Dim mIdx As Integer
Dim mLDAPRecord As String

Dim ResultFields() As String = {"securityEquals", "cn"}

Try
With oSearcher
.SearchRoot = New DirectoryEntry("LDAP://" & ldapServerName & _
"/dc=lippogeneral,dc=com")
.PropertiesToLoad.AddRange(ResultFields)
.Filter = "cn=" & pFindWhat & "*"
oResults = .FindAll()
End With

mCount = oResults.Count
If mCount > 0 Then
For Each oResult In oResults
mLDAPRecord = oResult.GetDirectoryEntry().Properties("cn").Value & " " & oResult.GetDirectoryEntry().Properties("mail").Value
RetArray.Add(mLDAPRecord)
Next
End If
Catch e As Exception

MsgBox("Error is " & e.Message)
Return RetArray

End Try

Return RetArray

End Function

A Function To Simplify ExecuteNonQuery Statements

Use this function to simplify ExecuteNonQuery. Normally, you need to setup a command and connection objects, which this code does. Just pass the SQL statement and the connection object that points to your database.

Function ExecuteSQL(ByVal sSQL As String, ByVal dbOLE As OleDb.OleDbConnection) As Integer
Dim command As New OleDb.OleDbCommand(sSQL, dbOLE)
If command.Connection.State = ConnectionState.Closed Then command.Connection.Open()
Command.CommandType = CommandType.Text
ExecuteSQL = command.ExecuteNonQuery()
command.Connection.Close()
Application.DoEvents()
End Function

Get a list of all Fonts

'This will get all of the available fonts on the computer and add

'them to the 'cmbFont' combobox control.

Dim f As System.Drawing.Text.InstalledFontCollection = New _

System.Drawing.Text.InstalledFontCollection

Dim fFamily As FontFamily

For Each fFamily In f.Families

lst.Items.Add(fFamily.Name)

Next

Remove Extra Space from a string

Quickly remove extra whitespace from inside a string.

Function fSQLSpalten(ByVal sSpaltenZeile$) As String

sSpaltenZeile = Trim(sSpaltenZeile)
Do While InStr(1, sSpaltenZeile, " ") > 0
sSpaltenZeile = fReplace(sSpaltenZeile, " ", " ")
Loop
fSQLSpalten = sSpaltenZeile
End Function

Auto File BackUp with VB.net

This code keeps backup of three different locations at a time in regular interval as per set by the user. It also works through network.

'For this Application you need:
'1. 3 Check Boxes.
'2. 6 text Boxes.
'3. 5 Command Buttons.
'4. 3 Combo Boxes.
'5. 6 Progressbar Controls.
'6. 3 File List Box Controls.
'7. 1 ImageList control.
'8. 3 Timer Controls

'N.B:(Controls that are directly involved with the code is mentioned above.)

Dim fln, root, fld, val, val1, val2 As String

Private Sub Check1_Click()
On Error GoTo err:
If Check1.Value = 1 Then
Text1.Enabled = True
Text4.Enabled = True
Text1.SetFocus
Else
Text1.Enabled = False
Text4.Enabled = False
End If
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub Check2_Click()
On Error GoTo err:
If Check2.Value = 1 Then
Text2.Enabled = True
Text5.Enabled = True
Text2.SetFocus
Else
Text2.Enabled = False
Text5.Enabled = False
End If
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub Check3_Click()
On Error GoTo err:
If Check3.Value = 1 Then
Text3.Enabled = True
Text6.Enabled = True
Text3.SetFocus
Else
Text3.Enabled = False
Text6.Enabled = False
End If
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub Command1_Click()
On Error GoTo err:
File1.path = Text1.Text
MkDir Text4.Text
Label6.Caption = File1.path & " (" & File1.ListCount & ") files."
val = 60 * Combo1.Text
Pr4.Max = val
Exit Sub
err:
MsgBox "Directory Already created", vbExclamation
End Sub

Private Sub Command2_Click()
On Error GoTo err:
File2.path = Text2.Text
MkDir Text5.Text
Label7.Caption = File2.path & " (" & File2.ListCount & ") files."
val1 = 60 * Combo2.Text
Pr5.Max = val1
Exit Sub
err:
MsgBox "Directory Already created", vbExclamation
End Sub

Private Sub Command3_Click()
On Error GoTo err:
File3.path = Text3.Text
MkDir Text6.Text
Label8.Caption = File3.path & " (" & File3.ListCount & ") files."
val2 = 60 * Combo2.Text
Pr6.Max = val2
Exit Sub
err:
MsgBox "Directory Already created", vbExclamation
End Sub

Private Sub Command4_Click()
On Error GoTo err:
If Len(Text4.Text) > 0 Then
Timer1.Enabled = True
Else
Timer1.Enabled = False
End If
If Len(Text5.Text) > 0 Then
Timer2.Enabled = True
Else
Timer2.Enabled = False
End If
If Len(Text6.Text) > 0 Then
Timer3.Enabled = True
Else
Timer3.Enabled = False
End If
err:
MsgBox err.Description, vbCritical
End Sub

Private Sub Command5_Click()
On Error GoTo err:
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Text5.Text = ""
Text6.Text = ""
Exit Sub
err:
MsgBox err.Description, vbCritical
End Sub

Private Sub ex_Click()
On Error GoTo err:
Dim i As Integer
i = MsgBox("Before Quiting make sure that all Backup Processes are stopped" & vbCrLf & "Are sure to quit?", vbYesNo + vbQuestion)
If i = vbYes Then
Unload Me
Else
End If
Exit Sub
err: MsgBox err.Description
End Sub

Private Sub File1_Click()
On Error GoTo err:
fld = File1.path
fln = File1.FileName
root = fld & "\" & fln
FileCopy root, Text4.Text & "\" & fln
Pr1.Value = Pr1.Value + 1
If Pr1.Value >= Pr1.Max Then
Pr1.Value = 0
End If
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub File2_Click()
On Error GoTo err:
fld = File2.path
fln = File2.FileName
root = fld & "\" & fln
FileCopy root, Text5.Text & "\" & fln
Pr2.Value = Pr2.Value + 1
If Pr2.Value >= Pr2.Max Then
Pr2.Value = 0
End If
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub File3_Click()
On Error GoTo err:
fld = File3.path
fln = File3.FileName
root = fld & "\" & fln
FileCopy root, Text6.Text & "\" & fln
Pr3.Value = Pr3.Value + 1
If Pr3.Value >= Pr3.Max Then
Pr3.Value = 0
End If
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub Form_Load()
On Error GoTo err:
Dim i As Integer
For i = 0 To 120 Step 2
Combo1.AddItem i
Combo2.AddItem i
Combo3.AddItem i
Next i
Text1.Enabled = False
Text2.Enabled = False
Text3.Enabled = False
Text4.Enabled = False
Text5.Enabled = False
Text6.Enabled = False
Command1.Enabled = False
Command2.Enabled = False
Command3.Enabled = False
Command4.Enabled = False
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error GoTo err:
Dim i As Integer
i = MsgBox("Before Quiting make sure that all Backup Processes are stopped" & vbCrLf & "Are sure to quit?", vbYesNo + vbQuestion)
If i = vbYes Then
Cancel = 0
Else
Cancel = 1
End If
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub hlp_Click()
MsgBox "Change Mode: F1" & vbCrLf & "NetDel: F2" & vbCrLf & "Refresh: F5" & vbCrLf & "Restore: F6", vbInformation, "DelMas: Help"
End Sub

Private Sub Text4_Change()
On Error GoTo err:
If Len(Text4.Text) >= 0 Then
Command1.Enabled = True
Command4.Enabled = True
Else
Command1.Enabled = False
End If
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub Text5_Change()
On Error GoTo err:
If Len(Text5.Text) >= 0 Then
Command2.Enabled = True
Else
Command2.Enabled = False
End If
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub Text6_Change()
On Error GoTo err:
If Len(Text6.Text) >= 0 Then
Command3.Enabled = True
Else
Command3.Enabled = False
End If
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub selectAll1()
On Error GoTo err:
Dim i As Integer
For i = 0 To Me.File1.ListCount - 1
Me.File1.Selected(i) = True
Next i
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub selectAll2()
On Error GoTo err:
Dim i As Integer
For i = 0 To Me.File2.ListCount - 1
Me.File2.Selected(i) = True
Next i
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub
Private Sub selectAll3()
On Error GoTo err:
Dim i As Integer
For i = 0 To Me.File3.ListCount - 1
Me.File3.Selected(i) = True
Next i
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub Timer1_Timer()
On Error GoTo err:
Pr1.Max = File1.ListCount
Label6.Caption = File1.path & " (" & File1.ListCount & ") files."
Pr4.Value = Pr4.Value + 1
Label9.Caption = "Backing up after " & Pr4.Value & " seconds..."
If Pr4.Value >= Pr4.Max Then
selectAll1
Pr4.Value = 0
End If
File1.Refresh
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub Timer2_Timer()
On Error GoTo err:
Pr2.Max = File2.ListCount
Label7.Caption = File2.path & " (" & File2.ListCount & ") files."
Pr5.Value = Pr5.Value + 1
Label10.Caption = "Backing up after " & Pr5.Value & " seconds..."
If Pr5.Value >= Pr5.Max Then
selectAll2
Pr5.Value = 0
File2.Refresh
End If
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub Timer3_Timer()
On Error GoTo err:
Pr3.Max = File3.ListCount
Label8.Caption = File3.path & " (" & File3.ListCount & ") files."
Pr6.Value = Pr6.Value + 1
Label11.Caption = "Backing up after " & Pr6.Value & " seconds..."
If Pr6.Value >= Pr6.Max Then
selectAll3
Pr6.Value = 0
End If
File3.Refresh
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
On Error GoTo err:
If Button.Index = 1 Then
If Len(Text4.Text) > 0 Then
Timer1.Enabled = True
Else
Timer1.Enabled = False
End If
If Len(Text5.Text) > 0 Then
Timer2.Enabled = True
Else
Timer2.Enabled = False
End If
If Len(Text6.Text) > 0 Then
Timer3.Enabled = True
Else
Timer3.Enabled = False
End If
ElseIf Button.Index = 2 Then
PopupMenu stp
ElseIf Button.Index = 3 Then
PopupMenu pbp
ElseIf Button.Index = 4 Then
Unload Me
End If
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub


Private Sub Toolbar1_ButtonMenuClick(ByVal Button As MSComctlLib.ButtonMenu)
On Error GoTo err:
If Button.Index = 1 Then
Timer1.Enabled = True
ElseIf Button.Index = 2 Then
Timer2.Enabled = True
ElseIf Button.Index = 3 Then
Timer3.Enabled = True
End If
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub t1_Click()
On Error GoTo err:
Timer1.Enabled = False
Pr4.Value = 0
Label9.Caption = ""
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub t2_Click()
On Error GoTo err:
Timer2.Enabled = False
Pr5.Value = 0
Label10.Caption = ""
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub t3_Click()
On Error GoTo err:
Timer3.Enabled = False
Pr6.Value = 0
Label11.Caption = ""
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub Tsk1_Click()
On Error GoTo err:
Timer1.Enabled = False
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub tsk2_Click()
On Error GoTo err:
Timer2.Enabled = False
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Private Sub tsk3_Click()
On Error GoTo err:
Timer3.Enabled = False
Exit Sub
err: MsgBox err.Description, vbCritical
End Sub

Open Acrobat Reader

How to open Acrobat in One click !

Imports System.Diagnostics

Public Class Form1

Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click

Dim proc As New Process()

With proc.StartInfo
.Arguments = "Your PDF Path eg:- C:\MyFiles\Ebook2007.pdf"
.UseShellExecute = True
.WindowStyle = ProcessWindowStyle.Maximized
.WorkingDirectory = "C:\Program Files\Adobe\Reader 8.0\Reader\" '<----- Set Acrobat Install Path
.FileName = "AcroRd32.exe" '<----- Set Acrobat Exe Name
End With

proc.Start()
proc.Close()
proc.Dispose()

End Sub

End Class

List View Example

This code will sum-up the value of a listview and save the entire list of a listview in just one click.

Dim scon As ADODB.Connection
Dim srec As ADODB.Recordset
Dim slist As ListItem
Dim sum As Double
Private Sub Command2_Click()
Dim sql As String
Dim x
sum = 0

For x = 1 To ListView1.ListItems.Count

sum = sum + CDbl(ListView1.ListItems.Item(x).SubItems(2))

sql = "insert into salary2 (idno,name,salary) values "
sql = sql & "(" & CLng(ListView1.ListItems.Item(x)) & ",'"
sql = sql & ListView1.ListItems.Item(x).SubItems(1) & "',"
sql = sql & CDbl(ListView1.ListItems.Item(x).SubItems(2)) & ")"

scon.Execute sql
Next x

Set slist = ListView1.ListItems.Add(, , " ")
Set slist = ListView1.ListItems.Add(, , "")
slist.SubItems(1) = "Total is==> P"
slist.SubItems(2) = Format(sum, "##,##0.00")

MsgBox "save record"

End Sub

Private Sub Form_Load()
Set scon = New ADODB.Connection
scon.Open "Provider=microsoft.jet.oledb.4.0;" & _
"Data source=" & App.Path & "\sum.mdb"

displayrec

End Sub
Sub displayrec()
Set srec = New ADODB.Recordset
srec.Open "select * from salary", scon, adOpenDynamic, adLockPessimistic
If srec.EOF Then Exit Sub
Do While Not srec.EOF
Set slist = ListView1.ListItems.Add(, , srec(0))
slist.SubItems(1) = srec!Name
slist.SubItems(2) = Format(srec!salary, "##,##0.00")
srec.MoveNext
Loop
End Sub

Upload file with ASP.NET

emember to import the system.file namespace
Also you will have to add a upload file server control to your html code. Like this.



The Code :

If FileUpload1.HasFile Then
FileUpload1.SaveAs(Server.MapPath("The_Name_Of_The_File"))
End If

Prime Number Generation

A console Application

Module Module1

Sub Main()
Dim n As Integer
Dim i As Integer
Dim flag As Boolean
For n = 1 To 50
flag = True
For i = 2 To n / 2
If n Mod i = 0 Then
flag = False
End If
Next
If flag Then
Console.WriteLine(n)
End If
Next
Console.ReadLine()
End Sub

End Module

Creating a line and displaying angle

using System;
using Autodesk.AutoCAD.Runtime;
using Autodesk.AutoCAD.ApplicationServices;
using Autodesk.AutoCAD.Colors;
using Autodesk.AutoCAD.DatabaseServices;
using Autodesk.AutoCAD.EditorInput;
using Autodesk.AutoCAD.Geometry;
using Autodesk.AutoCAD.GraphicsInterface;
using Autodesk.AutoCAD.Windows;
using System.Windows.Forms;



[assembly: CommandClass(typeof(ClassLibrary.Class))]

namespace ClassLibrary
{
///

/// Summary description for Class.
///

public class Class :IExtensionApplication
{
private static Editor pEditor;
public static Line pLine;
public Class()
{

}

[CommandMethod("lian")]
static public void test()
{
Database pDatabase = HostApplicationServices.WorkingDatabase;
Editor pEditor = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument.Editor;
Autodesk.AutoCAD.DatabaseServices.TransactionManager pTransactionManager = pDatabase.TransactionManager;
Transaction pTransaction = pTransactionManager.StartTransaction();
try
{
//for creating a line
Autodesk.AutoCAD.DatabaseServices.Line pLine = new Line();
PromptPointOptions pPromptPointOptions1 = new PromptPointOptions("enter first point of line");
PromptPointResult pPromptPointResult1 = pEditor.GetPoint(pPromptPointOptions1);
PromptPointOptions pPromptPointOptions2 = new PromptPointOptions("enter second point of line");
PromptPointResult pPromptPointResult2 = pEditor.GetPoint(pPromptPointOptions2);
pLine.StartPoint = pPromptPointResult1.Value;
pLine.EndPoint = pPromptPointResult2.Value;

BlockTable pBlockTable = pTransaction.GetObject(pDatabase.BlockTableId, OpenMode.ForRead, false) as BlockTable;
BlockTableRecord pBlockTableRecord = pTransaction.GetObject(pBlockTable[BlockTableRecord.ModelSpace], OpenMode.ForWrite, false) as BlockTableRecord;
ObjectId objId = pBlockTableRecord.AppendEntity(pLine);
pTransaction.AddNewlyCreatedDBObject(pLine, true);

//to get text
Point3d pPoint3d = new Point3d((pLine.StartPoint.X + pLine.EndPoint.X) / 2, (pLine.StartPoint.Y + pLine.EndPoint.Y ) / 2, 0.0);
DBText pDBText = new DBText();
pDBText.VerticalMode = TextVerticalMode.TextBottom;
pDBText.HorizontalMode = TextHorizontalMode.TextCenter;
pDBText.Height = 0.5;

//to find angle btwn to points
double angle = Angle(pLine.StartPoint, pLine.EndPoint);
//for getting angle in degrees upto 4 decimals
pDBText.TextString = "Angle = " + Converter.DistanceToString(angle * (180.0 / Math.PI), DistanceUnitFormat.Decimal, 4);

pDBText.Rotation = angle;
pDBText.AlignmentPoint = pPoint3d;
objId = pBlockTableRecord.AppendEntity(pDBText);
pTransaction.AddNewlyCreatedDBObject(pDBText, true);

}
catch (System.Exception pException)
{
pEditor.WriteMessage(pException.ToString());
}
finally
{

pTransaction.Commit();
}
pTransaction.Dispose();
}

public static double Angle(Point3d firPnt, Point3d secPnt)
{
double lineAngle;
if (firPnt.X == secPnt.X)
{
if (firPnt.Y < secPnt.Y)
lineAngle = Math.PI / 2.0;
else
lineAngle = (Math.PI / 2.0) * 3.0;
}
else
{
lineAngle = Math.Atan((secPnt.Y - firPnt.Y) / (secPnt.X - firPnt.X));
if (firPnt.X > secPnt.X)
lineAngle = Math.PI + lineAngle;
else
if (lineAngle < 0.0)
lineAngle = (Math.PI * 2.0) + lineAngle;
}
return (lineAngle);
}

#region IExtensionApplication Members

public void Initialize()
{
MessageBox.Show("application loaded");
}

public void Terminate()
{

}

#endregion
}
}

Finiding Maximum Value on an Array

This code will show you how your going to find and display the maximum value in your array.


The Code:
'You will need a FORM and a command button

Option Explicit
Dim A(20), num, i, j, max As Integer

Private Sub Command1_Click()
Print "Your array contains:"
For i = 0 To num - 1
Print A(i)
Next i
Print "Maximum Value= "; max
End Sub
Private Sub Form_Load()
num = InputBox("Initialize your array [1-20]:")

For i = 0 To num - 1
A(i) = InputBox("Enter your array:")
Next i

'find maximum
max = A(0)
For i = 0 To num - 1
If max < A(i) Then
max = A(i)
End If
Next
End Sub

Catch Win32 Services

The following code will allow you to catch running Win32Services

The Code:
Option Explicit On

Imports System
Imports System.Management

Public Class Form1

Private MgClass As New Management.ManagementClass("Win32_Service")

Private Sub ButtonLoadServices_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles ButtonLoadServices.Click

Try
Me.Cursor = Cursors.WaitCursor

ListView1.Items.Clear()

Label3.Text = ""
Label5.Text = ""
Label7.Text = ""
Label9.Text = ""

ButtonLoadServices.Enabled = False
ButtonLoadServices.Refresh()

Label1.Text = "0% Complete."
Label1.Refresh()

With ProgressBar1
.Value = 0
.Minimum = 0
.Maximum = MgClass.GetInstances().Count
.Refresh()
End With

For Each obj As Management.ManagementObject In MgClass.GetInstances()
Application.DoEvents()

Dim MHeader As New ListViewItem()
Dim SHeader As New ListViewItem.ListViewSubItem()

MHeader.Text = obj.GetPropertyValue("Caption").ToString

If obj.GetPropertyValue("Description") <> "" Then
SHeader.Text = obj.GetPropertyValue("Description").ToString()
End If

ListView1.Items.Add(MHeader).SubItems.Add(SHeader)

ProgressBar1.Value += 1
ProgressBar1.Refresh()

Label1.Text = ((ProgressBar1.Value / ProgressBar1.Maximum) * 100).ToString("0.00") & "% Complete."
Label1.Refresh()
Next

ButtonLoadServices.Enabled = True
ButtonLoadServices.Refresh()
Me.Cursor = Cursors.Default
Catch ex As Exception
MessageBox.Show(ex.Message, "Error", MessageBoxButtons.OK, MessageBoxIcon.Error)
ButtonLoadServices.Enabled = True
ButtonLoadServices.Refresh()
Me.Cursor = Cursors.Default
End Try

End Sub

Private Sub ListView1_AfterLabelEdit(ByVal sender As System.Object, ByVal e As System.Windows.Forms.LabelEditEventArgs) Handles ListView1.AfterLabelEdit

e.CancelEdit = True

End Sub

Private Sub ListView1_BeforeLabelEdit(ByVal sender As System.Object, ByVal e As System.Windows.Forms.LabelEditEventArgs) Handles ListView1.BeforeLabelEdit

e.CancelEdit = True

End Sub

Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load

Label3.Text = ""
Label5.Text = ""
Label7.Text = ""
Label9.Text = ""

End Sub

Private Sub ListView1_MouseClick(ByVal sender As System.Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles ListView1.MouseClick

Dim SelectItem As String = ""
Dim SelRow As Integer = 0

Try
Me.Cursor = Cursors.WaitCursor

SelRow = ListView1.SelectedItems.Item(0).Index

SelectItem += """"
SelectItem += ListView1.Items.Item(SelRow).Text.ToString()
SelectItem += """"

Dim SelQuery As New SelectQuery("Win32_Service", "Caption=" & SelectItem & "")
Dim ObjectSearcher As New ManagementObjectSearcher(SelQuery)

For Each service As ManagementObject In ObjectSearcher.Get()
Label3.Text = service.GetPropertyValue("PathName")
Label5.Text = service.GetPropertyValue("ServiceType")
Label7.Text = service.GetPropertyValue("StartMode")
Label9.Text = service.GetPropertyValue("State")
Exit For
Next

SelQuery = Nothing
ObjectSearcher.Dispose()
Me.Cursor = Cursors.Default
Catch ex As Exception
MessageBox.Show(ex.Message, "Error", MessageBoxButtons.OK, MessageBoxIcon.Error)
Me.Cursor = Cursors.Default
End Try

End Sub

End Class

Regular Expression Tester

This is a simple Regular Expression Tester.


Imports System.Text.RegularExpressions
Public Class Form1

Private Function TestRegularExpression(ByVal TestValue As Object, ByVal TestPattern As String) As Boolean

TestRegularExpression = False

If Regex.IsMatch(TestValue, TestPattern) Then
TestRegularExpression = True
Else
TestRegularExpression = False
End If

Return TestRegularExpression

End Function

Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click

Dim Ans As Boolean = False

Try

Ans = TestRegularExpression(TextBox2.Text.ToString().Trim(), TextBox1.Text.ToString().Trim())

If Ans = True Then
MessageBox.Show("Correct", "Regular Expressions", MessageBoxButtons.OK, MessageBoxIcon.Information)
Else
MessageBox.Show("Not Correct", "Regular Expressions", MessageBoxButtons.OK, MessageBoxIcon.Exclamation)
End If

Catch ex As Exception

MessageBox.Show(ex.Message, "Error ...", MessageBoxButtons.OK, MessageBoxIcon.Error)

End Try

Prime Number Generation

Open Visual Basic (.net) and create a new Console Application

Paste the following code and run !

Module Module1

Sub Main()
Dim n As Integer
Dim i As Integer
Dim flag As Boolean
For n = 1 To 50
flag = True
For i = 2 To n / 2
If n Mod i = 0 Then
flag = False
End If
Next
If flag Then
Console.WriteLine(n)
End If
Next
Console.ReadLine()
End Sub

End Module

Addition of the Digg Button

After a long search I found the method to add the Digg button to all the posts of the Blog.
Don't forget to Digg anypost you found helpful !

New Site Skin !

Hi,
I just fixed a new skin!! What do you think of it?

How to check a valid IP Address

Another idea to check an IP Address format

The Code:

'will make the text black if its a valid IP address
'or red if its not

Private Sub Text1_Change()
Text1.ForeColor = 255
If IsIP(Text1.Text) Then Text1.ForeColor = 0
End Sub



'place this part in a module
Public Function IsIP(TestAddress As String) As Boolean

Dim IPt As String
Dim TQ As Long
Dim TT As Long
Dim TW As Long
Dim IPTemp As Long

IsIP = False 'Set return value as false

On Error GoTo cockup
'if an error occures the string is not valid

If Left(TestAddress, 1) = "." Then Exit Function
If Right(TestAddress, 1) = "." Then Exit Function
'check first and last are not "."

For TQ = 1 To Len(TestAddress) 'test all chars
IPt = Mid(TestAddress, TQ, 1)
If IPt <> "." Then 'if its not a "." it must be 0-9
If Asc(IPt) > 57 Or Asc(IPt) < 48 Then Exit Function
End If
Next TQ

TQ = InStr(1, TestAddress, ".", vbTextCompare)
'find the three dots
TT = InStr(TQ + 1, TestAddress, ".", vbTextCompare)
TW = InStr(TT + 1, TestAddress, ".", vbTextCompare)
If InStr(TW + 1, TestAddress, ".", vbTextCompare) <> 0 Then Exit Function
'if there is a fourth then the string is invalid

'test each number is between 0 and 255
IPTemp = Val(Left(TestAddress, TQ - 1))
If IPTemp > 255 Or IPTemp < 0 Then Exit Function

IPTemp = Val(Mid(TestAddress, TQ + 1, TT - TQ - 1))
If IPTemp > 255 Or IPTemp < 0 Then Exit Function

IPTemp = Val(Mid(TestAddress, TT + 1, TW - TT - 1))
If IPTemp > 255 Or IPTemp < 0 Then Exit Function

IPTemp = Val(Right(TestAddress, Len(TestAddress) - TW))
If IPTemp > 255 Or IPTemp < 0 Then Exit Function

IsIP = True 'it has passed all tests so make it true

cockup:
End Function

Read the Content of XML file into the DataSet

This is the inverse of the last post!

The code :
Imports System
Imports System.Data
Imports System.Data.SqlClient

Private Sub btnReadXMLData_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnReadXMLData.Click

Dim dsPubs As New DataSet()

' Read in XML from file
dsPubs.ReadXml("Pubs.xml")

' Bind DataSet to Data Grid
grdData.DataMember = "publishers"
grdData.DataSource = dsPubs

End Sub

Hope it helps and good luck, any suggestion or questions post a comment !

How to save a DataSet As XML File

This is a cool idea to save a DataSet as XML file with VB.net, So far you can convert an SQL DataBase to XML format.

The code :
Private Sub btnWriteXMLData_Click(ByVal sender As System.Object, _
ByVal e As System.EventArgs) Handles btnWriteXMLData.Click
Dim dsSales As New DataSet()
Dim cn As New SqlConnection _
("data source=localhost;initial catalog=pubs;user id=sa")
Dim daAuthors As New SqlDataAdapter("select * from sales ", cn)
Dim daPublishers As New SqlDataAdapter("select * from stores ", cn)

' Load data from database
daAuthors.Fill(dsSales, "Sales")
daPublishers.Fill(dsSales, "Stores")

' Write XML to file
dsSales.WriteXml("XMLFile.xml")

End Sub

Hope it helps and good luck, any suggestion or questions post a comment !

Create a CSV File with VB

Hi friends,

This is a method to create a CSV file with VB6.
To make it with vb2005 just upgrade the code with the vb2005 tool

The Code :

Dim nfile As Integer
Dim conx as Integer

Private Sub cmdExport_Click()

nfile = FreeFile
ProgressBar1.Value = 1
Open "filea" For Output As #nfile

For conx = 1 To nbr
StatusBar1.Panels(1).Text = CInt(conx * 100 / nbr) & "% completed"

'Print to file each field of the structure "Customer"
Print #nfile, conx & ", " & Customer(conx).Field1 & ", " & Customer(conx).Field2 & ", " & Customer(conx).Field3 & ", " & Customer(conx).Field4 & ", " & Customer(conx).Field5 & ", " & Customer(conx).Field6 & ", "
ProgressBar1.Value = conx * 100 / nbr

Next conx

Close #nfile
FileCopy "filea", App.Path & "\ExportedFile.csv"
Kill "filea"

If err.Number = 0 Then

MsgBox "File exported to working directory!"
Else
MsgBox "Error exporting file: " & err.Number
End If
End Sub

'The data structure has to be defined like this one:
Type Customer

Field1 as String
Field2 as String

'You can add as many fields as you need
...
End Type


Hope it helps and good luck, any suggestion or questions post a comment !

Show/Hide the System Tray

This a good and short code to show and hide the Windows Tray.
It compatible with VB6 and also .net

Declaration :
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _
ByVal nCmdShow As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 Const Tray_SHOW = 5
Private Const Tray_HIDE = 0
Dim Trayhwnd As Long
Code :
Private Sub Form_Load()
Trayhwnd = FindWindow("Shell_TrayWnd", "")
Trayhwnd = FindWindowEx(Trayhwnd, 0, "TrayNotifyWnd", vbNullString)
ShowWindow Trayhwnd, Tray_HIDE 'To Hide
'To show the System Tray add this code insteed of above
'ShowWindow Trayhwnd, Tray_SHOW 'To Show
End Sub

How to use text files with VB.net

Hi there!

This is a small tutorial on using files with VB.net.
As VB.net uses new technologies it will be strange for some new developers!

First we must import the Syste.IO Class
Imports System.IO

Reading Text Files:
the easiest way to open a text file is with the System.IO.File.OpenText() method.



Code:'Dim your StreamReader
Dim TextFileStream As System.IO.TextReader



'Load the textfile into the stream
TextFileStream = System.IO.File.OpenText("C:\MyTextFile.txt")



'Read to the end of the file into a String variable.
Dim MyFileContents As String = TextFileStream.ReadToEnd



'Close the Stream object
TextFileStream.Close()



The above code will open a text file on your C drive called MyTextFile.txt. It will load all of the text into a string variable called MyFileContents.
It won't create a file of that name if it doesn't already exist (and will throw an exception which you should handle - but see later in the FAQ for how to create a new file).




Creating Text Files:



Code:'Dim your Text Writer
Dim TW As System.IO.TextWriter



'Create a Text file and load it into the TextWriter
TW = System.IO.File.CreateText("C:\MyTextFile.txt")



'Write a line
TW.WriteLine("Hello World")



'Write another line
TW.WriteLine("Hello World Again")



'Flush the text to the file
TW.Flush()



'Close the File
TW.Close()




Append to an existing Text file:



Code:'Dim your Stream Writer or Text Writer.
Dim SW As IO.TextWriter



'Open a file for Appending
SW = IO.File.AppendText("C:\MyTextFile.txt")



'Write a line to the bottom of the text file
SW.WriteLine("This is another line added to the bottom of the text file.")



'Flush to the file
SW.Flush()



'Close the object
SW.Close()



Here is how to get a random line from a text file with the smallest code I can think of.
Extracting One Line From a File:



Code:Dim RandomNumber As New Random()
Dim Tr As IO.TextReader = System.IO.File.OpenText("C:\MyTextFile.txt")
Dim FileLines() As String = Split(Tr.ReadToEnd(), vbCrLf)
Tr.Close
Dim MyRandomLine As String = FileLines(RandomNumber.Next(0, UBound(FileLines)))
MsgBox(MyRandomLine)



If you know what line you want to access then you can make it smaller like this :



Code:
Dim Tr As IO.TextReader = System.IO.File.OpenText("C:\MyTextFile.txt")
Dim MyFileLine As String = Split(Tr.ReadToEnd(), vbCrLf)(3)
Tr.Close
MsgBox(MyFileLine)



Note that the above code will return the fourth line from the file. It's zero based, so you would enter (0) for line 1, (1) for line 2 and so on.


If you need more, I advice you to focus on the MSDN Library!

Solution for Base Conversion

Option Explicit

'Variables to hold Old Base Type and New Base Type
Private OldBase As Integer
Private NewBase As Integer

>In the form load:

Private Sub Form_Load()
'Initialize Old and New Base Type to Decimal
OldBase = 10
NewBase = 10
End Sub

>in the textbox named txtnumber
Private Sub txtNumber_KeyPress(KeyAscii As Integer)
'If the key is NOT Backspace or Delete or Left or Right
If KeyAscii <> vbKeyBack Then
'Determine the Base Type are we dealing with
Select Case OldBase
Case 2
'Only allow Binary numbers to be entered (0-1)
If KeyAscii <> vbKey1 Then
KeyAscii = 0
End If
Case 8
'Only allow Octal numbers to be entered (0-7)
If KeyAscii <> vbKey7 Then
KeyAscii = 0
End If
Case 10
'Only allow Decimal numbers to be entered (0-9)
If KeyAscii <> vbKey9 Then
KeyAscii = 0
End If
Case 16
'Only allow Hexidecimal numbers to be entered (0-9 & A-F)
If KeyAscii <> vbKey9 Then
If KeyAscii <> vbKeyF Then
'If a-f then change to A-F
If KeyAscii >= 97 And KeyAscii <= 102 Then
KeyAscii = KeyAscii - 32
Else
KeyAscii = 0
End If
End If
End If
End Select
End If
End Sub


>in the option buttons (oct, hex, decimal,bin) named optNumber:

Private Sub optNumber_Click(Index As Integer)
Dim OldNumber As String
Dim NewNumber As String

OldNumber = txtNumber.Text

NewBase = optNumber(Index).Tag

Select Case NewBase
Case 2
txtNumber.MaxLength = 50
Case 8
txtNumber.MaxLength = 17
Case 10
txtNumber.MaxLength = 15
Case 16
txtNumber.MaxLength = 13
End Select

'If Base Type was clicked but no numbers entered then
'change Old and New Base to the Type selected and exit
If OldNumber = "" Then
OldBase = NewBase
Exit Sub
End If

'Determine the Base Type combo we are dealing with
Select Case True
Case OldBase = 2 And NewBase = 2 'Binary & Binary
NewNumber = OldNumber
Case OldBase = 2 And NewBase = 8 'Binary & Octal
NewNumber = Dec2Base(Base2Dec(OldNumber, OldBase), NewBase)
Case OldBase = 2 And NewBase = 10 'Binary & Decimal
NewNumber = Base2Dec(OldNumber, OldBase)
Case OldBase = 2 And NewBase = 16 'Binary & Hexidecimal
NewNumber = Dec2Base(Base2Dec(OldNumber, OldBase), NewBase)

Case OldBase = 8 And NewBase = 2 'Octal & Binary
NewNumber = Dec2Base(Base2Dec(OldNumber, OldBase), NewBase)
Case OldBase = 8 And NewBase = 8 'Octal & Octal
NewNumber = OldNumber
Case OldBase = 8 And NewBase = 10 'Octal & Decimal
NewNumber = Base2Dec(OldNumber, OldBase)
Case OldBase = 8 And NewBase = 16 'Octal & Hexidecimal
NewNumber = Dec2Base(Base2Dec(OldNumber, OldBase), NewBase)

Case OldBase = 10 And NewBase = 2 'Decimal & Binary
NewNumber = Dec2Base(OldNumber, NewBase)
Case OldBase = 10 And NewBase = 8 'Decimal & Octal
NewNumber = Dec2Base(OldNumber, NewBase)
Case OldBase = 10 And NewBase = 10 'Decimal & Decimal
NewNumber = OldNumber
Case OldBase = 10 And NewBase = 16 'Decimal & Hexidecimal
NewNumber = Dec2Base(OldNumber, NewBase)

Case OldBase = 16 And NewBase = 2 'Hexidecimal & Binary
NewNumber = Dec2Base(Base2Dec(OldNumber, OldBase), NewBase)
Case OldBase = 16 And NewBase = 8 'Hexidecimal & Octal
NewNumber = Dec2Base(Base2Dec(OldNumber, OldBase), NewBase)
Case OldBase = 16 And NewBase = 10 'Hexidecimal & Decimal
NewNumber = Base2Dec(OldNumber, OldBase)
Case OldBase = 16 And NewBase = 16 'Hexidecimal & Hexidecimal
NewNumber = OldNumber
End Select

txtNumber.Text = NewNumber
OldBase = NewBase
End Sub


>private function:

Private Function Dec2Base(ByVal DecNum, ByVal Base) As String
Dim NHD As Double
Dim HN As String

'Convert until done
While DecNum <> 0
'Get the largest number of the Base Type
NHD = DecNum - (Int(DecNum / Base) * Base)
'Find it's converted Base number then concatenate
'to the beginning of the resulting string
HN = Mid("0123456789ABCDEF", NHD + 1, 1) & HN
'Subtract the amount we converted
DecNum = Int(DecNum / Base)
Wend

'Return our new number in the requested Base Type
Dec2Base = HN
End Function


>another private function:

Private Function Base2Dec(BaseNum As String, ByVal Base) As String
Dim BN As Double
Dim i As Double
Dim j As Double

BN = 0
j = 1

'Step from Right to Left of the numbers
For i = Len(BaseNum) To 1 Step -1
'Determine what number we are dealing with then
'multiply its value by the power of the Base Type
'then add it to the total resulting value
Select Case UCase(Mid(BaseNum, i, 1))
Case "0"
BN = BN + j * 0
Case "1"
BN = BN + j * 1
Case "2"
BN = BN + j * 2
Case "3"
BN = BN + j * 3
Case "4"
BN = BN + j * 4
Case "5"
BN = BN + j * 5
Case "6"
BN = BN + j * 6
Case "7"
BN = BN + j * 7
Case "8"
BN = BN + j * 8
Case "9"
BN = BN + j * 9
Case "A"
BN = BN + j * 10
Case "B"
BN = BN + j * 11
Case "C"
BN = BN + j * 12
Case "D"
BN = BN + j * 13
Case "E"
BN = BN + j * 14
Case "F"
BN = BN + j * 15
End Select
'Multiply our Base Type Power times the Base to get our next power
j = j * Base
Next i

'Return our new number in Decimal format
Base2Dec = Trim(Str(BN))
End Function

How to get the number of days in a month

This is a good idea to get the number of days of any month

'For current month...

MsgBox DateAdd("m", 1, Now) - Now

'For some other month (Example: June)

Dim FirstDate As Date
FirstDate = "01/06/2006"
MsgBox DateAdd("m", 1, FirstDate) - FirstDate

Another way to eject a CD

This is another way to easily eject CD in only 5 line of code.

Private Sub Form_Load()
Call eject
End Sub

Public Sub eject()
'code to eject cdrom ok
Dim owmp As Object
Dim colCDROMs
Set owmp = CreateObject("WMPlayer.OCX.7")
Set colCDROMs = owmp.cdromCollection
If colCDROMs.Count >= 1 Then
For i = 0 To colCDROMs.Count - 1
colCDROMs.Item(i).eject
Next
End If
End Sub

Search Text in a database

This code will help you search any text in a database and show it in a datagridview
Create a button named utOk, a text box named txtName and a datagrid named Datagrid1.

Private Sub butOk_Click(ByValsender As System.Object, ByVal e As System.EventArgs) Handles but_ok.Click
Dim strConnection As String = "Data Source=your SQL data source;Initial Catalog=your database; Integrated Security=True"
Dim cn As SqlClient.SqlConnection = New SqlClient.SqlConnection(strConnection)
Dim ds As New DataSet
Dim strSelect As String
'strSelect As String
strSelect = "SELECT * FROM " & YourTable & " WHERE [Search Field] = '" & Me.txtName.Text & "'"
Dim dscmd As New SqlClient.SqlDataAdapter(strSelect, cn)
dscmd.Fill(ds, "your table")
Me.Datagrid1.DataSource = ds
Me.Datagrid1.DataMember = "your table"
Dim con As Integer
con = Me.BindingContext(ds, "your table").Count
If con = 0 Then
MessageBox.Show("Recourd could not be found")
End If
End Sub

How to Eject a CD or DVD

This short code Snippet will help you eject a CD or DVD using Windows Media Player API

Public Class frmEject
'you need window media player reference in your project
'1 combo box
' 2 button control
Dim omal As New WMPLib.WindowsMediaPlayer
Dim total As Integer
Dim i As Integer

Private Sub Form1_FormClosing(ByVal sender As Object, ByVal e As System.Windows.Forms.FormClosingEventArgs) Handles Me.FormClosing
omal.close()
End Sub
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
total = 0
i = 0
total = omal.cdromCollection.count
If (total >= 1) Then
For i = 0 To (total - 1)
ComboBox1.Items.Add(omal.cdromCollection.Item(i).driveSpecifier)
Next
ComboBox1.Text = ComboBox1.Items.Item(0)
End If
MyBase.CenterToScreen()
End Sub

Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
If Not (ComboBox1.Text = "") Then
omal.cdromCollection.Item(ComboBox1.SelectedIndex).eject()
End If
End Sub

Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
For i = 0 To (total - 1)
omal.cdromCollection.Item(i).eject()
Next
End Sub
End Class

Finding Maximum Value

This code will show you how your going to find and display the maximum value in your array.

'You will need a FORM and a command button

Option Explicit
Dim A(20), num, i, j, max As Integer
Private Sub Command1_Click()
Print "Your array contains:"
For i = 0 To num - 1
Print A(i)
Next i
Print "Maximum Value= "; max
End Sub
Private Sub Form_Load()
num = InputBox("Initialize your array [1-20]:")

For i = 0 To num - 1
A(i) = InputBox("Enter your array:")
Next i

'find maximum
max = A(0)
For i = 0 To num - 1
If max < A(i) Then
max = A(i)
End If
Next
End Sub

Try Windows Live Space

Good I'm Back Again
I had just tried out Windows Live Space. There you can make a home page very customizable and you can include many gadget. The thing that I loved is to include the blog summary or photo of my friends in MSN on the Blog. I liked it so much, plus you can include HTML and Script Text.
Just have a look @ my space : http://omarabid.spaces.live.com

Exam Finished

Yeah I've just finished school exams, but oof I didn't do well in this term.
I know I have much since my lastet posts, but I think I have to start a new project.
Now I don't have time, it's true that I have about 15 days of holiday, but I must also take care of my studies.
And now happy holidays for all students.