billing.bas

Billing Internet Cafe

Attribute VB_Name = "Billing"
'declare registry
Public Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type

Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006
Public Const KEY_ALL_ACCESS = &HF003F
Public Const KEY_CREATE_LINK = &H20
Public Const KEY_CREATE_SUB_KEY = &H4
Public Const KEY_ENUMERATE_SUB_KEY = &H8
Public Const KEY_EXECUTE = &H20019
Public Const KEY_NOTIFY = &H10
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_READ = &H20019
Public Const KEY_SET_VALUE = &H2
Public Const KEY_WRITE = &H20006
Public Const REG_BINARY = 3
Public Const REG_DWORD = 4
Public Const REG_DWORD_LITTLE_ENDIAN = 4
Public Const REG_DWORD_BIG_ENDIAN = 5
Public Const REG_EXPAND_SZ = 2
Public Const REG_LINK = 6
Public Const REG_MULTI_SZ = 7
Public Const REG_NONE = 0
Public Const REG_RESOURCE_LIST = 8
Public Const REG_SZ = 1

Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Public Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As String, ByVal cbData As Long) As Long
Public Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubkey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubkey As String, phkResult As Long) As Long
Public Declare Function RegEnumValue Lib "advapi32.dll" Alias "RegEnumValueA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpValueName As String, lpcbValueName As Long, ByVal lpReserved As Long, lpType As Long, lpData As Byte, lpcbData As Long) As Long
Public Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubkey As String, ByVal lpValue As String, lpcbValue As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubkey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long

Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function GetWindowLong& Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long)
Private Declare Function SetWindowLong& Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long)

Private Const WM_USER = &H400
Private Const PBM_SETBARCOLOR = (WM_USER + 9)
Private Const CCM_FIRST = &H2000
Private Const CCM_SETBKCOLOR = (CCM_FIRST + 1)
Private Type tagInitCommonControlsEx
    lngSize As Long
    lngICC As Long
End Type
Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As tagInitCommonControlsEx) As Boolean
Public Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Public Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Const ICC_USEREX_CLASSES = &H200
Public con1 As String
Public cn As New ADODB.Connection
Public rs As New ADODB.Recordset
Public cmd As New ADODB.Command
Public Function InitCommonControlsVB() As Boolean
    On Error Resume Next
    Dim iccex As tagInitCommonControlsEx
    ' Ensure CC available:
    With iccex
        .lngSize = LenB(iccex)
        .lngICC = ICC_USEREX_CLASSES
    End With
    InitCommonControlsEx iccex
    InitCommonControlsVB = (err.Number = 0)
    On Error GoTo 0
End Function
Public Sub Main()
On Error GoTo error
If InitCommonControlsVB Then
        FrmLoading.Show
    Else
        MsgBox "Initialization error!", vbCritical
        End
    End If
If App.PrevInstance Then
    MsgBox "Tidak Bisa Menjalankan " & App.ProductName & " di waktu bersamaan...", vbOKOnly Or vbExclamation, "Previous instance found"
    End
    End If
    con1 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & pathdata & "black.BLC;Persist Security Info=False;Jet OLEDB:Database Password=myblackpearl87"
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & pathdata & "black.BLC;Persist Security Info=False;Jet OLEDB:Database Password=myblackpearl87"
error:
    Select Case err.Number
    Case -2147467259
    MsgBox "Data Base Tidak ada, Pastikan data base terdapat di path program terinstall, dengan nama data (black.mdb)", vbOKOnly, "Missing data"
    End
    End Select
End Sub
Public Sub PBcolor(PB As ProgressBar, Backcolor As Long, Forecolor As Long)
    SendMessage PB.hWnd, CCM_SETBKCOLOR, 0, ByVal Backcolor
    SendMessage PB.hWnd, PBM_SETBARCOLOR, 0, ByVal Forecolor
End Sub

Public Function FExists(OrigFile As String)
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    FExists = fs.fileexists(OrigFile)
End Function

Public Function DirExists(OrigFile As String)
    Dim fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    DirExists = fs.folderexists(OrigFile)
End Function

Public Sub RegSaveString(hKey As Long, strPath As String, strValue As String, strData As String)
Dim keyHand As Long
Dim x As Long
    x = RegCreateKey(hKey, strPath, keyHand)
    x = RegSetValueEx(keyHand, strValue, 0, REG_SZ, ByVal strData, Len(strData))
    x = RegCloseKey(keyHand)
End Sub

Sub TulisKey()
Dim subkey As String
    Call RegSaveString(HKEY_LOCAL_MACHINE, "Software\BLacKPeaRL\server\" & VersiAplikasi & "\", "path", App.path & "\")
    Call RegSaveString(HKEY_LOCAL_MACHINE, "Software\BLacKPeaRL\server\" & VersiAplikasi & "\", "versi", VersiAplikasi)
    Call RegSaveString(HKEY_LOCAL_MACHINE, "Software\BLacKPeaRL\server\" & VersiAplikasi & "\", "penulis", Penulis)
    Call RegSaveString(HKEY_LOCAL_MACHINE, "Software\BLacKPeaRL\server\" & VersiAplikasi & "\", "email", EmailPenulis)
    Call RegSaveString(HKEY_LOCAL_MACHINE, "Software\BLacKPeaRL\server\" & VersiAplikasi & "\", "homepage", HomePage)
    pathdata = App.path & "\"
End Sub
Sub CekKey()
Dim x As Long
    x = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "Software\BLacKPeaRL\server\" & VersiAplikasi, 0, KEY_READ, hregKey)
    If x <> 0 Then
        Call TulisKey
    Else
        Call AmbilKey
    End If
    x = RegCloseKey(hregKey)
End Sub
Sub AmbilKey()
Dim x As Long
    x = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "Software\BLacKPeaRL\server\" & VersiAplikasi, 0, KEY_READ, hregKey)
    pathdata = GetRegistryValue(hregKey, "path")
End Sub
Public Function GetRegistryValue(ByVal hKey As Long, ByVal subkey_name As String) As String
Dim value As String
Dim length As Long
Dim value_type As Long
    length = 256
    value = Space$(length)
    If RegQueryValueEx(hKey, subkey_name, 0&, value_type, ByVal value, length) <> ERROR_SUCCESS Then
        value = "<Error>"
    Else
        value = Left$(value, length - 1)
    End If
    GetRegistryValue = value
End Function

Public Function EncryptText(strText As String, ByVal strPwd As String)
Dim i As Integer, C As Integer
Dim strBuff As String
    If Len(strPwd) Then
        For i = 1 To Len(strText)
            C = Asc(Mid$(strText, i, 1))
            C = C + Asc(Mid$(strPwd, (i Mod Len(strPwd)) + 1, 1))
            strBuff = strBuff & Chr$(C And &HFF)
        Next i
    Else
        strBuff = strText
    End If
    EncryptText = strBuff
End Function

Public Function DecryptText(strText As String, ByVal strPwd As String)
Dim i As Integer, C As Integer
Dim strBuff As String
    If Len(strPwd) Then
        For i = 1 To Len(strText)
            C = Asc(Mid$(strText, i, 1))
            C = C - Asc(Mid$(strPwd, (i Mod Len(strPwd)) + 1, 1))
            strBuff = strBuff & Chr$(C And &HFF)
        Next i
    Else
        strBuff = strText
    End If
    DecryptText = strBuff
End Function