Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

My Evaluation DLL you've been asking for

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Scott Turchin
    replied
    Had a bug in this whereas the appname was not being correctly written.

    Now it checks for both the install date of the folder the app was run from *AND* it's own set installdate.

    Code:
    'Test code
    Declare Function EvalMessage Lib "CCSREG.DLL"(hWnd As Long,AppName As String,St As String,URL As String) As Long
    Declare Function CheckIfEvaluationExpired Lib "CCSREG.DLL"(AppName As String,ccsFileSpec As String,EvalDaysAllowed As Long)As Long
    
    
            lResult = CheckIfEvaluationExpired(g_szMine,"YOURFILENAMEGOESHERE",30)
            If IsTrue lResult Then
    '           RegNow is a URL to your pay place, ie paypal, Regnow.com etc
                lResult = EvalMessage(CbHndl,g_szMine,"Your evaluation time has expired, please either purchase this product or uninstall it, Thank you for trying " & g_szMine & $CrLf & $CrLf & g_szCCS,RegNow)
                Dialog End CbHndl,%TRUE
            Else 'They have time left
    '           RegNow is a URL to your pay place, ie paypal, Regnow.com etc
                lResult = EvalMessage(CbHndl,g_szMine,g_szEvalMsg,g_RegNow)
            End If
    Code:
    #Compile Dll
    #Register None
    #Include "WIN32API.INC"
    #Resource "resource/CCSREG.PBR"
    %CCSURL1 = %WM_USER + 2015
    %IDT_TIMER1     = %WM_USER + 103
    
    Global osinfo   As OSVERSIONINFO
    Global hCurHand     As Long
    
    Declare Function CheckIfEvaluationExpired(ByVal AppName As String,ByVal ccsFileSpec As String,ByVal EvalDaysAllowed As Long)As Long
    Declare CallBack Function EvalProc() As Long
    Declare Function EvalMessage(hWnd As Long,ByVal AppName As String,ByVal St As String,ByVal URL As String) As Long
    
    'Duplicated from CCS.DLL
    Declare Function GetFileDateandTime(ccsFileSpec As String,ft As SYSTEMTIME) As Long
    Declare Function SetFileDateandTime(ccsFileSpec As String,ft As SYSTEMTIME) As Long
    Declare Function GetPCTimeandDate() As String
    Declare Function GetInstallDate(ft As SYSTEMTIME) As String
    
    Declare Function IsPastExpireDate(InstallDate As String,EvalDays As Long) As Long
    Declare Function GetRegistrationInfo(wRegUser As String,wRegCompany As String) As Long
    
    Declare Function FormatTime(st As SYSTEMTIME,TimeFormat As String,DateFormat As String)As String
    Declare Function uString(ByVal x As String) As String
    Declare Function StrToVbDate(ByVal dt As String) As Double
    
    Declare Function UrlProc (ByVal hWnd As Long, ByVal wMsg As Long, _
                      ByVal wParam As Long, ByVal lParam As Long)  As Long
    Declare Function InitUrlCtrl() As Long
    Declare Function Exist(ByVal CCSFilespec As String)  As Long
    Declare Function CCSGetSystemDir() As String
    Declare Function AppPath() As String
    Declare Function ExeName() As String
    Declare Function GetSetting(lpKey As Long ,ByVal MainKey As String, ByVal SubKey As String, ByVal wDefault As String) As String
    Declare Function GetINIData( IniFile As String,GroupName As String, ParName As String, wDefault As String)As String
    Declare Function WriteIniData(IniFile As String,GroupName As String, ParName As String,wValue As String) As Long
    Declare Function ConvertToBinaryString(charSt As String)As String
    Declare Function ConvertToFullPath(ByVal FileSpec As String) As String
    Declare Function GetWindowsVersion() As String
    
    
    Union QuadFILETIME
      dwLowDateTime  As Dword
      dwHighDateTime As Dword
      qdTime         As Quad
    End Union
    
    
    %CCS = 2006
    %LOCK = 2004
    %IMAGE = %WM_USER + 1024
    %HK   = %HKEY_LOCAL_MACHINE
    %OneDay      =   864000000000&&
    
    
    
    '----------------------------------------------------------
    
    Global aDlg             As Long
    Global pDlg             As Long
    Global g_hIcon          As Long
    Global g_hInst          As Long
    Global g_Result         As Long
    Global g_Copyrite       As String
    
    Global Password         As String
    Global CCS              As String
    Global URL              As String
    Global ghLibTest        As Long
    Global gReason          As Long
    Global gReserved        As Long
    Global gNumOfTimes      As Dword
    Global gNumOfCheck      As Dword
    '------------------------------------------------------------------------------------------
    Function LibMain(ByVal hInstance As Long, _
                     ByVal Reason    As Long, _
                     ByVal Reserved  As Long) Export As Long
    
      ghLibTest = hInstance
      gReason   = Reason
      gReserved = Reserved
      CCS       = "Computer Creations Software"
      URL       = "http://www.tngbbs.com/ccs"
      g_Copyrite = "Copyright © 2000"
      g_hInst   = hInstance
      Incr gNumOfTimes
    
      Select Case Reason
    
        Case %DLL_PROCESS_ATTACH
          gNumOfCheck = 1234
          LibMain = 1   'success!
          Exit Function
    
        Case %DLL_PROCESS_DETACH
           LibMain = 1   'success!
          Exit Function
    
        Case %DLL_THREAD_ATTACH
           LibMain = 1   'success!
          Exit Function
    
        Case %DLL_THREAD_DETACH
           LibMain = 1   'success!
          Exit Function
      End Select
    End Function
    
    '------------------------------------------------------------------------------------------
    
    Function CheckIfEvaluationExpired(ByVal AppName As String,ByVal ccsFileSpec As String,ByVal EvalDaysAllowed As Long) Export As Long
    Local hFile     As Long
    Local Himem     As String      'Himem.sys
    Local Bs        As String            'Backspace "\"
    Local ft        As SYSTEMTIME 'Use this one for himem, st for time
    Local it        As SYSTEMTIME 'Use this one for install date on folder installed to
    Local sDate     As String     'Stored Date
    Local x         As Long
    Local lResult    As Long
    
    Himem = CCSGetSystemDir & "\" & "Himem.sys"
    If IsFalse Exist(ByVal ccsFileSpec) Then 'Create a file
        hFile = FreeFile
        Open ccsFileSpec For Output Lock Write As #hFile
    
        'Pad the file with BS to look like an official file
        Print #hFile, ";The following lines are required for compatibility with other programs."
        Print #hFile,";Do not remove them (" + ccsFileSpec + " needs to be >1024 bytes)."
    
        For x = 3 To 21
           Print #hFile,";" + String$(71,"x") + Chr$(x)
        Next
        Close #hFile
        'New install? Write file, insert install date return false
        'Write the Install Date to the file now
        lResult = WriteIniData(ccsFileSpec,AppName, "Install Date",GetInstallDate(it))
    Else
        'Look for a previous installation date, sDate not used, "it" will now be used
        sDate = GetINIData( ccsFileSpec,AppName, "Install Date","") 'GetInstallDate(it)
        If IsFalse Len(sDate) Then
            sDate = GetInstallDate(it)
            MsgBox sDate
            lResult = WriteIniData(ccsFileSpec,AppName, "Install Date",sDate)
        End If
    'DEBUG
        If IsTrue IsPastExpireDate(sDate,EvalDaysAllowed) Then 'Checked stored date and date of folder, either busts them.
            Function = %TRUE
        End If
    End If
    
    'Now make our file set to the same date as Himem.sys (A system file)
    'This prevents someone from doing DIR /OD to find last modified file.
    lResult = GetFileDateandTime(Himem,ft)
    lResult = SetFileDateandTime(ccsFileSpec,ft)
    End Function
    '------------------------------------------------------------------------------------------
    'GetInstallDate retrieves the date of folder creation for the applications
    'Default install folder.
    '------------------------------------------------------------------------------
    Function GetInstallDate(ft As SYSTEMTIME) As String
    Local fd        As WIN32_FIND_DATA
    Local hFile     As Long
    Local sTmp      As String
    Local tDay As Asciiz * 64
    Local tTime As Asciiz * 64
    
    sTmp = ExeName
    
    'sTmp = Left$(sTmp,Len(sTmp)-1) 'Remove the backslash
    fd.dwFileAttributes = fd.dwFileAttributes And %FILE_ATTRIBUTE_DIRECTORY
    hFile = FindFirstFile(ByVal StrPtr(sTmp),fd)
    If IsFalse hFile Then Exit Function
    ' -- Convert the file time from UTC to local time
    FileTimeToLocalFileTime fd.ftLastWriteTime, fd.ftLastWriteTime
    ' -- Convert the file time into a compatible system time
    FileTimeToSystemTime fd.ftLastWriteTime, ft
    
    GetTimeFormat 0,0,ft, "hh':'mm':'ss tt", tTime, 64
    GetDateFormat 0,0,ft,"MM-dd-yyyy"  , tDay, 64
    Function = tDay & " " & tTime
    End Function
    '------------------------------------------------------------------------------------------
    '------------------------------------------------------------------------------------------
    'EvalDays is how many days they are allowed To evaluate the software
    'InstallDate will be In this format:
    '           "MMM dd',' yyyy" "hh:mm tt"
    Function IsPastExpireDate(InstallDate As String,EvalDays As Long)Export As Long
    Local ctdate         As Double
    Local indate          As Double
    Local st            As SYSTEMTIME
    Local ct            As SYSTEMTIME
    'Convert InstallDate to double
    indate = StrToVbDate(InstallDate)
    'Get Current Time
    GetlocalTime ct
    'Convert CurrentDate to double
    SystemTimeToVariantTime ct, ctdate 'Current Time in variant format
    'Compare the two dates and see
    'If it's greater than the allowed evaluation time
    If (ctdate - indate) > EvalDays Then Function = %TRUE
    End Function
    '------------------------------------------------------------------------------------------
    Function SetFileDateandTime(ccsFileSpec As String,ft As SYSTEMTIME)Export As Long
    Local hFile     As Long
    Local Result    As Long
    Local ccsFileTime  As FILETIME
    Local fLocTime  As FILETIME
    
    hFile = CreateFile(ccsFileSpec + Chr$(0), ByVal %GENERIC_READ Or %GENERIC_WRITE, _
                        ByVal 0, ByVal %NULL, ByVal %OPEN_ALWAYS, _
                        ByVal %FILE_ATTRIBUTE_NORMAL, ByVal %NULL)
    
    ' convert system date/time to file structure.
    SystemTimeToFileTime ft, fLocTime
    ' convert local file time to UTC file time
    ' setfiletime expects a time that is relative to utc time.
    LocalFileTimeToFileTime fLocTime, ccsFileTime
    ' set the file time
    Result = SetFileTime(ByVal hFile, ByVal %NULL, ByVal %NULL, ccsFileTime)
    CloseHandle hFile
    Function = Result
    End Function
    '------------------------------------------------------------------------------------------
    Function GetFileDateandTime(ccsFileSpec As String,ft As SYSTEMTIME)Export As Long
    Dim fd          As WIN32_FIND_DATA
    Local hFile     As Long
    hFile = FindFirstFile(ByVal StrPtr(ccsFileSpec),fd)
    If IsFalse hFile Then Exit Function
    ' -- Convert the file time from UTC to local time
    FileTimeToLocalFileTime fd.ftLastWriteTime, fd.ftLastWriteTime
    ' -- Convert the file time into a compatible system time
    FileTimeToSystemTime fd.ftLastWriteTime, ft
    Function = %TRUE
    End Function
    '------------------------------------------------------------------------------------------
    Function EvalMessage(hWnd As Long,ByVal AppName As String,ByVal St As String,ByVal URL As String)Export As Long
    If IsTrue Len(URL) Then InitUrlCtrl
    Dialog New hWnd,AppName,,, 250,80,%WS_CAPTION Or %WS_SYSMENU  To aDlg
    Control Add Image, aDlg, %IMAGE,"#2006",5,5,55,25
    Control Add Label, aDlg, 1, St, 55,1, 200,55
    'URL = https://www.regnow.com/softsell/nph-softsell.cgi?item=4316-3&referrer=1"
    Control Add "CCSURL", aDlg, %CCSURL1, URL ,5,65, 250, 12, %WS_VISIBLE Or %WS_CHILD
    Control Add Button, aDlg, %IDOK, "&OK",180,45,45,16, %BS_DEFAULT
    Dialog Send aDlg, %WM_SETICON, %ICON_BIG, LoadIcon(g_hInst, ByVal %LOCK)
    Control Set Focus aDlg, %IDOK
    Dialog Show Modal aDlg Call EvalProc
    Function = 1
    End Function
     '-----------------------------------------------------------------------------------------
    
    CallBack Function EvalProc() As Long
    Local wMsg   As Long
    Local wParam As Long
    Local lParam As Long
    
    wMsg = CbMsg
    lParam = CbLParam
    wparam = CbWParam
    
    Select Case wMsg
        Case %WM_INITDIALOG
            Control Set Focus CbHndl,%IDOK
            SetTimer CbHndl, %IDT_TIMER1,  30000, ByVal %NULL
    
        Case %WM_TIMER
            Select Case CbWParam
              Case %IDT_TIMER1
                 Dialog End CbHndl, 1
            End Select
    
        Case %WM_DESTROY
             KillTimer CbHndl, %IDT_TIMER1
    
        Case %WM_COMMAND
            Select Case LoWrd(wParam)
                Case %IDOK
                    Dialog End aDlg, 1
                    Exit Function
            End Select
    End Select
    End Function
     '-----------------------------------------------------------------------------------------
    Function GetPCTimeandDate() Export As String
    Local st                As SYSTEMTIME
    Local tDay              As Asciiz * 64
    Local tTime             As Asciiz * 64
    
    GetLocalTime st
    ' -- Create a date string using the local settings
    GetDateFormat %LOCALE_USER_DEFAULT, %NULL, st, "MMM dd',' yyyy", tDay, 64
    ' -- Create a time string using the local settings
    GetTimeFormat %LOCALE_USER_DEFAULT, %TIME_NOSECONDS, st, "hh:mm tt", tTime, 64
    Function = tDay + " " + tTime
    End Function
    '------------------------------------------------------------------------------------------
    Function GetRegistrationInfo(wRegUser As String,wRegCompany As String) Export As Long
    Local RegKey As String
    osinfo.dwOsVersionInfoSize = SizeOf(osinfo)
    GetVersionEx osinfo
    If osinfo.dwPlatformId = %VER_PLATFORM_WIN32_NT Then
       RegKey = "Software\Microsoft\Windows NT\CurrentVersion"
    Else
       RegKey = "Software\Microsoft\Windows\CurrentVersion"
    End If
    wRegUser = GetSetting(%HK ,ByVal  RegKey, "RegisteredOwner","")
    wRegCompany = GetSetting(%HK ,ByVal RegKey,"RegisteredOrganization","")
    End Function
    '------------------------------------------------------------------------------
    '------------------------------------------------------------------------------------------
    '------------------------------------------------------------------------------
    Function UrlProc (ByVal hWnd As Long, ByVal wMsg As Long, _
                      ByVal wParam As Long, ByVal lParam As Long) Export As Long
    
      Static zText    As Asciiz * 128
      Static hDC      As Long
      Static tRect    As RECT
      Static LpPaint  As PaintStruct
      Static x        As Long
      Static hBrush   As Long
      Static hFont    As Long
      Static lf       As LOGFONT
      Static TxtColor As Long
      Static TxtBack  As Long
      Static sz       As SIZEL
    
      Select Case wMsg
    
        '** Get the colors and create a brush for the background
        Case %WM_CREATE
          TxtColor = %Blue
          TxtBack  = GetSysColor(%COLOR_3DFACE)
          hBrush   = CreateSolidBrush(TxtBack)
    
        '** Add an underline to the wDefault dialog font
        Case %WM_SETFONT
          hFont = wParam
          GetObject hFont, SizeOf(lf), ByVal VarPtr(lf)
          lf.lfUnderline = 1
          hFont = CreateFontIndirect(lf)
          Function = 0
          Exit Function
    
        Case %WM_MOUSEMOVE
          GetWindowText hWnd, zText, 128
          zText = Extract$(zText,";")
          hDC = GetDC(hWnd)
          SelectObject hDC, hFont
          GetTextExtentPoint32 hDC, zText, Len(zText), sz
          ReleaseDC hWnd, hDC
          If (LoWrd(lParam) > sz.cx) Or (HiWrd(lParam) > sz.cy) Then
    '        SetCursor hCurArrow
          Else
            SetCursor hCurHand
          End If
    
        '** If the left mouse button is clicked, we're in business
        Case %WM_LBUTTONDOWN
          GetWindowText hWnd, zText, 128
          x = InStr(zText, ";")
          zText = Mid$(zText, x + 1)
          ShellExecute ByVal %NULL, "open", zText, ByVal %NULL, ByVal %NULL, %SW_SHOWNORMAL
          Function = 0
          Exit Function
    
        '** Display the URL in the dialog
        Case %WM_PAINT
          GetWindowText hWnd, zText, 128
          zText = Extract$(zText, ";")
          hDC = BeginPaint(hWnd, LpPaint)
            SelectObject hDC, hFont
            GetClientRect hWnd, tRect
            SetBkMode hDC, %TRANSPARENT
            SetTextColor hDC, TxtColor
            DrawText hDC, zText, -1, tRect, %DT_SINGLELINE
          EndPaint hWnd, LpPaint
          Function = 0
          Exit Function
    
        '** Draw the background
        Case %WM_ERASEBKGND
          hDC = wParam
          GetClientRect hWnd, tRect
          FillRect hDC, tRect, hBrush
          Function = 1
          Exit Function
    
      End Select
    
      '* wDefault processing for other messages.
      Function = DefWindowProc(hWnd, wMsg, wParam, lParam)
    
    End Function
    '------------------------------------------------------------------------------------------
    Function InitUrlCtrl()Export As Long
    
      Local wc          As WNDCLASS
      Local szClassName As Asciiz * 10
      Local hLib        As Long
      Local z           As Asciiz * 260
      szClassName      = "CCSURL"
      '---Load the cursor
      GetWindowsDirectory z, SizeOf(z)
      z = z & "\winhlp32.exe"
    
      hLib = LoadLibrary(z)
      If hLib Then
          hCurHand = LoadCursor(hLib, "#106") '<---DO NOT CHANGE THIS!
          FreeLibrary hLib
      End If
    
      '---Register control window class.
      szClassName      = "CCSURL"
      wc.style         = %CS_HREDRAW Or %CS_VREDRAW Or %CS_GLOBALCLASS
      wc.lpfnWndProc   = CodePtr(UrlProc)
      wc.cbClsExtra    = 0
      wc.cbWndExtra    = 0    ' 4 pre allocated bytes at offset %GWL_USERDATA
      wc.hInstance     = GetModuleHandle(ByVal %NULL)
      wc.hIcon         = %NULL
      wc.hCursor       = %NULL
      wc.hbrBackground = %COLOR_WINDOW + 1
      wc.lpszMenuName  = %NULL
      wc.lpszClassName = VarPtr(szClassName)
    
      Function = RegisterClass(wc)
    End Function
    '------------------------------------------------------------------------------------------
    '------------------------------------------------------------------------------------------
    Function Exist(ByVal CCSFilespec As String) Export As Long
      Local hDir     As Dword
      Local FindData As WIN32_FIND_DATA
    
      FindData.dwFileAttributes = %FILE_ATTRIBUTE_DIRECTORY
      hDir = FindFirstFile(ByVal StrPtr(CCSFilespec), FindData)
      If hDir = %INVALID_HANDLE_VALUE Then
          Function = %FALSE
          Exit Function     'file not found
      Else
          Function = %TRUE
      End If
      FindClose hDir
    End Function
    '------------------------------------------------------------------------------------------
    '------------------------------------------------------------------------------------------
    Function CCSGetSystemDir() Export As String
    Local lResult As Long
    Local buff As Asciiz * %MAX_PATH
    lResult = GetSystemDirectory(buff,SizeOf(buff))
    Function = buff
    End Function
    '------------------------------------------------------------------------------------------
    Function AppPath() Export As String
        Local zTmp As Asciiz * 256
        Local sTmp As String
        LenExeName& = GetModuleFileName(ByVal %NULL, zTmp, SizeOf(zTmp))
        If LenExeName& Then
           LenExeName& = Min&(LenExeName&, SizeOf(zTmp))
           sTmp = Left$(zTmp, LenExeName&)
           sTmp = Left$(sTmp,InStr(-1,sTmp,"\"))
           Function = sTmp
        End If
    End Function
    '------------------------------------------------------------------------------------------
    Function ExeName() Export As String
        Local zTmp As Asciiz * 256
        LenExeName& = GetModuleFileName(ByVal %NULL, zTmp, SizeOf(zTmp))
        If LenExeName& Then
           LenExeName& = Min&(LenExeName&, SizeOf(zTmp))
           Function = Left$(zTmp, LenExeName&)
        End If
    End Function
    '------------------------------------------------------------------------------------------
    
    '=======================================================================================
    ' GetSetting - Retrieves application entry in the Windows registry.
    '
    ' Syntax:
    ' cMainkey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Run"
    ' SubKey   = "BrowserWebCheck"
    '   Value  = GetSetting(%HKEY_CURRENT_USER ,cMainkey, SubKey,"Not Found")
    '   Value should now be equal to "loadwc.exe"
    '
    ' Where:
    '  lpKey   = Which key of 6 to look in (Ie HKEY_LOCAL_MACHINE)
    '  MainKey = Which key under the lpkey to look in
    '  SubKey  = The key containing the pointer to data
    '  wDefault is returned if function returns null
    '  Returns:
    '  Function returns the actual string in the key
    '
    '------------------------------------------------------------------------------'
    
    Function GetSetting(lpKey As Long ,ByVal MainKey As String, ByVal SubKey As String, _
                        ByVal wDefault As String) Export As String
    
      Local Result  As Long
      Local KeyType As Long
      Local Buffer  As String * 2048
      Local kSize    As Long
      Local hKey    As Long
      Local sTmp    As String
    
    If Len(MainKey) = 0 Then
        Function = wDefault
        Exit Function
    End If
    
    ' ** Open the section
    If RegOpenKeyEx(lpKey, ByVal StrPtr(MainKey),0,  %KEY_ALL_ACCESS, hKey) <> %ERROR_SUCCESS Then
        Function = wDefault
        Exit Function
    End If
    ' ** Get the key value
    kSize = SizeOf(Buffer)
    Result = RegQueryValueEx(hKey,ByVal StrPtr(SubKey), 0, KeyType, Buffer, kSize)
    
    ' ** Close the registry
    RegCloseKey hKey
    ' ** Exit if not successful or nothing there
    If (Result <> %ERROR_SUCCESS) Or (kSize = 0) Then
        Function = wDefault
        Exit Function
    End If
    
    ' ** Return the data
    If KeyType = %REG_SZ Then
        sTmp = Left$(Buffer, kSize - 1)
    Else
        sTmp = Left$(Buffer, kSize)
    End If
    Function = Trim$(Remove$(sTmp,Chr$(0)))
    End Function
    '------------------------------------------------------------------------------------------
    Function GetINIData( IniFile As String,GroupName As String, ParName As String, wwDefault As String) Export As String
    Local Result     As Long
    Local zGroupName As Asciiz * 125
    Local zParname   As Asciiz * 125
    Local zData      As Asciiz * 150
    Local zwDefault   As Asciiz * 150
    Local zIniFile   As Asciiz * 255
    zGroupName = GroupName
    zParname   = Parname
    zIniFile   = IniFile
    zwDefault   = wwDefault
    Result = GetPrivateProfileString(zGroupName,zParName,zwDefault,zData,SizeOf(zData),zIniFile)
    Function = zData
    End Function
    '------------------------------------------------------------------------------------------
    Function WriteIniData(IniFile As String,GroupName As String, ParName As String,wValue As String) Export As Long
    Local zGroupName As Asciiz * 125
    Local zParname   As Asciiz * 125
    Local zValue     As Asciiz * 150
    Local zIniFile   As Asciiz * 255
    Local Result     As Long
    zGroupName = GroupName
    zParname   = Parname
    zIniFile   = IniFile
    zValue     = wValue
    Function = WritePrivateProfileString(zGroupName,zParname,zValue,zIniFile)
    End Function
    '------------------------------------------------------------------------------------------
    'This function does the same thing as GetPCTimeAndDate except uses the input SYSTEMTIME structure
    Function FormatTime(st As SYSTEMTIME,TimeFormat As String,DateFormat As String)Export As String
    Local tTime As Asciiz * 64
    Local tDay  As Asciiz * 64
    
    'TimeFormat =  "hh':'mm':'ss tt"
    'DateFormat = "mm-dd-yyyy"
    
    GetTimeFormat 0,0,st, ByVal StrPtr(TimeFormat), tTime, 64
    GetDateFormat 0,0,st,ByVal StrPtr(DateFormat), tDay, 64
    MsgBox tDay
    Function = tDay & " " & tTime
    End Function
    '------------------------------------------------------------------------------------------
    '===================================<Time Conversion Functions to SYSTEMTIME>==================
    Function uString(ByVal x As String)Export As String
    Local y As String
    Local n As Integer
    
    If Len(x) Then
      For n = 1 To Len(x)
          y = y + Mki$(Asc(x, n))
      Next n
    End If
    Function = y
    End Function
    
    '------------------------------------------------------------------------------
    
    Function StrToVbDate(ByVal dt As String) Export As Double
      Local x      As Long
      Local y      As String
      Local vbdate As Double
      Local lResult As Long
      Local stDay   As String
      Local styear  As String
      Local stMonth As String
    
    
    '  02-01-14
    '  stday = Mid$(dt,7,2)
    '  stYear = Left$(dt,2)
    '  stMonth = Mid$(dt,4,2)
    '  Mid$(dt,4,2) = stday
    '  Mid$(dt,7,2) = styear
    '  Mid$(dt,1,2) = stMonth
      dt = uString(dt)
      lResult = VarDateFromStr(ByVal StrPtr(dt),%LOCALE_USER_DEFAULT, 0, vbdate)
      Select Case lResult
            Case %FALSE
               Function = vbdate
            Case %DISP_E_TYPEMISMATCH 'Can't convert string to date, set 0 and invalidate
               Function = 0
            Case %DISP_E_OVERFLOW
               Function = -1
            Case %E_OUTOFMEMORY      'Throw exception here
               Function = %FALSE
      End Select
    End Function
    '-----------------------------------------------------------------------------------
    Function ConvertToBinaryString(charSt As String)Export As String
    Local y As Long
    Local x As Long
    Local PosPtr As Long
    Local St As String
    Local NewKeySt As String
    
    y = Len(charSt)
    For x = 1 To y Step 2
        St = Mid$(charSt,x,2)
        NewKeySt = NewKeySt + Chr$(Val("&h" + St))
    Next
    Function = NewKeySt
    End Function
    '=========================================================================================================
    Function ConvertToFullPath(ByVal FileSpec As String)Export  As String
    Local zTmp      As Asciiz * %MAX_PATH
    Local Nullo     As Asciiz * 2
    Local lResult   As Long
    lResult = GetFullPathName(ByVal StrPtr(FileSpec),ByVal SizeOf(zTmp),ByVal VarPtr(zTmp),Nullo)
    Function = zTmp
    End Function
    '=========================================================================================================
    Function GetWindowsVersion()Export  As String
    '*****OS VERSION*****
    Local osi       As OSVERSIONINFOEX
    Local lResult   As Long
    Local sVer      As String
    osi.dwOsVersionInfoSize = SizeOf(OSVERSIONINFOEX)
    lResult = GetVersionEx(osi)
    If IsFalse lResult Then
        osi.dwOsVersionInfoSize = SizeOf(OsVersionInfo)
        lResult = GetVersionEX(osi)
    End If
    
    Select Case osi.dwPlatformID
              Case %VER_PLATFORM_WIN32_NT 'NT-2000-XP-2003 Platform
                    If osi.dwMajorVersion = 6 Then _
                        sVer = "Microsoft Windows Vista, "
                    If osi.dwMajorVersion = 5 And osi.dwMinorVersion = 2 Then _
                        sVer = "Microsoft Windows Server 2003 Family, "
                    If osi.dwMajorVersion = 5 And osi.dwMinorVersion = 1 Then _
                        sVer = "Microsoft Windows XP "
                    If osi.dwMajorVersion = 5 And osi.dwMinorVersion = 0 Then _
                        sVer = "Microsoft Windows 2000 "
                    If osi.dwMajorVersion <= 4 Then _
                        sVer = "Microsoft Windows NT " & Trim$(Str$(osi.dwMajorVersion)) _
                            & "." & Trim$(Str$(osi.dwMinorVersion))
                 Select Case osi.wProductType
                        Case %VER_NT_WORKSTATION 'workstation Product
                            If osi.dwMajorVersion <= 4 Then
                                sver = sver & "Workstation "
                            ElseIf (osi.wSuiteMask And %VER_SUITE_PERSONAL) Then
                                sver = sver & "Home Edition "
                            Else
                                sver = sver & "Professional "
                            End If
                        Case %VER_NT_DOMAIN_CONTROLLER, %VER_NT_SERVER  'Server Product
                            If osi.dwMajorVersion = 5 And osi.dwMinorVersion = 2 Then
                                If (osi.wSuiteMask And %VER_SUITE_DATACENTER) Then
                                    sver = sver & "Datacenter Edition "
                                ElseIf (osi.wSuiteMask And %VER_SUITE_ENTERPRISE) Then
                                    sver = sver & "Enterprise Edition "
                                ElseIf (osi.wSuiteMask And %VER_SUITE_BLADE) Then
                                    sver = sver & "Web Edition "
                                Else
                                    sver = sver & "Standard Edition "
                                End If
                            ElseIf osi.dwMajorVersion = 5 And osi.dwMinorVersion = 0 Then
                                If (osi.wSuiteMask And %VER_SUITE_DATACENTER) Then
                                    sver = sver & "Datacenter Server "
                                ElseIf (osi.wSuiteMask And %VER_SUITE_ENTERPRISE) Then
                                    sver = sver & "Advanced Server "
                                Else
                                    sver = sver & " Server "
                                End If
                            Else
                                If (osi.wSuiteMask And %VER_SUITE_ENTERPRISE) Then
                                    sver = sver & "Server, Enterprise Edition "
                                Else
                                    sver = sver & "Server "
                                End If
                            End If
                        End Select
                    sver = sver & osi.szCSDVersion &  " (Build " & Trim$(Str$(osi.dwBuildNumber))  & ")"
              Case %VER_PLATFORM_WIN32_WINDOWS '95-98-ME Platform
                            If osi.dwMajorversion = 4 And osi.dwMinorVersion = 0 Then
                                sver = "Microsoft Windows 95 "
                                    If Trim$(osi.szCSDVersion) = "C" Or Trim$(osi.szCSDVersion) = "B" Then _
                                    sver = sver & "OSR2 "
                            End If
                            If osi.dwMajorVersion = 4 And osi.dwMinorVersion = 10 Then
                                sver = "Microsoft Windows 98 "
                                    If Trim$(osi.szCSDVersion) = "A" Then _
                                        sver = sver & "Second Edition"
                           End If
                           If osi.dwMajorversion = 4 And osi.dwMinorVersion = 90 Then _
                               sver = "Microsoft Windows Millennium Edition "
              Case %VER_PLATFORM_WIN32s '3.1, 3.11 with win32s installed
                    sver = "Microsoft Win32s"
    End Select
    Function = sver
    End Function
    '=========================================================================================================
    '-----------------------------------------------------------------------------------
    '-----------------------------------------------------------------------------------
    '-----------------------------------------------------------------------------------

    Leave a comment:


  • Scott Turchin
    started a topic My Evaluation DLL you've been asking for

    My Evaluation DLL you've been asking for

    Since a lot of people have asked me for this and I don't use it anymore - here it is.

    THe code in the other DLL's can be found on this message board, a LOT of this is cut/paste except for teh creativity of writing to the file/format etc...

    It can be detected by any program that watches file I/O, deleting the file would give a user another 30 days.

    Code:
    #Compile Dll
    #Register None
    #Include "WIN32API.INC"
    #Resource "CCSREG.PBR"
    %CCSURL1 = %WM_USER + 2015
    
    Global osinfo   As OSVERSIONINFO
    
    Declare Function CheckIfEvaluationExpired(AppName As String,ccsFileSpec As String,EvalDaysAllowed As Long)As Long
    Declare CallBack Function EvalProc() As Long
    Declare Function EvalMessage(hWnd As Long,AppName As String,St As String,URL As String) As Long
    
    'Duplicated from CCS.DLL
    Declare Function GetFileDateandTime(ccsFileSpec As String,ft As SYSTEMTIME) As Long
    Declare Function SetFileDateandTime(ccsFileSpec As String,ft As SYSTEMTIME) As Long
    Declare Function GetPCTimeandDate() As String
    Declare Function GetInstallDate(ft As SYSTEMTIME) As String
    
    Declare Function IsPastExpireDate(InstallDate As String,EvalDays As Long) As Long
    Declare Function GetRegistrationInfo(wRegUser As String,wRegCompany As String) As Long
    
    Declare Function InitUrlCtrl Lib "CCS.DLL"() As Long
    Declare Function Exist Lib "CCS.DLL"(ByVal filespec As String)As Long
    Declare Function CCSGetSystemDir Lib "CCS.DLL"() As String
    Declare Function GetSetting Lib "CCS.DLL"(lpKey As Long ,ByVal MainKey As String, ByVal SubKey As String, _
                        ByVal wDefault As String) As String
    Declare Function GetINIData Lib "CCS.DLL"( IniFile As String,GroupName As String, ParName As String, wDefault As String)As String
    Declare Function WriteIniData  Lib "CCS.DLL"(IniFile As String,GroupName As String, ParName As String,wValue As String) As Long
    Declare Function AppPath Lib "CCS.DLL"() As String
    Declare Function FormatTime Lib "CCSDATE.DLL"(st As SYSTEMTIME,TimeFormat As String,DateFormat As String)As String
    Declare Function uString Lib "CCSDATE.DLL"(ByVal x As String) As String
    Declare Function StrToVbDate Lib "CCSDATE.DLL"(ByVal dt As String) As Double
    
    
    Union QuadFILETIME
      dwLowDateTime  As Dword
      dwHighDateTime As Dword
      qdTime         As Quad
    End Union
    
    
    %CCS = 2006
    %LOCK = 2004
    %IMAGE = %WM_USER + 1024
    %HK   = %HKEY_LOCAL_MACHINE
    %OneDay      =   864000000000&&
    
    
    
    '----------------------------------------------------------
    
    Global aDlg             As Long
    Global pDlg             As Long
    Global g_hIcon          As Long
    Global g_hInst          As Long
    Global g_Result         As Long
    Global g_Copyrite       As String
    
    Global Password         As String
    Global CCS              As String
    Global URL              As String
    Global ghLibTest        As Long
    Global gReason          As Long
    Global gReserved        As Long
    Global gNumOfTimes      As Dword
    Global gNumOfCheck      As Dword
    '------------------------------------------------------------------------------------------
    Function LibMain(ByVal hInstance As Long, _
                     ByVal Reason    As Long, _
                     ByVal Reserved  As Long) Export As Long
    
      ghLibTest = hInstance
      gReason   = Reason
      gReserved = Reserved
      CCS       = "Computer Creations Software"
      URL       = "http://www.tngbbs.com/ccs"
      g_Copyrite = "Copyright © 2000"
      g_hInst   = hInstance
      Incr gNumOfTimes
    
      Select Case Reason
    
        Case %DLL_PROCESS_ATTACH
          gNumOfCheck = 1234
          LibMain = 1   'success!
          Exit Function
    
        Case %DLL_PROCESS_DETACH
           LibMain = 1   'success!
          Exit Function
    
        Case %DLL_THREAD_ATTACH
           LibMain = 1   'success!
          Exit Function
    
        Case %DLL_THREAD_DETACH
           LibMain = 1   'success!
          Exit Function
      End Select
    End Function
    
    '------------------------------------------------------------------------------------------
    
    Function CheckIfEvaluationExpired(AppName As String,ccsFileSpec As String,EvalDaysAllowed As Long) Export As Long
    Local hFile     As Long
    Local Himem     As String     'Himem.sys
    Local Bs        As String     'Backspace "\"
    Local ft        As SYSTEMTIME 'Use this one for himem, st for time
    Local it        As SYSTEMTIME 'Use this one for install date on folder installed to
    Local cDate     As String     'Current Date
    Local sDate     As String     'Stored Date
    Local x         As Long
    Local lResult    As Long
    
    Himem = CCSGetSystemDir & "\" & "Himem.sys"
    'MsgBox "Created date: " & GetInstallDate
    
    'ccsFileSpec is any file you create, ie MSCCSDLL.DLL - looks official but is a text file when done
    'It always goes in the Windows\system32 folder  (CCSGetSystemDir)
    If IsFalse Exist(ByVal ccsFileSpec) Then 'Create a file
        hFile = FreeFile
        Open ccsFileSpec For Output Lock Write As #hFile
    
        'Pad the file with BS to look like an official file
        Print #hFile, ";The following lines are required for compatibility with other programs."
        Print #hFile,";Do not remove them (" + ccsFileSpec + " needs to be >1024 bytes)."
    
        For x = 3 To 21
           Print #hFile,";" + String$(71,"x") + Chr$(x)
        Next
        Close #hFile
        'New install? Write file, insert install date return false
        'Write the Install Date to the file now
        lResult = WriteIniData(ccsFileSpec,AppName, "Install Date",GetInstallDate(it))
    Else
        'Look for a previous installation date, sDate not used, "it" will now be used
        sDate = GetINIData( ccsFileSpec,AppName, "Install Date", GetInstallDate(it))
        If IsFalse Len(sDate) Then
            lResult = WriteIniData(ccsFileSpec,AppName, "Install Date",GetInstallDate(it))
        End If
        If IsTrue IsPastExpireDate(sDate,EvalDaysAllowed) Then
            Function = %TRUE
        End If
    End If
    
    'Now make our file set to the same date as Himem.sys (A system file)
    'This prevents someone from doing DIR /OD to find last modified file.
    lResult = GetFileDateandTime(Himem,ft)
    lResult = SetFileDateandTime(ccsFileSpec,ft)
    End Function
    '------------------------------------------------------------------------------------------
    'GetInstallDate retrieves the date of folder creation for the applications
    'Default install folder.
    '------------------------------------------------------------------------------
    Function GetInstallDate(ft As SYSTEMTIME) As String
    Local fd        As WIN32_FIND_DATA
    Local hFile     As Long
    Local sTmp      As String
    
    sTmp = AppPath
    sTmp = Left$(sTmp,Len(sTmp)-1) 'Remove the backslash
    fd.dwFileAttributes = fd.dwFileAttributes And %FILE_ATTRIBUTE_DIRECTORY
    hFile = FindFirstFile(ByVal StrPtr(sTmp),fd)
    If IsFalse hFile Then Exit Function
    ' -- Convert the file time from UTC to local time
    FileTimeToLocalFileTime fd.ftLastWriteTime, fd.ftLastWriteTime
    ' -- Convert the file time into a compatible system time
    FileTimeToSystemTime fd.ftLastWriteTime, ft
    Function = FormatTime(ft,"hh':'mm':'ss tt","MM-dd-yyyy")
    End Function
    '------------------------------------------------------------------------------------------
    '------------------------------------------------------------------------------------------
    'EvalDays is how many days they are allowed To evaluate the software
    'InstallDate will be In this format:
    '           "MMM dd',' yyyy" "hh:mm tt"
    Function IsPastExpireDate(InstallDate As String,EvalDays As Long)Export As Long
    Local ctdate         As Double
    Local indate          As Double
    Local st            As SYSTEMTIME
    Local ct            As SYSTEMTIME
    'Convert InstallDate to double
    indate = StrToVbDate(InstallDate)
    'Get Current Time
    GetlocalTime ct
    'Convert CurrentDate to double
    SystemTimeToVariantTime ct, ctdate 'Current Time in variant format
    'Compare the two dates and see
    'If it's greater than the allowed evaluation time
    If (ctdate - indate) > EvalDays Then Function = %TRUE
    End Function
    '------------------------------------------------------------------------------------------
    Function SetFileDateandTime(ccsFileSpec As String,ft As SYSTEMTIME)Export As Long
    Local hFile     As Long
    Local Result    As Long
    Local ccsFileTime  As FILETIME
    Local fLocTime  As FILETIME
    
    hFile = CreateFile(ccsFileSpec + Chr$(0), ByVal %GENERIC_READ Or %GENERIC_WRITE, _
                        ByVal 0, ByVal %NULL, ByVal %OPEN_ALWAYS, _
                        ByVal %FILE_ATTRIBUTE_NORMAL, ByVal %NULL)
    
    ' convert system date/time to file structure.
    SystemTimeToFileTime ft, fLocTime
    ' convert local file time to UTC file time
    ' setfiletime expects a time that is relative to utc time.
    LocalFileTimeToFileTime fLocTime, ccsFileTime
    ' set the file time
    Result = SetFileTime(ByVal hFile, ByVal %NULL, ByVal %NULL, ccsFileTime)
    CloseHandle hFile
    Function = Result
    End Function
    '------------------------------------------------------------------------------------------
    Function GetFileDateandTime(ccsFileSpec As String,ft As SYSTEMTIME)Export As Long
    Dim fd          As WIN32_FIND_DATA
    Local hFile     As Long
    hFile = FindFirstFile(ByVal StrPtr(ccsFileSpec),fd)
    If IsFalse hFile Then Exit Function
    ' -- Convert the file time from UTC to local time
    FileTimeToLocalFileTime fd.ftLastWriteTime, fd.ftLastWriteTime
    ' -- Convert the file time into a compatible system time
    FileTimeToSystemTime fd.ftLastWriteTime, ft
    Function = %TRUE
    End Function
    '------------------------------------------------------------------------------------------
    Function EvalMessage(hWnd As Long,AppName As String,St As String,URL As String)Export As Long
    InitUrlCtrl
    Dialog New hWnd,AppName,,, 250,65,%WS_CAPTION Or %WS_SYSMENU  To aDlg
    Control Add Image, aDlg, %IMAGE,"#2006",5,5,18,18
    Control Add Label, aDlg, 1, St, 35,1, 200,45
    Control Add Label, aDlg, 1, g_Copyrite,35,35, 100, 12
    'URL = https://www.regnow.com/softsell/nph-softsell.cgi?item=4316-3&referrer=1"
    Control Add "CCSURL", aDlg, %CCSURL1, "Register at Regnow.com;" & URL ,35,50, 120, 12, %WS_VISIBLE Or %WS_CHILD
    Control Add Button, aDlg, %IDOK, "&OK",180,45,45,16, %BS_DEFAULT
    Dialog Send aDlg, %WM_SETICON, %ICON_BIG, LoadIcon(g_hInst, ByVal %LOCK)
    Control Set Focus aDlg, %IDOK
    Dialog Show Modal aDlg Call EvalProc
    Function = 1
    End Function
     '-----------------------------------------------------------------------------------------
    
    CallBack Function EvalProc() As Long
    Local wMsg   As Long
    Local wParam As Long
    Local lParam As Long
    
    wMsg = CbMsg
    lParam = CbLParam
    wparam = CbWParam
    
    Select Case wMsg
        Case %WM_INITDIALOG
            Control Set Focus CbHndl,%IDOK
        Case %WM_TIMER
        Case %WM_DESTROY
        Case %WM_COMMAND
            Select Case LoWrd(wParam)
                Case %IDOK
                    Dialog End aDlg, 1
                    Exit Function
            End Select
    End Select
    End Function
     '-----------------------------------------------------------------------------------------
    Function GetPCTimeandDate() Export As String
    Local st                As SYSTEMTIME
    Local tDay              As Asciiz * 64
    Local tTime             As Asciiz * 64
    
    GetLocalTime st
    ' -- Create a date string using the local settings
    GetDateFormat %LOCALE_USER_DEFAULT, %NULL, st, "MMM dd',' yyyy", tDay, 64
    ' -- Create a time string using the local settings
    GetTimeFormat %LOCALE_USER_DEFAULT, %TIME_NOSECONDS, st, "hh:mm tt", tTime, 64
    Function = tDay + " " + tTime
    End Function
    '------------------------------------------------------------------------------------------
    Function GetRegistrationInfo(wRegUser As String,wRegCompany As String) Export As Long
    Local RegKey As String
    osinfo.dwOsVersionInfoSize = SizeOf(osinfo)
    GetVersionEx osinfo
    If osinfo.dwPlatformId = %VER_PLATFORM_WIN32_NT Then
       RegKey = "Software\Microsoft\Windows NT\CurrentVersion"
    Else
       RegKey = "Software\Microsoft\Windows\CurrentVersion"
    End If
    wRegUser = GetSetting(%HK ,ByVal  RegKey, "RegisteredOwner","")
    wRegCompany = GetSetting(%HK ,ByVal RegKey,"RegisteredOrganization","")
    End Function
    '------------------------------------------------------------------------------
    '------------------------------------------------------------------------------------------
Working...
X