'begin code
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "Mscomctl.ocx"
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "Toi da ton bao nhieu"
ClientHeight = 1245
ClientLeft = 45
ClientTop = 345
ClientWidth = 4695
Icon = "Form1.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 1245
ScaleWidth = 4695
StartUpPosition = 2 'CenterScreen
Begin VB.CommandButton cmdAbout
Cancel = -1 'True
Caption = "&About"
Height = 375
Left = 3120
TabIndex = 3
Top = 720
Width = 1335
End
Begin VB.Frame Options
BorderStyle = 0 'None
Enabled = 0 'False
Height = 1455
Left = 840
TabIndex = 4
Top = 1260
Width = 3015
Begin VB.CommandButton cmdReset
Caption = "&Reset Options"
Height = 375
Left = 1560
TabIndex = 13
Top = 960
Width = 1335
End
Begin VB.CommandButton cmdSave
Caption = "&Save Options"
Height = 375
Left = 120
TabIndex = 12
Top = 960
Width = 1335
End
Begin VB.TextBox Text1
Alignment = 1 'Right Justify
Height = 285
Left = 1200
TabIndex = 11
Top = 540
Width = 1695
End
Begin VB.ComboBox Combo2
Height = 315
ItemData = "Form1.frx":0442
Left = 2160
List = "Form1.frx":04FA
Style = 2 'Dropdown List
TabIndex = 8
Top = 120
Width = 615
End
Begin VB.ComboBox Combo1
Height = 315
ItemData = "Form1.frx":05E4
Left = 1200
List = "Form1.frx":0606
Style = 2 'Dropdown List
TabIndex = 6
Top = 120
Width = 615
End
Begin VB.Label Label4
AutoSize = -1 'True
Caption = "I&mpulse Cost:"
Height = 195
Left = 120
TabIndex = 10
Top = 540
Width = 945
End
Begin VB.Label Label3
AutoSize = -1 'True
Caption = "s"
Height = 195
Left = 2880
TabIndex = 9
Top = 180
Width = 75
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "m"
Height = 195
Left = 1920
TabIndex = 7
Top = 180
Width = 120
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "Impulse &Time:"
Height = 195
Left = 120
TabIndex = 5
Top = 180
Width = 975
End
End
Begin VB.CommandButton cmdClose
Caption = "&Close"
Height = 375
Left = 1680
TabIndex = 2
Top = 720
Width = 1335
End
Begin VB.CommandButton cmdOptions
Caption = "&Options >>"
Height = 375
Left = 240
TabIndex = 1
Top = 720
Width = 1335
End
Begin VB.Timer Timer1
Interval = 1000
Left = 4080
Top = 120
End
Begin MSComctlLib.ProgressBar ProgressBar
Height = 255
Left = 360
TabIndex = 15
Top = 360
Width = 3615
_ExtentX = 6376
_ExtentY = 450
_Version = 393216
BorderStyle = 1
Appearance = 1
Scrolling = 1
End
Begin VB.Label Status
Alignment = 2 'Center
Caption = "Ban khong vao internet"
Height = 255
Left = 2400
TabIndex = 14
Top = 120
Width = 1935
End
Begin VB.Label Timed
Alignment = 2 'Center
Caption = "Ban khong vao internet"
Height = 255
Left = 0
TabIndex = 0
Top = 120
Width = 2295
End
Begin VB.Line Line1
BorderColor = &H80000014&
BorderWidth = 2
X1 = 120
X2 = 4560
Y1 = 1200
Y2 = 1200
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private ITime As Integer, ICost As Single
Private NetStart As Long, NetCount As Integer, NetCost As Long
Private OnLine As Boolean
Dim Db As database
Dim tblDef As TableDef
Dim fldDef As Field
Dim fldLoop As Field
Dim prpLoop As Property
Dim indx As Index
Dim dbName As String
Dim FileNumber As String
Dim FileName As String
Private Sub CreateIT()
Set tblDef = Db.CreateTableDef("Cost")
With tblDef
.Fields.Append .CreateField("Date", dbDate, 4)
.Fields.Append .CreateField("Time", dbDate, 64)
.Fields.Append .CreateField("Cost", dbLong, 32)
End With
Db.TableDefs.Append tblDef
FileNumber = FreeFile
FileName = App.Path & "\Database Info.txt"
Open FileName For Output As #FileNumber
Print #FileNumber, vbCrLf & "Properties of Fields in " & tblDef.Name & vbCrLf
For Each fldLoop In tblDef.Fields
Print #FileNumber, " " & fldLoop.Name
For Each prpLoop In fldLoop.Properties
On Error Resume Next
Print #FileNumber, " " & prpLoop.Name & " - " & _
IIf(prpLoop = "", "[empty]", prpLoop)
On Error GoTo 0
Next prpLoop
Next fldLoop
Close #FileNumber
End Sub
Private Sub cmdClose_Click()
UpdateDB
'write to DB
End
'End the program
End Sub
Private Sub cmdOptions_Click()
If cmdOptions.Caption = "&Options >>" Then
'Show the Options Panel
ResetOptions
cmdOptions.Caption = "&Options <<"
Me.Height = 3045
Options.Enabled = True
'Disable the timer
Timer1.Enabled = False
Else
'Hide the Options Panel
cmdOptions.Caption = "&Options >>"
Me.Height = 1545
Options.Enabled = False
'Enable the timer
Timer1.Enabled = True
End If
End Sub
Private Sub cmdReset_Click()
'Reset the options, by reloading the settings
ResetOptions
End Sub
Private Sub cmdSave_Click()
'Update the options variables
ITime = Combo1 * 60 + Combo2
ICost = CSng(Text1)
'Save the options on the Windows Registry
SaveSetting "Internet Costs Control", "ops", "ITime", ITime
SaveSetting "Internet Costs Control", "ops", "ICost", ICost
End Sub
Private Sub Form_Load()
On Error GoTo err:
dbName = App.Path & "\ICC.mdb"
If (Len(Dir(dbName))) Then
' Kill dbName
End If
Set Db = DBEngine.Workspaces(0).CreateDatabase(dbName, dbLangGeneral)
Call CreateIT
MsgBox ("Database successfully created at " & dbName & "." & _
vbCrLf & "Database Info file created at " & FileName & ".")
If Error = 3204 Then
err:
'nothing
End If
'Set the options, by loading the setings
ResetOptions
'Align the Impulse Progress Bar
ProgressBar.Tag = Timed.Width - 60
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
Dim Ret As Long, PassedTime As Long
'Check if you are connected
If IsRASConnected Then
'Get the time you have been connected
PassedTime = Timer - NetStart
If OnLine Then
'If you were already connected,
Timed = "Dang dung " & TimeSerial(0, 0, PassedTime)
If Int(PassedTime / ITime + 1) > NetCount Then
'Update the Costs Panel
NetCount = Int(PassedTime / ITime + 1)
NetCost = NetCount * ICost
Status = "Ban da ton " & Format(NetCost, "Currency")
ProgressBar.Width = Int(ProgressBar.Tag)
Else
'Update the Impulse Progress Bar
ProgressBar.Width = Int(ProgressBar.Tag) / ITime * (PassedTime Mod ITime)
End If
Else
'If you weren't connected, set the session variables
NetStart = Timer
NetCount = 1
NetCost = ICost
Timed = "Dang dung internet " & TimeSerial(0, 0, 0)
Status = "Ban da ton " & Format(NetCost, "Currency")
'Change the Online flag to True
OnLine = True
'Disable the Options CommandButton
cmdOptions.Enabled = False
End If
Else
'If you were connected,
If OnLine Then
'Update the Costs Panel
Timed = "Khong vao internet. Thoi gian Ban khong vao internet " & TimeSerial(0, 0, Timer - NetStart)
Status = "Ban da ton " & Format(NetCost, "Currency") & " cho viec truy cap internet"
ProgressBar.Width = 0
'Change the Online flag to False
OnLine = False
'Enable the Options CommandButton
cmdOptions.Enabled = True
End If
End If
'Do all events
DoEvents
End Sub
Private Sub ResetOptions()
'Get the program settings from Windows Registry
ITime = Int(GetSetting("Internet Costs Control", "Ops", "ITime", 180))
ICost = CSng(GetSetting("Internet Costs Control", "Ops", "ICost", 10))
'Update the Options Controls with the setting values
Combo1 = Int(ITime / 60)
Combo2 = ITime - 60 * Int(ITime / 60)
Text1 = ICost
End Sub
Public Sub UpdateDB()
Dim Db As database
Dim Record As Recordset
Set Db = OpenDatabase(App.Path & "\ICC.mdb")
Set Record = Db.OpenRecordset("Cost", dbOpenDynaset)
With Record
.AddNew
!Date = Format(Date, "dd-mm-yyyy")
!Time = Format(Time, "hh:mm:ss")
!cost = Format(NetCost, "Currency")
.Update
.Close
End With
End Sub
'cut here
'begin BAS
Attribute VB_Name = "Module1"
Private Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lprasconn As Any, lpcb As Long, lpcConnections As Long) As Long
Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasConn As Long, lpRASCONNSTATUS As Any) As Long
Private Const RAS95_MaxEntryName = 256
Private Const RAS_MaxDeviceType = 16
Private Const RAS95_MaxDeviceName = 128
Private Const RASCS_DONE = &H2000&
Type RASCONN95
dwSize As Long
hRasConn As Long
szEntryName(RAS95_MaxEntryName) As Byte
szDeviceType(RAS_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Public Function IsRASConnected() As Boolean
Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim lReturn As Long
Dim Tstatus As RASCONNSTATUS95
TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize
lReturn = RasEnumConnections(TRasCon(0), lg, lpcon)
If lReturn Then
' Some error code here
Exit Function
End If
Tstatus.dwSize = 160
lReturn = RasGetConnectStatus(TRasCon(0).hRasConn, Tstatus)
If Tstatus.RasConnState = RASCS_DONE Then
IsRASConnected = True
Else
IsRASConnected = False
End Function