У меня почему-то код игнорирует заданные константы условной компиляции.
- Код: Выделить всё
' Руководство к Озадаченному
' Авторское право © 1997 Desaware Inc Все права защищены
' Варианты, поддержавшие этим модулем включают:
' DEMOVERSION - Проверяет хорошо только в среде VB
' DLLCHECK - Требует файл лицензии в среде VB
Imports System.IO
Module Licenser
' Функция GetModuleFileName отыскивает полный путь и имя файла
' для файла, содержащего указанный модуль.
' Windows 95/98/Me: функция GetModuleFilename отыскивает длинные имена
' файлов, когда номер версии приложения больше чем или равен 4.00,
' и длинное имя файла доступно. Иначе, это возвращает только 8.3 имен
' файла формата.
Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameA" (ByVal hModule As Integer, ByVal lpFileName As String, ByVal nSize As Integer) As Integer
' Функция GetModuleHandle отыскивает дескриптор для указанного модуля,
' если файл отображен в адресном пространстве процесса запроса.
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Integer
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lpFileName As String) As Integer
#If DEMOVERSION Or DLLCHECK Then
' Возвратите Истину если
' Демонстрационная версия может работать на любой VB платформе, дизайне или времени выполнения
Public Function IsVBEnvironment() As Boolean
Dim thismod As Integer
Dim thisfile, basename As String
Dim thispos As Short
Dim thischar As String
On Error GoTo nogo
thismod = GetModuleHandle("DSALib.dll")
thisfile = New String(Chr(0), 262)
Call GetModuleFileName(thismod, thisfile, 261)
thisfile = Left$(thisfile, InStr(thisfile, Chr(0)) - 1)
thispos = Len(thisfile)
Do
thischar = Mid$(thisfile, thispos, 1)
If thischar = "\" Or thischar = ":" Then Exit Do
thispos = thispos - 1
Loop While thispos > 0
basename = LCase$(Mid$(thisfile, thispos + 1))
If basename = "vb.exe" Or basename = "vb32.exe" Or basename = "vb6.exe" Or basename = "devenv.exe" Then
IsVBEnvironment = True
End If
Exit Function
nogo:
End Function
#End If
Public Function VerifyLicense() As Boolean
Static PriorVerification As Boolean
Static VerifiedOnce As Boolean
' Быстро вернуться при втором обращении
If PriorVerification Then
VerifyLicense = VerifiedOnce
Exit Function
End If
PriorVerification = True
' Значение по умолчанию нет
VerifiedOnce = False
VerifyLicense = False
#If DEMOVERSION Then
Dim F As frmAbout
F = New frmAbout
If IsVBEnvironment() Then
' Вывести информационный экран
F.MessageType = 0
F.ShowDialog()
VerifiedOnce = True
Else
' Вывести экран отказа лицензии
F.MessageType = 1
F.ShowDialog()
VerifiedOnce = False
End If
VerifyLicense = VerifiedOnce
#End If
#If DLLCHECK Then
If IsVBEnvironment() Then
' Здесь проверить DLL или объект.
' Если не найдено, вернуть VerifyLicense = False
' VerifiedOnce = False
Dim sRet As String
' Fill sRet with Null Chars
sRet = New String(Chr(0), 255)
' Get data from INI file
sRet = Left$(sRet, GetPrivateProfileString("Settings", "lic", "0", sRet, Len(sRet), My.Application.Info.DirectoryPath & "\lic.ini"))
If sRet = "0" Then
Dim F As frmAbout
F = New frmAbout
F.MessageType = 1
F.ShowDialog()
If LCase(F.MessageCode) = "123" Then
WritePrivateProfileString("Settings", "lic", "1", My.Application.Info.DirectoryPath & "\lic.ini")
VerifiedOnce = True
Else
VerifiedOnce = False
End If
F.Close()
Else
VerifiedOnce = True
End If
Else
VerifiedOnce = True
End If
VerifyLicense = VerifiedOnce
Exit Function
#End If
End Function
End Module
