Cara membuat Aplikasi berita terupdate dengan Visual Basic
Bagi Anda yang suka berkoding hari ini expertadvisorku.blogspot.com membagi teknik membuat aplikasi sendiri dan bisa di convert ke bahasa pemograman yang lain baik ke C++ maupun ke Java sehingga dapat di gunakan di Android, Linux dan MAc namun dalam tahapan ini, Penulis hanya menjelaskan Aplikasi Berita terupdate sehingga anda tidak akan pernah ketinggalan beritannya dan aplikasi ini dapat anda kembangkan lebih mantap lagi, karena ditangan yang tepat maka aplikasi ini jadi lebih berguna, bermanfaat dan lebih nendang. Namun kebanyakan aplikasi ini lebih banyak untuk kepenting aplikasi itu sendiri yakni memberitahuakn update terbaru seperti pada IDM, SMADAV dan Aplikasi yang lainnya jika ada versi terbaru maka kotak dialog muncul tiba-tiba dengan beritanya sekaligus, nah sekarang kita kembangkan jadi lebih luas bukan hanya untuk aplikasi ini saja fungsinya namun untuk yang lainnya begitulah kirannya semoga tidak gagal paham dalam hal ini.
Pertama-tama kita akan membuat Form lebih dahulu yakni Form Utama beserta tombol dan pendukung yang lainnya :
Adapun Bahasa Visual basic 6 pada adalah :
Dim BufferUpdate As Long
Private Sub BeritaSamarinda_Click()
FB_BUSAM (False): OpiniBSM (False): BeritaSMD (True)
Txtberita1.Visible = False
Txtberita1.Enabled = False
TxtOpini.Visible = False
TxtBeritasmd.Visible = True
bUpdateCompon = False
HentikanUpdate = False
BufferUpdate = -1
SamarindaUpdateInfo "http://www.realmarketindonesia.com/InfoSmd/BusamInfo.txt", GetSpecFolder(USER_DOC) & "\updHantamutama.tmp"
End Sub
Private Sub CmdBeritaonline_Click()
'If CmdBeritaonline.Caption = "Check Online News" Then
bUpdateCompon = False
HentikanUpdate = False
BufferUpdate = -1
AmbilBeritaInfo "http://www.realmarketindonesia.com/02032013/FBBusam/UpdateInfo.txt", GetSpecFolder(USER_DOC) & "\updHantama.tmp"
'cmdCheckUpdate.Caption = j_bahasa(34)
'mnUpdate.Caption = j_bahasa(34)
TambahlblStatusUpdate.Caption = j_bahasa(33)
'Else
' HentikanUpdate = True
'cmdCheckUpdate.Caption = j_bahasa(27)
'mnUpdate.Caption = j_bahasa(27)
TambahlblStatusUpdate.Caption = j_bahasa(32)
'End If
TampilkanBalon Me, "Mohon Ditunggu !!! Anda Saat ini sedang melakukan aktivitas Browsing dan sedang persiapan berkunjung kesitus Hantam jika server terputus situs sedang masa kontruksi", "Perhatikan Koneksi Internet Anda ", NIIF_WARNING
End Sub
Private Sub CmdJadwalTerbang_Click()
On Error Resume Next
LetakanForm Me, False
FrmTerbang.Show
FrmTerbang.Left = Me.Left + Me.Width
FrmTerbang.Top = Me.Top
FrmTerbang.TxtTerbang.Text = ""
'FrmSapos.Hide
'FrmTribun.Hide
End Sub
Private Sub Downloader1_DownloadComplete(MaxBytes As Long, SaveFile As String)
On Error Resume Next
BufferUpdate = BufferUpdate + 1
tmrBeritaUpdate.Enabled = True
tmrNewsBerita.Enabled = True
tmrOpiniBusam.Enabled = True
tmrLowongan.Enabled = True
End Sub
Private Sub FBBusam_Click()
FB_BUSAM (True): OpiniBSM (False): BeritaSMD (False)
Txtberita1.Visible = True
Txtberita1.Enabled = True
TxtOpini.Visible = False
TxtBeritasmd.Visible = False
bUpdateCompon = False
HentikanUpdate = False
BufferUpdate = -1
AmbilBeritaInfo "http://www.realmarketindonesia.com/02032013/FBBusam/UpdateInfo.txt", GetSpecFolder(USER_DOC) & "\updHantama.tmp"
End Sub
Private Sub Form_Load()
On Error Resume Next
'Me.Height = frmMain.Height
'If CmdBeritaonline.Caption = "Refresh" Then
bUpdateCompon = False
HentikanUpdate = False
BufferUpdate = -1
'LowonganUpdateInfo "http://www.realmarketindonesia.com/Lowong/LowonganInfo.txt", GetSpecFolder(USER_DOC) & "\updLowongan.tmp"
AmbilBeritaInfo "http://www.realmarketindonesia.com/02032013/FBBusam/UpdateInfo.txt", GetSpecFolder(USER_DOC) & "\updHantama.tmp"
'AmbilBeritaInfo "http://www.realmarketindonesia.com/02032010/Informasi/UpdateInfo.txt", GetSpecFolder(USER_DOC) & "\updHantama.tmp"
'cmdCheckUpdate.Caption = j_bahasa(34)
'mnUpdate.Caption = j_bahasa(34)
TambahlblStatusUpdate.Caption = j_bahasa(33)
'Else
' HentikanUpdate = True
'cmdCheckUpdate.Caption = j_bahasa(27)
'mnUpdate.Caption = j_bahasa(27)
TambahlblStatusUpdate.Caption = j_bahasa(32)
Call UpdateIcon(Me.Icon, "Hantam News", Me)
'SamarindaUpdateInfo "http://www.realmarketindonesia.com/InfoSmd/BusamInfo.txt", GetSpecFolder(USER_DOC) & "\updHantamutama.tmp"
'ShellExecute 0, "open", "http://hantam.org", vbNullString, vbNullString, 1
TampilkanBalon Me, "Mohon Ditunggu !!! Anda Saat ini sedang melakukan aktivitas Online", "Perhatikan Koneksi Internet Anda ", NIIF_WARNING
'End If
End Sub
Private Sub Form_Resize()
On Error Resume Next
If Me.WindowState = vbMinimized Then
Me.Caption = "Hantam News"
End If
Me.Height = 8660
Me.Width = 5465
End Sub
Private Sub LblHaki_Click()
kuLowongan (False): Hakiku (True): Saposku (False)
TxtLowongan.Visible = False
TxtLowongan.Enabled = False
TxtBerita2.Visible = True
TxtSapos.Visible = False
End Sub
Private Sub Lowongan_Click()
kuLowongan (True): Hakiku (False): Saposku (False)
TxtLowongan.Visible = True
TxtLowongan.Enabled = True
TxtBerita2.Visible = False
TxtSapos.Visible = False
bUpdateCompon = False
HentikanUpdate = False
BufferUpdate = -1
LowonganUpdateInfo "http://www.realmarketindonesia.com/Lowong/LowonganInfo.txt", GetSpecFolder(USER_DOC) & "\updLowongan.tmp"
End Sub
Private Sub OpiniBusam_Click()
FB_BUSAM (False): OpiniBSM (True): BeritaSMD (False)
Txtberita1.Visible = False
Txtberita1.Enabled = False
TxtOpini.Visible = True
TxtBeritasmd.Visible = False
bUpdateCompon = False
HentikanUpdate = False
BufferUpdate = -1
OpiniUpdateInfo "http://www.realmarketindonesia.com/OpiniBsm/OpiniInfo.txt", GetSpecFolder(USER_DOC) & "\updOpiniBusam.tmp"
End Sub
Private Sub Sapos_Click()
kuLowongan (False): Hakiku (False): Saposku (True)
TxtLowongan.Visible = False
TxtLowongan.Enabled = False
TxtBerita2.Visible = False
TxtSapos.Visible = True
'bUpdateCompon = False
'HentikanUpdate = False
'BufferUpdate = -1
'AmbilBeritaInfo "http://www.realmarketindonesia.com/02032010/Saposinfo/Saposinfo.txt", GetSpecFolder(USER_DOC) & "\updhantam.tmp"
'cmdCheckUpdate.Caption = j_bahasa(34)
'mnUpdate.Caption = j_bahasa(34)
'TambahlblStatusUpdate.Caption = j_bahasa(33)
'Else
'HentikanUpdate = True
'cmdCheckUpdate.Caption = j_bahasa(27)
'mnUpdate.Caption = j_bahasa(27)
' TambahlblStatusUpdate.Caption = j_bahasa(32)
'End If
'TampilkanBalon Me, "Mohon Ditunggu !!! Anda Saat ini sedang melakukan aktivitas Browsing dan sedang persiapan berkunjung kesitus Hantam jika server terputus situs sedang masa kontruksi", "Perhatikan Koneksi Internet Anda ", NIIF_WARNING
End Sub
Private Sub Tmrberita_Timer()
'Me.Left = frmMain.Left + frmMain.Width
'Me.Top = frmMain.Top
End Sub
Private Sub tmrBeritaUpdate_Timer()
Dim TmpPath As String
Dim TmpPath2 As String
Dim MyPath As String
If HentikanUpdate = True Then GoTo LBL_MATI_AJ
TmpPath = GetSpecFolder(USER_DOC) & "\updHantama.tmp"
TmpPath2 = GetSpecFolder(USER_DOC) & "\hantamtmpa.txt"
MyPath = GetFilePath(App_FullPathW(False))
Select Case BufferUpdate
Case 0 ' baru ambil updateinfo.txt
Txtberita1.Text = TambahCheckUpdate(TmpPath, TambahlblStatusUpdate)
' TxtLowongan.Text = LowonganCheckUpdate(TmpPath, TambahlblStatusUpdate)
' TxtOpini.Text = OpiniCheckUpdate(TmpPath, TambahlblStatusUpdate)
' TxtBeritasmd.Text = SamarindaCheckUpdate(TmpPath, TambahlblStatusUpdate)
' TxtSapos.Text = SaposCheckUpdate(TmpPath, TambahlblStatusUpdate)
If bUpdateCompon = True Then ' berarti ada update terbaru
'mnUpdate.Caption = j_bahasa(34)
'cmdCheckUpdate.Caption = j_bahasa(34)
UpdateKomponen PB_UPD, TambahlblStatusUpdate, BufferUpdate
End If
Case 1 ' selesai update komponen db-0 (0x.cmc)
'MoveIfValidComp TmpPath2, MyPath & "\sign\" & Hex$(BufferUpdate - 1) & "x.Hantam", TambahlblStatusUpdate
'UpdateKomponen PB_UPD, TambahlblStatusUpdate, BufferUpdate
Case Is < 16 ' selesai update komponen db-1 (1x.cmc) dst
' MoveIfValidComp TmpPath2, MyPath & "\sign\" & Hex$(BufferUpdate - 1) & "x.Hantam", TambahlblStatusUpdate
'UpdateKomponen PB_UPD, TambahlblStatusUpdate, BufferUpdate
Case 16 ' selesai update komponen db-15 (terakhir PE)
' MoveIfValidComp TmpPath2, MyPath & "\sign\" & Hex$(BufferUpdate - 1) & "x.Hantam", TambahlblStatusUpdate
' UpdateKomponenNonPE PB_UPD, TambahlblStatusUpdate, BufferUpdate - 16
Case Is < 32
' MoveIfValidComp TmpPath2, MyPath & "\signx\" & Hex$(BufferUpdate - 17) & "z.Hantam", TambahlblStatusUpdate
' UpdateKomponenNonPE PB_UPD, TambahlblStatusUpdate, BufferUpdate - 16
Case 32 ' selsai sampai akhir
' MoveIfValidComp TmpPath2, MyPath & "\signx\" & Hex$(BufferUpdate - 17) & "z.Hantam", TambahlblStatusUpdate
'cmdCheckUpdate.Caption = j_bahasa(27)
'mnUpdate.Caption = j_bahasa(27)
TambahlblStatusUpdate.Caption = j_bahasa(31)
PBC.Value = PBC.Max
tmrBeritaUpdate.Enabled = False
BufferUpdate = -1
'Call BacaDatabase
'Call ListVirus(lstListWorm)
Exit Sub
End Select
PBC.Value = 0
tmrBeritaUpdate.Enabled = False ' matiin lagi...
Exit Sub
LBL_MATI_AJ:
PBC.Value = 0
tmrBeritaUpdate.Enabled = False
'cmdCheckUpdate.Caption = j_bahasa(27)
'mnUpdate.Caption = j_bahasa(27)
End Sub
Private Sub Downloader1_DownloadError(SaveFile As String)
HentikanUpdate = True
TambahlblStatusUpdate.Caption = "Sorry, Error Get Hantam News..."
End Sub
Private Sub Downloader1_DownloadProgress(CurBytes As Long, MaxBytes As Long, SaveFile As String)
PBC.Max = MaxBytes
PBC.Value = CurBytes
End Sub
Private Sub tmrOpiniBusam_Timer()
Dim TmpPath As String
Dim TmpPath2 As String
Dim MyPath As String
If HentikanUpdate = True Then GoTo LBL_MATI_AJ
TmpPath = GetSpecFolder(USER_DOC) & "\updOpiniBusam.tmp"
TmpPath2 = GetSpecFolder(USER_DOC) & "\OpiniBusam.txt"
MyPath = GetFilePath(App_FullPathW(False))
Select Case BufferUpdate
Case 0 ' baru ambil updateinfo.txt
TxtOpini.Text = OpiniCheckUpdate(TmpPath, OpiniTambahlblStatusUpdate)
'TxtBerita2.Text = TambahCheckUpdate(TmpPath, TambahlblStatusUpdate)
If bUpdateCompon = True Then ' berarti ada update terbaru
'mnUpdate.Caption = j_bahasa(34)
'cmdCheckUpdate.Caption = j_bahasa(34)
UpdateKomponen PB_UPD, OpiniTambahlblStatusUpdate, BufferUpdate
End If
Case 1 ' selesai update komponen db-0 (0x.cmc)
'MoveIfValidComp TmpPath2, MyPath & "\sign\" & Hex$(BufferUpdate - 1) & "x.Hantam", TambahlblStatusUpdate
'UpdateKomponen PB_UPD, TambahlblStatusUpdate, BufferUpdate
Case Is < 16 ' selesai update komponen db-1 (1x.cmc) dst
' MoveIfValidComp TmpPath2, MyPath & "\sign\" & Hex$(BufferUpdate - 1) & "x.Hantam", TambahlblStatusUpdate
'UpdateKomponen PB_UPD, TambahlblStatusUpdate, BufferUpdate
Case 16 ' selesai update komponen db-15 (terakhir PE)
' MoveIfValidComp TmpPath2, MyPath & "\sign\" & Hex$(BufferUpdate - 1) & "x.Hantam", TambahlblStatusUpdate
' UpdateKomponenNonPE PB_UPD, TambahlblStatusUpdate, BufferUpdate - 16
Case Is < 32
' MoveIfValidComp TmpPath2, MyPath & "\signx\" & Hex$(BufferUpdate - 17) & "z.Hantam", TambahlblStatusUpdate
' UpdateKomponenNonPE PB_UPD, TambahlblStatusUpdate, BufferUpdate - 16
Case 32 ' selsai sampai akhir
' MoveIfValidComp TmpPath2, MyPath & "\signx\" & Hex$(BufferUpdate - 17) & "z.Hantam", TambahlblStatusUpdate
'cmdCheckUpdate.Caption = j_bahasa(27)
'mnUpdate.Caption = j_bahasa(27)
OpiniTambahlblStatusUpdate.Caption = j_bahasa(31)
PBC.Value = PBC.Max
tmrOpiniBusam.Enabled = False
BufferUpdate = -1
'Call BacaDatabase
'Call ListVirus(lstListWorm)
Exit Sub
End Select
PBC.Value = 0
tmrOpiniBusam.Enabled = False ' matiin lagi...
Exit Sub
LBL_MATI_AJ:
PBC.Value = 0
tmrOpiniBusam.Enabled = False
'cmdCheckUpdate.Caption = j_bahasa(27)
'mnUpdate.Caption = j_bahasa(27)
End Sub
Private Sub tmrNewsBerita_Timer()
Dim TmpPath As String
Dim TmpPath2 As String
Dim MyPath As String
If HentikanUpdate = True Then GoTo LBL_MATI_AJ
TmpPath = GetSpecFolder(USER_DOC) & "\updHantamutama.tmp"
TmpPath2 = GetSpecFolder(USER_DOC) & "\hantamutamatmp.txt"
MyPath = GetFilePath(App_FullPathW(False))
Select Case BufferUpdate
Case 0 ' baru ambil updateinfo.txt
TxtBeritasmd.Text = SamarindaCheckUpdate(TmpPath, InfoTambahlblStatusUpdate)
'TxtBerita2.Text = TambahCheckUpdate(TmpPath, TambahlblStatusUpdate)
If bUpdateCompon = True Then ' berarti ada update terbaru
'mnUpdate.Caption = j_bahasa(34)
'cmdCheckUpdate.Caption = j_bahasa(34)
UpdateKomponen PB_UPD, InfoTambahlblStatusUpdate, BufferUpdate
End If
Case 1 ' selesai update komponen db-0 (0x.cmc)
'MoveIfValidComp TmpPath2, MyPath & "\sign\" & Hex$(BufferUpdate - 1) & "x.Hantam", TambahlblStatusUpdate
'UpdateKomponen PB_UPD, TambahlblStatusUpdate, BufferUpdate
Case Is < 16 ' selesai update komponen db-1 (1x.cmc) dst
' MoveIfValidComp TmpPath2, MyPath & "\sign\" & Hex$(BufferUpdate - 1) & "x.Hantam", TambahlblStatusUpdate
'UpdateKomponen PB_UPD, TambahlblStatusUpdate, BufferUpdate
Case 16 ' selesai update komponen db-15 (terakhir PE)
' MoveIfValidComp TmpPath2, MyPath & "\sign\" & Hex$(BufferUpdate - 1) & "x.Hantam", TambahlblStatusUpdate
' UpdateKomponenNonPE PB_UPD, TambahlblStatusUpdate, BufferUpdate - 16
Case Is < 32
' MoveIfValidComp TmpPath2, MyPath & "\signx\" & Hex$(BufferUpdate - 17) & "z.Hantam", TambahlblStatusUpdate
' UpdateKomponenNonPE PB_UPD, TambahlblStatusUpdate, BufferUpdate - 16
Case 32 ' selsai sampai akhir
' MoveIfValidComp TmpPath2, MyPath & "\signx\" & Hex$(BufferUpdate - 17) & "z.Hantam", TambahlblStatusUpdate
'cmdCheckUpdate.Caption = j_bahasa(27)
'mnUpdate.Caption = j_bahasa(27)
InfoTambahlblStatusUpdate.Caption = j_bahasa(31)
PBC.Value = PBC.Max
tmrNewsBerita.Enabled = False
BufferUpdate = -1
'Call BacaDatabase
'Call ListVirus(lstListWorm)
Exit Sub
End Select
PBC.Value = 0
tmrNewsBerita.Enabled = False ' matiin lagi...
Exit Sub
LBL_MATI_AJ:
PBC.Value = 0
tmrNewsBerita.Enabled = False
'cmdCheckUpdate.Caption = j_bahasa(27)
'mnUpdate.Caption = j_bahasa(27)
End Sub
Private Sub tmrLowongan_Timer()
On Error Resume Next
Dim TmpPath As String
Dim TmpPath2 As String
Dim MyPath As String
If HentikanUpdate = True Then GoTo LBL_MATI_AJ
TmpPath = GetSpecFolder(USER_DOC) & "\updLowongan.tmp"
TmpPath2 = GetSpecFolder(USER_DOC) & "\LowonganBusam.txt"
MyPath = GetFilePath(App_FullPathW(False))
Select Case BufferUpdate
Case 0 ' baru ambil updateinfo.txt
TxtLowongan.Text = LowonganCheckUpdate(TmpPath, LowonganTambahlblStatusUpdate)
'TxtBerita2.Text = TambahCheckUpdate(TmpPath, TambahlblStatusUpdate)
If bUpdateCompon = True Then ' berarti ada update terbaru
'mnUpdate.Caption = j_bahasa(34)
'cmdCheckUpdate.Caption = j_bahasa(34)
UpdateKomponen PB_UPD, LowonganTambahlblStatusUpdate, BufferUpdate
End If
Case 1 ' selesai update komponen db-0 (0x.cmc)
'MoveIfValidComp TmpPath2, MyPath & "\sign\" & Hex$(BufferUpdate - 1) & "x.Hantam", TambahlblStatusUpdate
'UpdateKomponen PB_UPD, TambahlblStatusUpdate, BufferUpdate
Case Is < 16 ' selesai update komponen db-1 (1x.cmc) dst
' MoveIfValidComp TmpPath2, MyPath & "\sign\" & Hex$(BufferUpdate - 1) & "x.Hantam", TambahlblStatusUpdate
'UpdateKomponen PB_UPD, TambahlblStatusUpdate, BufferUpdate
Case 16 ' selesai update komponen db-15 (terakhir PE)
' MoveIfValidComp TmpPath2, MyPath & "\sign\" & Hex$(BufferUpdate - 1) & "x.Hantam", TambahlblStatusUpdate
' UpdateKomponenNonPE PB_UPD, TambahlblStatusUpdate, BufferUpdate - 16
Case Is < 32
' MoveIfValidComp TmpPath2, MyPath & "\signx\" & Hex$(BufferUpdate - 17) & "z.Hantam", TambahlblStatusUpdate
' UpdateKomponenNonPE PB_UPD, TambahlblStatusUpdate, BufferUpdate - 16
Case 32 ' selsai sampai akhir
' MoveIfValidComp TmpPath2, MyPath & "\signx\" & Hex$(BufferUpdate - 17) & "z.Hantam", TambahlblStatusUpdate
'cmdCheckUpdate.Caption = j_bahasa(27)
'mnUpdate.Caption = j_bahasa(27)
LowonganTambahlblStatusUpdate.Caption = j_bahasa(31)
PBC.Value = PBC.Max
tmrLowongan.Enabled = False
BufferUpdate = -1
Exit Sub
End Select
PBC.Value = 0
tmrLowongan.Enabled = False ' matiin lagi...
Exit Sub
LBL_MATI_AJ:
PBC.Value = 0
tmrLowongan.Enabled = False
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next
Dim lHasil As Long
Dim HorX As Long
If Me.ScaleMode = vbPixels Then
HorX = X
Else
HorX = X / Screen.TwipsPerPixelX
End If
Select Case HorX
Case WM_LBUTTONDBLCLK
Me.WindowState = vbNormal
lHasil = SetForegroundWindow(Me.hwnd)
' mnCScan.Caption = g_bahasa(0)
Me.Show
Case WM_RBUTTONUP 'Tampilkan menu Popup saat klik kanan.
lHasil = SetForegroundWindow(Me.hwnd)
Me.PopupMenu Me.MnBusam
End Select
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
'If LewatExit = False And Left$(Command, 2) <> "-S" Then ' klo dari shell scan tanda X juga berguna nutup
Cancel = 1
Shell_NotifyIcon NIM_DELETE, nID
Call UpdateIcon(Me.Icon, "Hantam News", Me)
Me.WindowState = vbMinimized
' Me.Hide
' Frmsetingan.Hide
' FrmBerita.Hide
' FrmTweak.Hide
'ElseIf BERHENTI = False Then
' Cancel = 1
' MsgBox i_bahasa(8), vbExclamation
'Else
' Me.Show
' Shell_NotifyIcon NIM_DELETE, nID
Unload Me
End
'End If
End Sub
Private Sub MnKeluar_Click()
On Error Resume Next
'Call LepasSemuaKunci
' LewatExit = True
' Set ShellIE = Nothing
' SaveConfig GetFilePath(App_FullPathW(False)) & "\Hantam.ini"
'Unload frmRTP
' Call BerhentiDetect
Unload Me
End Sub
======================================================================
Itulah isi dari form Utama dan perlu digaris bawahi Anda dapat mengembangkannya dan menconvertnya ke C++ atau Java
Bagi yang sudah memahami bahasa Pemograman Visual Basic tentu tidak pusing melihat Kode-kode itu...namun bagi yang awam akan nampak bahasa planetnya....
Jika di visualisasikan akan nampak seperti gambar dibawah ini :
Adapun file Anda dapat mendownloadnya DISINI
0 Response to "Cara membuat Aplikasi berita terupdate dengan Visual Basic"
Posting Komentar