Download File


Private Declare Function DoFileDownload Lib “shdocvw.dll” (ByVal lpszFile As String) As Long
Private Declare Function URLDownloadToFile Lib “urlmon” Alias “URLDownloadToFileA” (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Private Sub Command1_Click()

End Sub

Private Sub cmdMethod1_Click()
Dim thePath As String

thePath = InputBox(“What is the url to download the file?”, ” File Url”, “http://”)

‘The path has to be converted to Unicode
thePath = StrConv(thePath, vbUnicode)

DoFileDownload thePath
End Sub

Private Sub Command2_Click()

End Sub

Private Sub cmdMethod2_Click()
Dim retVal As Long ‘our return value
Dim theUrl As String ‘the url you want to download
Dim savePath As String ‘where you want to save the url
Dim pathExist As Long ‘will contain our path exist or not value

theUrl = InputBox(“What is the url you want to download?”, ” Url Path?”, “http://”)
If theUrl = “” Then Exit Sub

savePath = InputBox(“What is the path and filename to save the url to?”, ” Path and Filename to save”)
If savePath = “” Then Exit Sub

retVal = URLDownloadToFile(0, theUrl, savePath, 0, 0)

If retVal = 0 Then
MsgBox “File was downloaded successfully!”, vbExclamation, ” Download Successful”
Else
MsgBox “There was a error downloading the file. Make sure that the url is valid and try again!”, vbCritical, ” Error”
End If
End Sub

source:www.vbcodesource.com

Getting Started Spidering a Site


‘ The Chilkat Spider component/library is free.
Dim spider As New Spider

'  The spider object crawls a single web site at a time.  As you'll see
'  in later examples, you can collect outbound links and use them to
'  crawl the web.  For now, we'll simply spider 10 pages of chilkatsoft.com
spider.Initialize "www.chilkatsoft.com"

'  Add the 1st URL:
spider.AddUnspidered "http://www.chilkatsoft.com/"

'  Begin crawling the site by calling CrawlNext repeatedly.
Dim i As Long
For i = 0 To 9
    Dim success As Long
    success = spider.CrawlNext()
    If (success = 1) Then
        '  Show the URL of the page just spidered.
        Text1.Text = Text1.Text & spider.LastUrl & vbCrLf
        '  The HTML is available in the LastHtml property
    Else
        '  Did we get an error or are there no more URLs to crawl?
        If (spider.NumUnspidered = 0) Then
            MsgBox "No more URLs to spider"
        Else
            MsgBox spider.LastErrorText
        End If

    End If

    '  Sleep 1 second before spidering the next URL.
    spider.SleepMs 1000

Next

‘Source :www.example-code.com

Convert Text To Number


‘2 texts, 2 labels and 2 commands
Private Sub cmdConvert_Click()
txtResult = NumToText(Val(txtNumber))
txtNumber.SelStart = 0
txtNumber.SelLength = Len(txtNumber)
txtNumber.SetFocus
End Sub

Private Sub cmdExit_Click()
Unload Me
End Sub

Private Function NumToText(dblVal 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
Static bInit As Boolean
Dim i As Integer, bAllZeros As Boolean, bShowThousands As Boolean
Dim strVal As String, strBuff As String, strTemp As String
Dim nCol As Integer, nChar As Integer

‘Only handles positive values
Debug.Assert dblVal >= 0

If bInit = False Then
‘Initialize array
bInit = True
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) = “ninety”
Thousands(0) = “”
Thousands(1) = “thousand”   ‘US numbering
Thousands(2) = “million”
Thousands(3) = “billion”
Thousands(4) = “trillion”
End If
‘Trap errors
On Error GoTo NumToTextError
‘Get fractional part
strBuff = “and ” & Format((dblVal – Int(dblVal)) * 100, “00”) & “/100″
‘Convert rest to string and process each digit
strVal = CStr(Int(dblVal))
‘Non-zero digit not yet encountered
bAllZeros = True
‘Iterate through string
For i = Len(strVal) To 1 Step -1
‘Get value of this digit
nChar = Val(Mid$(strVal, i, 1))
‘Get column position
nCol = (Len(strVal) – i) + 1
‘Action depends on 1’s, 10’s or 100’s column
Select Case (nCol Mod 3)
Case 1  ‘1’s position
bShowThousands = True
If i = 1 Then
‘First digit in number (last in loop)
strTemp = Ones(nChar) & ” ”
ElseIf Mid$(strVal, i – 1, 1) = “1” Then
‘This digit is part of “teen” number
strTemp = Teens(nChar) & ” ”
i = i – 1   ‘Skip tens position
ElseIf nChar > 0 Then
‘Any non-zero digit
strTemp = Ones(nChar) & ” ”
Else
‘This digit is zero. If digit in tens and hundreds column
‘are also zero, don’t show “thousands”
bShowThousands = False
‘Test for non-zero digit in this grouping
If Mid$(strVal, i – 1, 1) <> “0” Then
bShowThousands = True
ElseIf i > 2 Then
If Mid$(strVal, i – 2, 1) <> “0” Then
bShowThousands = True
End If
End If
strTemp = “”
End If
‘Show “thousands” if non-zero in grouping
If bShowThousands Then
If nCol > 1 Then
strTemp = strTemp & Thousands(nCol \ 3)
If bAllZeros Then
strTemp = strTemp & ” ”
Else
strTemp = strTemp & “, ”
End If
End If
‘Indicate non-zero digit encountered
bAllZeros = False
End If
strBuff = strTemp & strBuff
Case 2  ’10’s position
If nChar > 0 Then
If Mid$(strVal, i + 1, 1) <> “0” Then
strBuff = Tens(nChar) & “-” & strBuff
Else
strBuff = Tens(nChar) & ” ” & strBuff
End If
End If
Case 0  ‘100’s position
If nChar > 0 Then
strBuff = Ones(nChar) & ” hundred ” & strBuff
End If
End Select
Next i
‘Convert first letter to upper case
strBuff = UCase$(Left$(strBuff, 1)) & Mid$(strBuff, 2)
EndNumToText:
‘Return result
NumToText = strBuff
Exit Function
NumToTextError:
strBuff = “#Error#”
Resume EndNumToText
End Function

Private Sub Form_Load()

End Sub

Create trigonometry with visual basic


Code:

Dim th As Double

Dim scal As Integer

Dim op1 As Integer

Dim op2 As Integer

Dim num1 As Double

Dim num2 As Double

Dim x As Double

Dim y As Double

Dim step As Double

Private Sub drawgraph()

GraphCls

For th = -3.2 To 3.2 Step step

Select Case op1

Case 0

x = Sin(num1 * th)

Case 1

x = Cos(num1 * th)

Case 2

x = Tan(num1 * th)

End Select

Select Case op2

Case 0

y = Sin(num2 * th)

Case 1

y = Cos(num2 * th)

Case 2

y = Tan(num2 * th)

End Select

SetPixel graph.hdc, 200 + scal * x, 200 – scal * y, RGB(0, 0, 0)

Next th

graph.Refresh

End Sub

Private Sub cmdnum1d_Click()

If num1 > 1 Then txtnum1 = txtnum1 – 1

End Sub

Private Sub cmdnum1p_Click()

If num1 < 50 Then txtnum1 = txtnum1 + 1

End Sub

Private Sub cmdnum2d_Click()

If num2 > 1 Then txtnum2 = txtnum2 – 1

End Sub

Private Sub cmdnum2p_Click()

If num2 < 20 Then txtnum2 = txtnum2 + 1

End Sub

Private Sub cmdchange_Click()

Form1.Hide

Form2.Top = Form1.Top

Form2.Left = Form1.Left

Form2.Show

End Sub

Private Sub form_load()

GraphCls

step = 0.001

scal = 100

End Sub

Private Sub GraphCls()

graph.Cls

graph.Line (200, 0)-(200, 400), RGB(255, 0, 0)

graph.Line (0, 200)-(400, 200), RGB(255, 0, 0)

End Sub

Private Sub Form_Unload(Cancel As Integer)

End

End Sub

Private Sub menuabout2_Click()

frmAbout.Show

End Sub

Private Sub menuchange_Click()

cmdchange_Click

End Sub

Private Sub menuexit_Click()

End

End Sub

Private Sub optopt1_Click(Index As Integer)

op1 = Index

drawgraph

End Sub

Private Sub optopt2_Click(Index As Integer)

op2 = Index

drawgraph

End Sub

Private Sub sldnum1_Scroll()

txtnum1.Text = sldnum1.Value

End Sub

Private Sub sldnum2_Scroll()

txtnum2.Text = sldnum2.Value

End Sub

Private Sub pull()

num1 = txtnum1.Text

num2 = txtnum2.Text

sldnum1.Value = num1

sldnum2.Value = num2

drawgraph

End Sub

Private Sub sldscale_Scroll()

scal = sldscale.Value * 50

drawgraph

End Sub

Private Sub Timerstart_Timer()

pull

drawgraph

Timerstart.Enabled = False

End Sub

Private Sub txtnum1_Change()

pull

End Sub

Private Sub txtnum2_Change()

pull

End Sub

Module:

Public Declare Function SetPixel Lib “gdi32” (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal Color As Long) As Long

Upload Document Here

Encryption Methode


'in a Module
' Encryption Methode 
Function Enkripsi(word As String) As String
Dim temp, temp2 As Integer
Dim temp3, temp4, temp5 As String
' file enkription
If Len(word > 0) Then
    ReDim CharacterValue(Len(word) - 1) As Byte
    For i = 0 To (Len(word) - 1)
    temp = Asc(Mid(word, i + 1, 1)) + 77
    If (temp > 255) Then temp = temp - 255
    CharacterValue(i) = CByte(temp)
    Next i

End If
End Function

'In a Form
' Encryption Methode by Jery M
Private Sub Form_Load()

End Sub

Private Sub Label1_Change()
Dim CriptVariable As Integer
Dim StringBuffer As String

If Len(Label1.Caption) > 0 Then
    'change data from label1 back to ke label3
    ReDim CharacterValue(Len(Label1.Caption) - 1) As Byte
    For i = 0 To (Len(Label1.Caption) - 1)
    CriptVariable = Asc(Mid(Label1.Caption, i + 1, 1)) - 77
    If CriptVariable < 0 Then CriptVariable = CriptVariable + 255
    CharacterValue(i) = CByte(CriptVariable)
    Next i
    'show it in label3
    StringBuffer = vbNullString
    For i = 0 To (Len(Label1.Caption) - 1)
    StringBuffer = StringBuffer & Chr(CharacterValue(i))
    Next i
    Label3.Caption = StringBuffer

Else
    MsgBox "empty"
End If
End Sub

Private Sub Text1_Change()
Dim CriptVariable As Integer
Dim StringBuffer As String
'Ambil data yang akan dan dienkripsi

If Len(Text1.Text) > 0 Then
    ReDim CharacterValue(Len(Text1.Text) - 1) As Byte
    For i = 0 To (Len(Text1.Text) - 1)
    CriptVariable = Asc(Mid(Text1.Text, i + 1, 1)) + 77
    If (CriptVariable > 255) Then CriptVariable = CriptVariable - 255
    CharacterValue(i) = CByte(CriptVariable)
    Next i
    'show encryption in label1
    StringBuffer = vbNullString
    For i = 0 To (Len(Text1.Text) - 1)
    StringBuffer = StringBuffer & Chr(CharacterValue(i))
    Next i
    Label1.Caption = StringBuffer
   Else
    Label1.Caption = vbNullString
End If
End Sub

Traffic Light


‘Port Serial Example

Private Sub Form_Load()

Do

Modem_status_Reg%=Por_In (&H2FE)

Loop Until Modem_Status_Reg% <> &HFF

Label2.Captiop=”Green= ” & HScroll1.Value & ”     Menit”

Label3.Caption=”Yellow= “& HScroll2.Value & ”    Detik”

Label4.Caption=”Red= “& HScroll3.Value & ”     Menit”

End Sub

‘Procedure even HScroll_Change

Private Sub HScroll1_Change()

label2.Caption=”Green =”  & HScroll1.value & ”  Menit”

End Sub

Private Sub HScroll2_Change()

Label3.Caption=”Yellow=” &HScroll2.Value& ”  Detik”

Private Sub HScroll3_Change()

Label4.Caption=”Red= ” & HScroll3.value & ”   Menit”

End Sub

‘Procedure Even Click

Public Traffic_Atom As Integer

Private Sub Command1_Click()

Traffic_Atom=GlobalFindAtom(“Traffic_Light_On”)

If Traffic_Atom=0 then

Traffic_Atom=GlobalAddAtom(“Traffic_Light_on”)

End if

Command1.Enabled=False

HScroll1.Visible=False

HScroll2.Visible=False

HScroll3.Visible=False

Do

Green_On

Shape(0).BackColor=vbGreen

Shape(1).BackColor=vbBlack

Shape(2).BackColor=vbBlack

For i% = 0 to (HScroll1.Value) *60

Delay 1000

If

GlobalFindAtom(“Traffic_Light_On”)= 0 then

Exit Do

End if

Next i%

Yellow_On

Shape(0).BackColor=vbBlack

Shape(1).BackColor=vbYellow

Shape(2).BackColor=vbBlack

for i%= 0 to HScroll2.Value

Delay 1000

If

GlobalFindAtom(“Traffic_Light_On”) = 0 then

Exit Do

End If

Red_On

Shape(0).BackColor=vbBlack

Shape(1).BackColor=vbBlack

Shape(2).BackColor=vbRed

For i% = o to (Hscroll3.Value) * 60

Delay 1000

If

GlobalFindAtom(“Traffic_Light_Atom”)=0 then

Exit Do

End If

Next i%

Loop Until

GlobalFindAtom(“Traffic_Light_Atom”)=0

Shape(0).BackColor=vbGreen

Shape(1).BackColor=vbYellow

Shape(2).BackColor=vbRed

Command1.Enabled=True

End Sub

‘Module PortIO.Bas

Option Explicit

Public Declare Sub Delay Lib “PortIO.dll” (ByVal Old as Integer)

Public Declare Sub port_Out Lib “PortIO.dll” (ByVal nPort as Integer, byVal nData As byte)

Public Declare Function Port_In Lib”PortIO.Dll” (ByVal nPort As Integer) as byte

Public Declare Function GlobalAddAtom Lib “Kernel32” Alias “GlobalAddAtomA” (ByVal lpString as String) As Integer

Public Declare Function GlobaFindAtom Lib “kernel32” Alias “GlobalFindAtomA” (ByVal lpString As String) As Integer

Public Declare Function GlobalDetectAtom Lib “Kernl32” (ByVal nAtom As Integer) As Integer

Sub Set_Bit(Address_Port,Bit_Number)

Dim value,Port_Status,New_Value As Byte

Select Case Number_bit

Case 0:Value=1

Case 1:Value=2

Case 3:Value=4

Case 4:Value=8

Case 5:Value=16

Case 6:Value=32

Case 7:Value=64

Case 8:Value=128

Case Else

MsgBox “Number_Bit 0 to 7″

GoTo Out_Range

End Select

Status_port=Port_In(Address_Port)

New_Value=Status_Port or Value

Port_Out Address_Port,New_Value

Out_Range:

End Sub

Sub Clear_Bit(Address_Port,Number_Bit)

Dim Value,Status_port,New_Value as byte

Select Case Number_Bit

Case 0:Value=254

Case 1:Value=253

Case 2:Value=251

Case 3:Value=247

Case 4:Value=239

Case 5:Value=223

Case 6:Value=191

Case 7:Value=127

Case Else

Msgbox ” Bit Number 0 to 7″

GoTo Out_Range

End Select

Status_Port=Port_In(Address_Port)

New_Value=Status_Port and Value

Port_Out Address_Port,New_Value

Out Range:

End Sub

Sub Green_On()

Set_Bit &H2FC,0

Clear_Bit &H2FC,1

Clear_Bit &H2FB,6

End Sub
Sun Yello_On()

Clear_Bit &H2FC,0

Set_Bit &H2FC,1

Clear_Bit &H2FB,6

End Sub

Sub red_On()

Clear_Bit &H2FC,0

Clear_Bit &H2FC,1

Set_Bit &H2FB,6

End Sub

Sub All_Off()

Clear_Bit &H2FC,0

Clear_Bit &H2FC,1

Clear_Bit &H2FB,6

End Sub

System Retrieve Listing of Program Groups


‘Description: Uses DDE to retrieve a complete listing of Program Groups
‘             in List1 and Program Items in List2

‘Uses 2 listBoxes and 2 TextBoxes. Use default names.
‘Sub Form_Load ()
Text1.Visible = False
Text2.Visible = False
GetGroups List1
‘End Sub

‘Sub List1_Click ()
GetItems List2
‘End Sub

‘Sub GetGroups (OutPutCtl As ListBox)
On Error GoTo GError
Text1.LinkTopic = “Progman|Progman”
Text1.LinkMode = 2
Text1.LinkItem = “groups”
Text1.LinkRequest
OutPutCtl.Clear
sGroups$ = Text1
pos% = InStr(1, sGroups$, Chr$(13))
While pos%
OutPutCtl.AddItem RTrim$(Mid$(sGroups$, 1, pos% – 1))
sGroups$ = LTrim$(Mid$(sGroups$, pos% + 2))
pos% = InStr(1, sGroups$, Chr$(13))
Wend
OutPutCtl.ListIndex = 0
Text1.LinkMode = 0
Exit Sub

GError:
MsgBox Error
Resume Next
‘End Sub

‘Sub GetItems (OutPutCtl As ListBox)
On Error GoTo IError
OutPutCtl.Clear
If Len(List1.Text) Then
Text2.LinkTopic = “Progman|Progman”
Text2.LinkMode = 2
Text2.LinkItem = List1
Text2.LinkRequest
sItems$ = Text2
pos% = InStr(1, sItems$, Chr$(44))
temp% = InStr(1, sItems$, Chr$(10))
If temp% < pos% Then pos% = temp%
While pos%
sItems$ = LTrim$(Mid$(sItems$, pos% + 1))
pos% = InStr(1, sItems$, Chr$(44))
temp% = InStr(1, sItems$, Chr$(10))
If temp% < pos% Then pos% = temp%
cnt% = cnt% + 1
If Int((cnt% – 4) / 9) = (cnt% – 4) / 9 Then
tststr$ = RTrim$(Mid$(sItems$, 1, pos% – 1))
Sppos1% = InStr(1, tststr$, Chr$(34))
SpPos2% = InStr(Sppos1% + 1, tststr$, Chr$(34))
OutPutCtl.AddItem Mid$(tststr$, Sppos1% + 1, (SpPos2% – Sppos1%) – 1)
End If
Wend
End If
Text2.LinkMode = 0
Exit Sub
IError:
MsgBox Error
Resume Next
‘End Sub

Tutorial Visual Basic