Attribute VB_Name = "modRainBow"
Option Explicit
'* 1. Add the "global.bas" to your project. This file is part of the Visual Basic interface, the location of the file can be found in the README.TXT.
'* 2. Include the "sx32w.dll" with your compiled program. This contains the necessary functions to talk to your SuperPro. You will have to include this with your program when you send it out to the customer. If you are running your application from the IDE, place this file in the "windows\system" directory as that is where Visual Basic will look for it.
'* 3. Declare a variable of type APIPACKET, or use the declared variable "ApiPack" in the GLOBAL.BAS file.
'* 4. gAdr Address is a integer number in the Rainbow Key.
Dim MyAPIPacket As APIPACKET
Public QueryTable(1 To 10) As TQueryPair
Public gAdrDBPassword As Integer
Public gAdrLastRunDate As Integer
Public gAdrLastRunTime As Integer
Public gAdrNetworkLic As Integer
Public gAdrAllowDateLimit As Integer
Public gAdrExecCounter As Integer
Public gAdrLicAlgorithm As Integer
Public Type TQueryPair
query As String
response As String
End Type
Private Const SP_SUCCESS = 0
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long)
'*** Unsigned to signed
Public Function LoWord(ByVal inDWord As Long) As Integer
Call CopyMemory(ByVal VarPtr(LoWord), ByVal VarPtr(inDWord), 2)
End Function
'*** Signed to unsigned
Private Function SWordToWord(inWord As Integer) As Long
Call CopyMemory(ByVal VarPtr(SWordToWord), ByVal VarPtr(inWord), 2)
End Function
'* 4. Format the API packet that you previously declared using the RNBOsproFormatPacket function call:
Private Function fRNBOsproFormatPacket() As Boolean
Dim tmpResult As Long
tmpResult = RNBOsproFormatPacket(MyAPIPacket, Len(MyAPIPacket))
If tmpResult = SP_SUCCESS Then
fRNBOsproFormatPacket = True
Else
fRNBOsproFormatPacket = False
End If
End Function
'* 5. Initialize the packet you declared using the RNBOsproInitialize function call:
Private Function fRNBOsproInitialize() As Boolean
Dim tmpResult As Long
tmpResult = RNBOsproInitialize(MyAPIPacket)
If tmpResult = SP_SUCCESS Then
fRNBOsproInitialize = True
Else
fRNBOsproInitialize = False
End If
End Function
'* 6 Set communication protocol using the RNBOsproSetProtocol function call ( default communication protocol is TCP/IP):
Private Function fRNBOsproSetProtocol(ProtocolFlag As Integer) As Boolean
Dim tmpResult As Long
tmpResult = RNBOsproSetProtocol(MyAPIPacket, ProtocolFlag)
If tmpResult <> SP_SUCCESS Then
fRNBOsproSetProtocol = False
Else
fRNBOsproSetProtocol = True
End If
End Function
'* 7. Add code to set the contact server using the RNBOsproSetContactServer call:
Private Function fRNBOsproContactServer(szServerName As String) As Boolean
'Dim szServerName As String 'initialize to the server name you want to communicate with
Dim tmpResult As Long
tmpResult = RNBOsproSetContactServer(MyAPIPacket, szServerName)
If tmpResult <> SP_SUCCESS Then
fRNBOsproContactServer = False
'If FindFirst has already been successful
'before it is called, this API won't work.
'an error message.
Else
fRNBOsproContactServer = True
End If
End Function
'* 8. Add code to check for the presence of the key using the RNBOsproFindFirstUnit function call:
Private Function fRNBOsproFindFirstUnit() As Boolean
Dim tmpResult As Long
tmpResult = RNBOsproFindFirstUnit(MyAPIPacket, &Hxxxx)
If tmpResult <> SP_SUCCESS Then
fRNBOsproFindFirstUnit = False
ReleaseDongle
' Key not found...
' Give user chance to retry or abort displaying
' an error message.
Else
fRNBOsproFindFirstUnit = True
End If
End Function
'* 9. Now make a call to get the sub license using RNBOsproGetSubLicense call:
Private Function fRNBOsproGetSubLicense(cellAddress As Integer) As Boolean
'Dim cellAddress As Integer
Dim tmpResult As Long
tmpResult = RNBOsproGetSubLicense(MyAPIPacket, cellAddress)
If tmpResult <> SP_SUCCESS Then
fRNBOsproGetSubLicense = False
'if the cellAddress is not a sublicence cell then this api will return
'no license available
Else
fRNBOsproGetSubLicense = True
End If
End Function
'* 11. Make Read call within configured heart beat time RNBOsproRead call (You can configure heart beat value using RNBOsproSetHeartBeat API, default heartbeat time is 120 seconds).
Private Function fRNBOsproRead(RNBOAddress As Integer, RNBOdata As Integer) As Boolean
'Dim address As Integer
'Dim data As Integer
Dim tmpResult As Long
tmpResult = RNBOsproRead(MyAPIPacket, RNBOAddress, RNBOdata)
If tmpResult <> SP_SUCCESS Then
fRNBOsproRead = False
End
'SP_ACCESS_DENIED error is given when read operation
'is made on Algo word or Locked Data Word
Else
fRNBOsproRead = True
End If
End Function
Private Function fRNBOsproWrite(RNBOAddress As Integer, RNBOdata As Integer) As Boolean
Dim tmpResult As Long
tmpResult = RNBOsproWrite(MyAPIPacket, &HC362, RNBOAddress, RNBOdata, 0)
If tmpResult <> SP_SUCCESS Then
fRNBOsproWrite = False
End
Else
fRNBOsproWrite = True
End If
End Function
'* 12. Now make call to release license or sublicenses using ReleaseLicense call:
Private Sub sRNBOsproReleaseLicense()
Dim cellAddress As Integer 'This is the sublicense cell address
Dim nLicenses As Integer ' This is the number of sublicenses to release
cellAddress = 0
nLicenses = 0
'If cellAddress is zero, the main license,
'including all the sublicenses(if any) is (are) released.
Call RNBOsproReleaseLicense(MyAPIPacket, cellAddress, nLicenses)
End Sub
'Declare Function RNBOsproDecrement% Lib "Sx32w.dll" (ApiPack As APIPACKET, ByVal wPass As Integer, ByVal address As Integer)
Private Function fRNBOsproDecrement(RNBOAddress As Integer) As Boolean
Dim tmpResult As Long
tmpResult = RNBOsproDecrement(MyAPIPacket, &HC362, RNBOAddress)
If tmpResult <> SP_SUCCESS Then
fRNBOsproDecrement = False
End
Else
fRNBOsproDecrement = True
End If
End Function
Private Function fRNBOsproSetHeartBeat(RNBOheartBeatValue As Long) As Boolean
Dim tmpResult As Long
tmpResult = RNBOsproSetHeartBeat(MyAPIPacket, RNBOheartBeatValue)
If tmpResult <> SP_SUCCESS Then
fRNBOsproSetHeartBeat = False
Else
fRNBOsproSetHeartBeat = True
End If
End Function
' * The GetQueryData and GetResponseData functions will pull an item from your Query/Response Table and convert it to the hexadecimal form the SuperPro libraries expect. The following code should be added to the end of the "GLOBAL.BAS" file to facilitate this and contains your randomly generated table of Query/Response pairs.
Public Function GetQueryData(Index As Integer) As DATAQUERY
Dim i As Integer
Dim Answer As DATAQUERY
For i = 0 To (Len(QueryTable(Index).query) / 2 - 1)
Answer.Data(i) = Val("&H" + Mid$(QueryTable(Index).query, i * 2 + 1, 2))
Next i
GetQueryData = Answer
End Function
Public Function GetResponseData(Index As Integer) As DATAQUERY
Dim i As Integer
Dim Answer As DATAQUERY
For i = 0 To (Len(QueryTable(Index).response) / 2 - 1)
Answer.Data(i) = Val("&H" + Mid$(QueryTable(Index).response, i * 2 + 1, 2))
Next i
GetResponseData = Answer
End Function
Public Function CheckDongle() As Boolean
Dim tmpResult As Boolean
tmpResult = fRNBOsproFormatPacket
tmpResult = tmpResult And fRNBOsproInitialize
tmpResult = tmpResult And fRNBOsproContactServer("localhost")
tmpResult = tmpResult And fRNBOsproFindFirstUnit
tmpResult = tmpResult And fRNBOsproSetHeartBeat(180)
If tmpResult = True Then
InitQueryTable
If fQueryDongle <> True Then End
Else
ReleaseDongle
End
End If
CheckDongle = tmpResult
End Function
Public Sub ReleaseDongle()
sRNBOsproReleaseLicense
End Sub
Private Function fGetDateDiff() As Long
Dim tmpResult As Long
Dim tmpDate As Date
Dim tmpReturn As Long
tmpDate = CDate("2000/1/1")
tmpResult = DateDiff("d", tmpDate, Now)
tmpReturn = 0
If Now > tmpDate Then
If tmpResult > 0 Then
tmpReturn = tmpResult
Else
tmpReturn = 0
End If
Else
tmpReturn = 0
End
End If
fGetDateDiff = tmpReturn
End Function
Private Function fGetCurrTime() As Integer
Dim tmpHour As Integer
Dim tmpMin As Integer
tmpHour = Hour(Now)
tmpMin = Minute(Now)
fGetCurrTime = tmpHour * 60 + tmpMin
End Function
Private Function fGetLastDate() As Long
Dim tmpData As Integer
If fRNBOsproRead(gAdrLastRunDate, tmpData) = True Then
fGetLastDate = SWordToWord(tmpData)
Else
fGetLastDate = 0
End
End If
End Function
Private Sub sSaveLastDate(InputDate As Long)
If fRNBOsproWrite(gAdrLastRunDate, LoWord(InputDate)) <> True Then End
End Sub
Private Function fGetLastTime() As Integer
Dim tmpData As Integer
If fRNBOsproRead(gAdrLastRunTime, tmpData) = True Then
fGetLastTime = tmpData
Else
fGetLastTime = 0
End
End If
End Function
Private Sub sSaveLastTime(InputTime As Integer)
If fRNBOsproWrite(gAdrLastRunTime, InputTime) = False Then End
End Sub
Public Function fCheckExecValid() As Boolean
Dim tmpData As Integer
Dim tmpResult As Boolean
Dim tmpAllowExec As Long
tmpResult = True
If fRNBOsproRead(gAdrExecCounter, tmpData) <> True Then
tmpResult = False
End
End If
tmpAllowExec = SWordToWord(tmpData)
If tmpAllowExec < 65535 Then sLicDecrement
If tmpAllowExec < 1 Then tmpResult = False
fCheckExecValid = tmpResult
End Function
Public Function fCheckDateValid() As Boolean
Dim tmpLastDate As Long
Dim tmpAllowDays As Long
Dim tmpToday As Long
Dim tmpLastTime As Integer
Dim tmpCurrTime As Integer
Dim tmpResult As Boolean
tmpResult = True
tmpToday = fGetDateDiff
tmpLastDate = fGetLastDate
tmpAllowDays = fGetAllowDays
tmpLastTime = fGetLastTime
tmpCurrTime = fGetCurrTime
If tmpAllowDays <> 65535 Then
If tmpToday < 1 Then fCheckDateValid = False: Exit Function
If tmpToday >= tmpLastDate Then
If tmpToday > tmpAllowDays Then fCheckDateValid = False: Exit Function
If tmpToday = tmpLastDate Then
If tmpLastTime > tmpCurrTime + 15 Then
tmpResult = False
Else
If tmpCurrTime > tmpLastTime Then sSaveLastTime tmpCurrTime
End If
End If
If tmpToday > tmpLastDate Then
sSaveLastDate tmpToday
sSaveLastTime tmpCurrTime
End If
Else
tmpResult = False
End If
End If
fCheckDateValid = tmpResult
End Function
Private Sub sLicDecrement()
If fRNBOsproDecrement(gAdrExecCounter) = False Then End
End Sub
Private Function fGetExecCount() As Long
Dim tmpData As Integer
If fRNBOsproRead(gAdrExecCounter, tmpData) = False Then End
fGetExecCount = SWordToWord(tmpData)
End Function
Private Function fGetAllowDays() As Long
Dim tmpData As Integer
If fRNBOsproRead(gAdrAllowDateLimit, tmpData) = False Then End
fGetAllowDays = SWordToWord(tmpData)
End Function
Private Function fGetAllowLic() As Long
Dim tmpData As Integer
If fRNBOsproRead(gAdrNetworkLic, tmpData) = False Then End
fGetAllowLic = SWordToWord(tmpData)
End Function
'* 10. Now verify that the key is the correct key, and they are still licensed to use it:
Public Function fQueryDongle() As Boolean
Dim QueryStr As DATAQUERY
Dim ExpectedResponse As DATAQUERY
Dim ResponseStr As DATAQUERY
Dim Response32 As Long
Dim tmpResult As Long
Dim TableIndex As Integer
Dim QueryLength As Integer
Dim compare As Boolean
Dim CompIndex As Integer
' Get the query value and expected response. TableIndex should be
' set to which item in the query table you would like to use.
Randomize
QueryLength = 4
TableIndex = Int((10 * Rnd) + 1)
QueryStr = GetQueryData(TableIndex)
ExpectedResponse = GetResponseData(TableIndex)
' Query the key
tmpResult = RNBOsproQuery(MyAPIPacket, gAdrLicAlgorithm, QueryStr, ResponseStr, Response32, QueryLength)
' Evaluate Response = Query
compare = True
For CompIndex = 0 To QueryLength - 1
compare = compare And (ResponseStr.Data(CompIndex) = ExpectedResponse.Data(CompIndex))
Next CompIndex
If Not compare Then
' If responses don't match display error message something to the extent of:
' "This demo has expired, call your distributor to purchase a copy..."
' then terminate the app...
' Or you could give the user the option to retry with a different key.
sRNBOsproReleaseLicense
End
End If
fQueryDongle = compare
End Function
Public Function fGetDBPassword() As String
Dim tmpData As Integer
If fRNBOsproRead(gAdrDBPassword, tmpData) = True Then
fGetDBPassword = Str(SWordToWord(tmpData))
End If
End Function
Public Function GetOpenPassword() As Long
Dim tmpResult As Boolean
Dim tmpData As Integer
Dim tmpRetVal As Long
tmpResult = fRNBOsproFormatPacket
tmpResult = tmpResult And fRNBOsproInitialize
tmpResult = tmpResult And fRNBOsproContactServer("localhost")
tmpResult = tmpResult And fRNBOsproFindFirstUnit
If tmpResult = True Then
If fRNBOsproRead(gAdrDBPassword, tmpData) = True Then
GetOpenPassword = SWordToWord(tmpData)
Else
GetOpenPassword = 0
End If
ReleaseDongle
Else
ReleaseDongle
GetOpenPassword = 0
End If
End Function
Public Sub fShowRemainLic()
Dim tmpDays As String
Dim tmpExec As String
Dim tmpExecCount As Long
Dim tmpLastDate As Long
Dim tmpDateDiff As Long
Dim tmpAllowDays As Long
Dim tmpLastTime As Integer
Dim tmpCurrTime As Integer
If fGetAllowDays <> 65535 Then
tmpLastDate = fGetLastDate
tmpDateDiff = fGetDateDiff
tmpAllowDays = fGetAllowDays
tmpLastTime = fGetLastTime
tmpCurrTime = fGetCurrTime
tmpDays = CStr(tmpAllowDays - (tmpDateDiff + (tmpLastDate - tmpDateDiff)))
Else
tmpDays = "No Authorize"
End If
tmpExecCount = fGetExecCount
If tmpExecCount = 65535 Then
tmpExec = "No Authorize"
Else
tmpExec = CStr(tmpExecCount)
End If
If (tmpLastDate > tmpDateDiff) And (tmpAllowDays <> 65535) Then
MsgBox "Please check your system date and restart Program again !", vbCritical
Else
If tmpDateDiff = tmpLastDate Then
If tmpLastTime > tmpCurrTime + 15 Then
MsgBox "Please check your system time and restart Program again !", vbCritical
Else
MsgBox "Remain Day Authorize : " & tmpDays & " / Remain Exec Authorize : " & tmpExec, vbInformation
End If
Else
MsgBox "Remain Day Authorize : " & tmpDays & " / Remain Exec Authorize : " & tmpExec, vbInformation
End If
End If
End Sub
