Jam Analog
‘Buat Form dan 1 Timer
Option Explicit
Dim xgen, ygen, xmin, ymin, xsec, ysec, xhor, yhor As Double
Dim h, m, s As Date
‘control the minute ‘
Function mint()
If s >= 0 And s < 12 Then
Call findminangle(CDbl(m))
ElseIf s >= 12 And s < 24 Then
Call findminangle(CDbl(m) + 0.2)
ElseIf s >= 24 And s < 36 Then
Call findminangle(CDbl(m) + 0.4)
ElseIf s >= 36 And s <= 48 Then
Call findminangle(CDbl(m) + 0.6)
ElseIf s >= 48 And s <= 59 Then
Call findminangle(CDbl(m) + 0.8)
End If
xmin = xgen
ymin = ygen
Line (Form1.ScaleWidth / 2, Form1.ScaleHeight / 2)-(xmin, ymin), RGB(255, 24, 32)
End Function
‘control the second
Function secnd()
Call findminangle(CDbl(s))
xsec = xgen
ysec = ygen
Line (Form1.ScaleWidth / 2, Form1.ScaleHeight / 2)-(xsec, ysec), RGB(100, 100, 100)
End Function
‘control the hour
Function hr()
If m >= 0 And m < 12 Then
Call findminangle(CDbl(h) * 5)
ElseIf m >= 12 And m < 24 Then
Call findminangle(5 * (CDbl(h) + 0.2))
ElseIf m >= 24 And m < 36 Then
Call findminangle(5 * (CDbl(h) + 0.4))
ElseIf m >= 36 And m < 48 Then
Call findminangle(5 * (CDbl(h) + 0.6))
ElseIf m >= 48 And m <= 59 Then
Call findminangle(5 * (CDbl(h) + 0.8))
End If
xhor = xgen
yhor = ygen
If xhor >= Form1.ScaleWidth / 2 And yhor >= Form1.ScaleHeight / 2 Then
Line (Form1.ScaleWidth / 2, Form1.ScaleHeight / 2)-(xhor – 200, yhor – 200), RGB(0, 0, 255)
ElseIf xhor <= Form1.ScaleWidth / 2 And yhor >= Form1.ScaleHeight / 2 Then
Line (Form1.ScaleWidth / 2, Form1.ScaleHeight / 2)-(xhor + 200, yhor – 200), RGB(0, 0, 255)
ElseIf xhor <= Form1.ScaleWidth / 2 And yhor <= Form1.ScaleHeight / 2 Then
Line (Form1.ScaleWidth / 2, Form1.ScaleHeight / 2)-(xhor + 200, yhor + 200), RGB(0, 0, 255)
ElseIf xhor >= Form1.ScaleWidth / 2 And yhor <= Form1.ScaleHeight / 2 Then
Line (Form1.ScaleWidth / 2, Form1.ScaleHeight / 2)-(xhor – 200, yhor + 200), RGB(0, 0, 255)
End If
End Function
‘draw the clock
Function drawdig()
Dim i As Integer
Circle (Form1.ScaleWidth / 2, Form1.ScaleHeight / 2), 1411, RGB(255, 34, 34)
For i = 5 To 60
Call findminangle(CDbl(i))
Form1.CurrentX = xgen – TextWidth(i / 5) / 2
Form1.CurrentY = ygen – TextWidth(i / 5) / 2
Form1.Print i / 5
i = i + 4
Next
End Function
‘find the co-ordinate
Function findminangle(p As Double)
Dim temp As Double
temp = 60 – (p – 15)
temp = temp * 60 * 0.1
temp = (22 * temp) / (7 * 180)
xgen = (Form1.ScaleWidth / 2) + (1000 * Cos(temp))
ygen = (Form1.ScaleHeight / 2) – (1000 * Sin(temp))
End Function
Private Sub Timer1_Timer()
Form1.Cls
Call drawdig
Form1.Caption = Time()
h = Hour(Time())
m = Minute(Time())
s = Second(Time())
Call mint
Call secnd
Call hr
End Sub
Melihat Data Excell dengan VB
Private Sub Command1_Click()
Dim i As Integer
Dim j As Integer
Dim k As Integer
j = Val(Text2.Text)
k = Val(Text3.Text)
Set xlBook = GetObject(Text1.Text)
List1.Clear
For i = 1 To k
List1.AddItem xlBook.WorkSheets(1).Cells(i, j).Value
Next
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
Private Sub File1_Click()
Text1.Text = File1.Path & “\” & File1.FileName
End Sub
Private Sub Form_Load()
File1.Pattern = “*.xls”
End Sub
Melihat Code Character
Private Function ChrCode(txt As String) As String
Dim x As Long
Dim outstring As String
For x = 1 To Len(txt$)
outstring$ = outstring$ + “Chr(” + CStr(Asc(Mid(txt$, x, 1))) + “) + “
Next x
outstring$ = Trim(outstring$)
outstring$ = Mid(outstring$, 1, Len(outstring$) – 2)
ChrCode$ = outstring$
End Function
Private Sub Command1_Click()
If Text1 = “” Then Exit Sub
Text2.Text = ChrCode(Text1.Text)
End Sub
Private Sub Command2_Click()
Text1.Text = “”
End Sub
Private Sub Command3_Click()
If Text2 = “” Then Exit Sub
Clipboard.SetText Text2.Text
End Sub
Private Sub Command4_Click()
Text2.Text = “”
End Sub
Private Sub Form_Unload(Cancel As Integer)
Unload Me
End
End Sub
Posted by Administrator in 03:49:08 | Permalink | No Comments »
Friday, March 14, 2008
Belajar Input Teks di List
Private Sub cmdHapus_Click()
LstList.RemoveItem (LstList.ListIndex)
End Sub
Private Sub cmdHapusSemua_Click()
LstList.Clear
End Sub
Private Sub cmdInput_Click()
LstList.AddItem txtInput.Text
txtInput.Text = “”
End Sub
Private Sub cmdKeluar_Click()
End
End Sub
Posted by Administrator in 09:04:21 | Permalink | No Comments »
Monday, March 10, 2008
Counter Time
Private Sub Command1_Click()
intbatas = 5
Me.Timer1.Interval = 1000
Me.Timer1.Enabled = True
End Sub
Private Sub Command2_Click()
intbatas = 5
Dim inttout As Integer
Dim dtm As Date
dtm = DateAdd(“s”, intbatas, Now)
Do Until Now >= dtm
DoEvents
inttout = Second(dtm) – Second(Now)
Me.Caption = “TimeOut:” & inttout
Loop
Unload Me
End Sub
Private Sub Timer1_Timer()
intbatas = intbatas – 1
If intbatas <= 0 Then
Me.Timer1.Enabled = False
Unload Me
Else
Me.Caption = “TimeOut:” & intbatas
End If
End Sub
Posted by Administrator in 08:41:29 | Permalink | Comments (1) »
Program Load Gambar
Private Sub Command1_Click()
With Me.CommonDialog1
.DialogTitle = “Ambil Gambar”
.Filter = “JPEG|*.jpg”
.ShowOpen
If .FileName <> “” Then
Set Me.Picture1.Picture = Nothing
Me.Picture1.Picture = LoadPicture(.FileName)
End If
End With
End Sub
‘Private Sub Form_Load()
‘Me.Picture1.Picture = LoadPicture(“D:\gbr_motor\bikes_honda_01.jpg”)
‘End Sub
Posted by Administrator in 08:31:20 | Permalink | No Comments »
Saturday, March 8, 2008
Radio Tuner Dengan VB
‘Thank’s Mackay for your sharing about Radio Tuner with VB
‘by Peter
Form
Option Explicit
‘Sintonizador de emisoras de radios
‘latinas en internet.
‘Creado por E. Mackay D. feb. 2008
Dim nEmisora As String
Dim nRadioPais As String
Private Sub cmdEscuchar_Click()
On Local Error Resume Next
If cmdEscuchar.Caption = “Escuchar” Then
Image1(0) = Image1(1) ‘Rojo
Tuneador.Enabled = False
cmdEscuchar.Caption = “Detener”
WMPradio.URL = nEmisora
WMPradio.Controls.Play
Else
cmdEscuchar.Caption = “Escuchar”
Image1(0) = Image1(3) ‘Gris
Tuneador.Enabled = True
WMPradio.Controls.Stop
Escuchar.Panels(1).Text = “”
lblRadioPais.Caption = “”
End If
End Sub
Private Sub Form_Load()
Image1(0) = Image1(3) ‘Gris
Escuchar.Panels(1).Width = Me.Width – 100
Call Emisoras
‘Emisora buffer Radio HRN de Honduras
nEmisora = “http://206.17.135.195/VACILON_LIVE”
End Sub
Private Sub Emisoras()
Dim strVar As String
‘Abre archivo para leer
On Local Error Resume Next
’Sept. 2, 2007
Open UnArchivo For Input As #1
Do While Not EOF(1)
Line Input #1, strVar
‘Procesa linea a linea, si la linea es valida
If strVar <> “” Then Call Separar(strVar)
Loop
Close #1
End Sub
Private Sub Separar(sRlinea As String)
Dim sNum, iPos As Long
Dim strFinal, lesStr As String
lesStr = sRlinea
On Local Error Resume Next
For sNum = 1 To 4
iPos = InStr(lesStr, “|”)
strFinal = Trim(Left(lesStr, iPos – 1))
Select Case sNum
’Numero en la lista
Case 1
ListaURL.Add strFinal
’Nombre de emisora
Case 2
ListaURL.Add strFinal
’Pais de origen
Case 3
ListaURL.Add strFinal
’Url de emisora
Case 4
ListaURL.Add strFinal
End Select
lesStr = Right(sRlinea, Len(lesStr) – iPos)
Next sNum
’Programacion
ListaURL.Add lesStr
’
End Sub
Private Sub Tuneador_Scroll()
On Local Error GoTo Fuera
’Muestra instantaneamente la emisora y el pais
Escuchar.Panels(1).Text = ListaURL((Tuneador.Value * 5) + 2) & ” en ” & ListaURL((Tuneador.Value * 5) + 3)
nEmisora = ListaURL((Tuneador.Value * 5) + 4)
nRadioPais = Escuchar.Panels(1).Text
Exit Sub
Fuera:
MsgBox “Solo hay ” & ListaURL.Count / 5 & ” estaciones listadas.”, vbInformation + vbOKOnly, “AVISO”
Tuneador.Value = (ListaURL.Count / 5) – 1
End Sub
Private Sub WMPradio_OpenStateChange(ByVal NewState As Long)
Escuchar.Panels(1).Text = WMPradio.Status
If Left(WMPradio.Status, 3) = “Rep” Then
lblRadioPais.Caption = Trim(nRadioPais)
Image1(0) = Image1(2) ‘Verde
Else
lblRadioPais.Caption = “”
Image1(0) = Image1(1) ‘Rojo
End If
End Sub
Module
Option Explicit
‘Marzo 2008
‘hp1ml@hotmail.com
‘Para escuchar emisoras de radio latinas en internet
‘……………………..
‘Configuracion del string por paises
Public UnArchivo As String
Public Type TVNAME
nIdice As Long
Canal As String
dirURL As String
nBitrate As Integer
namePais As String
nRata As Integer
nStatus As Integer
End Type
Public ListaURL As New Collection
Public CanalPorPais As New Collection
Public Type POINTAPI
x As Long
y As Long
End Type
‘Para desplegar mas lineas en un combobox
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public 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 Declare Function MoveWindow Lib _
“user32″ (ByVal hWnd As Long, _
ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
Public Declare Function GetWindowRect Lib _
“user32″ (ByVal hWnd As Long, _
lpRect As RECT) As Long
Public Const CB_SHOWDROPDOWN = &H14F
Public Const CB_GETITEMHEIGHT = &H154
Sub main()
UnArchivo = App.Path & “\allradio.dat” ‘channelTV.txt” ‘”\get3test.htm”
frmTuner.Show
End Sub
Membuat Animasi Huruf
Private Sub cmdkeluar_Click()
Unload Me
End Sub
Private Sub form_load()
Label1.FontBold = True
Label1.Left = 240
Label1.Top = 240
Timer1.Interval = 200
End Sub
Private Sub Timer1_Timer()
Label1.Top = Label1.Top + 100
If Label1.Top > 3000 Then
Label1.Top = 240
End If
End Sub
Belajar Fungsi VB
Private Sub OK_Click()
Dim userMsg As String
userMsg = InputBox(“What is your message?”, “Message Entry Form”, “Enter your messge here”, 500, 700)
If userMsg <> “” Then
message.Caption = userMsg
Else
message.Caption = “No Message”
End If
End Sub
Posted by Administrator in 07:54:24 | Permalink | No Comments »
Saturday, February 23, 2008
Program Menghitung Lama Parkir
Dim awal, akhir As Date
Dim lama As Double
Private Sub cmd_keluar_Click()
End
End Sub
Private Sub txt_bg_change()
Ado_parkir.RecordSource = “Select*from tb_parkir where no_polisi=” ‘”&txt_bg.text&”‘”
Ado_parkir.Refresh
With Ado_parkir.Recordset
If .PageCount <> 0 Then
If !Status = “T” Then
TXT_MULAI.Text = !jam_masuk
cmd_mulai.Caption = “&Stop”
cmd_mulai.SetFocus
Else
MsgBox “Nomor Polisi Yang Telah tersimpan Silahkan Anda Tekan Tombol Mulai”, vbInformation + vbOKOnly, “BG”
cmd_mulai.SetFocus
End If
Else
TXT_MULAI.Text = “”
TXT_SELESAI.Text = “”
TXT_TOTAL.Text = “”
TXT_BIAYA.Text = “”
cmd_mulai.Caption = “&Mulai”
End If
End With
End Sub
Private Sub txt_bg_keypress(KeyASCII As Integer)
If KeyASCII = 13 Then cmd_mulai.SetFocus
End Sub
Private Sub cmd_mulai_Click()
Dim biaya As Integer
If TXT_BG.Text = “” Then
MsgBox “Masukkan Nomor BG Terlebih Dahulu”, vbInformation + vbOKOnly, “Information”
TXT_BG.SetFocus
Else
If cmd_mulai.Caption = “&Mulai” Then
awal = Time
TXT_MULAI.Text = awal
cmd_mulai.Caption = “&Simpan”
ElseIf cmd_mulai.Caption = “&Simpan” Then
Ado_parkir.RecordSource = “Select*from tb_parkir”
Ado_parkir.Refresh
With Ado_parkir.Recordset
.AddNew
!no_polisi = TXT_BG.Text
!jam_masuk = TXT_MULAI.Text
.Update
End With
cmd_mulai.Caption = “&Mulai”
TXT_MULAI.Text = “”
TXT_BG.Text = “”
TXT_BG.SetFocus
ElseIf cmd_mulai.Caption = “&Stop” Then
akhir = Time
TXT_SELESAI.Text = akhir
cmd_mulai.Caption = “&Lama”
ElseIf cmd_mulai.Caption = “&Lama” Then
Ado_parkir.RecordSource = “Select jam_masuk from”
tb_parkir where no_polisi=’”&txt_bg.text&”‘”
Ado_parkir.Refresh
lama = akhir – Ado_parkir.Recordset!jam_masuk
TXT_TOTAL.Text = Format(lama, “hh:mm:ss”)
cmd_mulai.Caption = “&Biaya”
ElseIf cmd_mulai.Caption = “&Biaya” Then
biaya = 50000 * lama
TXT_BIAYA.Text = Format(biaya, “Rp #,#”)
Ado_parkir.RecordSource = “select*from tb_parkir”
where ado_parkir=’”&txt_bg.text&”‘”
Ado_parkir.Refresh
With Ado_parkir.Recordset
!jam_keluar = TXT_SELESAI.Text
!biaya = biaya
!Status = “Y”
.Update
End With
cmd_mulai.Caption = “&Parkir”
ElseIf cmd_mulai.Caption = “&Parkir” Then
TXT_MULAI.Text = “”
TXT_SELESAI.Text = “”
TXT_TOTAL.Text = “”
TXT_BG.Text = “”
TXT_BIAYA.Text = “”
TXT_BG.SetFocus
cmd_mulai.Caption = “&Mulai”
End If
End If
End Sub
Private Sub cmd_cari_click()
On Error GoTo Error:
Cari = InputBox(“Masukkan Nomor Polisi Yang Akan Dicari:”, “Cari No.Polisi”)
If Cari <> Empty Then
ado_parkir.RecordSource=”Select*from tb_parkir where no_polisi=’”&Cari”‘”
Ado_parkir.Refresh
With Ado_parkir.Recordset
If !Status = “T” Then
TXT_BG.Text = !no_polisi
TXT_MULAI.Text = !jam_masuk
cmd_mulai.Caption = “&Stop”
TXT_SELESAI.Text = “”
TXT_BIAYA.Text = “”
TXT_TOTAL.Text = “”
Else
TXT_BG.Text = !no_polisi
TXT_MULAI.Text = “”
TXT_SELESAI = “”
TXT_BIAYA = “”
TXT_TOTAL = “”
cmd_mulai.Caption = “&Mulai”
End If
Exit Sub
Error:
MsgBox “No.Polisi Yang Anda Cari Tidak Ada!”, vbQuestion + vbOKOnly, “Pencarian”
TXT_BG.SetFocus
End With
End If
End Sub
