make Macro only run 5 times before requiring registration 6

[richiwatts]

Could someone help me with a bit of code that will only
allow my MS Word macro to run 5 times before requiring a
registration number.

I was thinking of maybe a window poping up saying this if
the 3rd time it has been used would they like to register?
or something like that. And then don't let it work without
a registration number

Once they have a registration number this box wouldn't
show up and the Macro will just run.

Is this something someone could help me with?

many thanks
Richi

 

[JustinEzequiel]

cobbled this quickly so there might be errors but I hope it would give you some ideas

it stores in the registry the number of times your macro has been run

this is not the safest place to store it as anyone with access to the registry can easily modify it if he knows where to look

am running Word 97 on Windows 95 so YMMV

Option Explicit

Sub YourMacro()
  If CheckExpiration Then
    MsgBox "ok to run macro", vbInformation
  Else
    MsgBox "not ok to run macro", vbExclamation
  End If
End Sub

Function CheckExpiration() As Boolean
  Dim nCount As Long
  Dim sRegistration As String
  Dim nRet As Long
  
  On Error GoTo ERRHANDLER
  
  With Application.System
    sRegistration = .ProfileString("Settings", "SerialNum")
    If sRegistration = "a valid number" Then
      CheckExpiration = True
    Else
      nCount = .ProfileString("Settings", "Count")
      If nCount < 6 Then
        .ProfileString(&quot;Settings&quot;, &quot;Count&quot;) = nCount + 1
        CheckExpiration = True
      Else
        MsgBox &quot;You have run this macro more than 5 times&quot; & vbCrLf & _
               &quot;You need to register to be able to run it again&quot;, vbExclamation
      End If
    End If
  End With
  Exit Function
  
ERRHANDLER:
  If Err.Number = 5843 Then
    ' section/keys not found in registry
    Resume Next
  Else
    nRet = MsgBox(Err.Description, vbAbortRetryIgnore + vbExclamation)
    Select Case nRet
      Case vbAbort
        ' exit
      Case vbRetry
        Resume
      Case vbIgnore
        Resume Next
    End Select
  End If
End Function

Sub Register()
  Dim sSerial As String
  sSerial = InputBox(&quot;Enter serial number&quot;, &quot;Register&quot;)
  If StrPtr(sSerial) <> 0 Then
    With Application.System
      .ProfileString(&quot;Settings&quot;, &quot;SerialNum&quot;) = sSerial
    End With
  End If
End Sub

 

[rmikesmith]

Justin,

Nice bit o' code, but what is StrPtr in the line

If StrPtr(sSerial) <> 0 Then

?

I couldn't find a reference to it.

Regards,
Mike

 

[JustinEzequiel]

from what I understand of the function, it returns a pointer to a string variable.

here I use StrPtr to determine if the user clicked on the Cancel button.

if he/she did then the function will return zero (0).

if the user did not enter anything but clicked on the OK button, the function would return a non-zero value.

I guess I did not need it in this case but I got used to using StrPtr whenever I ask for input using an InputBox.

anyway, here's what I found on MSDN:

StrPtr

Strings in Visual Basic are stored as BSTR's. If you use the VarPtr on a variable of type String, you will get the address of the BSTR, which is a pointer to a pointer of the string. To get the address of the string buffer itself, you need to use the StrPtr function. This function returns the address of the first character of the string. Take into account that Strings are stored as UNICODE in Visual Basic.

To get the address of the first character of a String, pass the String variable to the StrPtr function.

Example:



Dim lngCharAddress as Long
Dim strMyVariable as String
strMyVariable = "Some String"
lngCharAddress = StrPtr(strMyVariable)

You can use this function when you need to pass a pointer to a UNIOCODE string to an API call.

 

[richiwatts]

Thanks for the help guys.

As a beginner I have got a bit lost now.

In my template there are 3 macros but it is only one of the macros that i want to have this function on. The other won't do anything unless this has been run. How would the above code know which macro to work with.

Also I am to stick with the first bit of code or do I need to make some changes with the bit of code from the third post.

Thank you.
Richi

 

[rmikesmith]

Richi,

The third bit of code was for my benefit as part of the explanation of the StrPtr function. Stick with Justin's original code. To answer your second question (Justin, jump in here if I've misrepresented anything), the only macro that should be affected is the one containing a call to the CheckExpiration function, as in:

Sub YourMacro()
  If CheckExpiration Then
    MsgBox "ok to run macro", vbInformation
  Else
    MsgBox "not ok to run macro", vbExclamation
  End If
End Sub

I'm sure the MsgBox statements are for demonstration only. You will probably want to use something like:

Sub YourMacro()
  If CheckExpiration = False Then Exit Sub
  ...
  Your existing macro code here
  ...
End Sub

HTH.

Justin - Thanks for the explanation. One other question: Is this a VB only function or is it also available in VBA?

Regards,
Mike

 

[richiwatts]

I have not been able to figure it out!

Also, how does the code know what registration numbers to accept.

I have posted the code for the macro i want it to work with and hope someone could show me how to put it all together.

Sub FindHomonyms()
Dim oRg As Range
Dim LineFromFile As String, LineString As String
Dim path As String
Dim WordArray As Variant
Dim indx As Integer, LparenPos As Integer, RparenPos As Integer
Dim WholeDocument As String

WholeDocument = LCase$(ActiveDocument.Range.Text)

path = ThisDocument.path
Open path & Application.PathSeparator & "data.txt" For Input As #1
Do While Not EOF(1)
Line Input #1, LineString
LparenPos = InStr(LineString, "(&quot
Do While LparenPos > 0
RparenPos = InStr(LparenPos, LineString, &quot&quot
If RparenPos > 0 Then
LineString = Left(LineString, LparenPos - 2) & _
Right(LineString, Len(LineString) - RparenPos)
LparenPos = InStr(LineString, "(&quot
End If
Loop
LineFromFile = LineFromFile & vbTab & LineString
Loop
Close #1

WordArray = Split(LineFromFile, vbTab)

Set oRg = ActiveDocument.Range

Application.ScreenUpdating = False

With oRg.Find
.ClearFormatting
.Replacement.ClearFormatting

.Replacement.Font.Underline = wdUnderlineWavy

.Replacement.Text = &quot;^&&quot; ' <= code for &quot;found text&quot;
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

For indx = 1 To UBound(WordArray)
If InStr(WholeDocument, LCase$(WordArray(indx))) > 0 Then
.Text = WordArray(indx)
.Execute Replace:=wdReplaceAll
End If
StatusBar = UBound(WordArray) - indx
DoEvents
Next indx
End With

Application.ScreenUpdating = True
End Sub

 

[richiwatts]

Still need some help with this one...
Thanks

 

[rmikesmith]

Richi,

To implement this in your macro, set it up like this:

Sub FindHomonyms()
   Dim oRg As Range
   Dim LineFromFile As String, LineString As String
   Dim path As String
   Dim WordArray As Variant
   Dim indx As Integer, LparenPos As Integer, RparenPos As Integer
   Dim WholeDocument As String

   If CheckExpiration = False Then Exit Sub

   WholeDocument = LCase$(ActiveDocument.Range.Text)
   *** Remainder of your macro code here ***

This assumes you've added the function CheckExpiration and the sub Register to a standard code module, as given by Justin.

As to how it knows if it is a valid registration number -- This really isn't defined in Justin's code. As he mentioned, he put it together rather quickly, more as a demo than ready-to-use code. Look at the line

If sRegistration = "a valid number" Then

. This really just shows the logic needed. You would need to modify this. I suggest a function that matches the retrieved value against a lookup table of valid registration numbers. The modified line might look something like

 If IsValidRegNum(sRegistration) Then

. Of course, you still need a function of this sort. I'll try to put something together. Perhaps Justin will also. In the meantime, you can test your code by replacing &quot;a valid number&quot; with a number you make up (enclosed in quotes so it's treated as a string). Next, run the Register sub and enter the same number into the input box. Then when you run your macro (FindHominyms), it should work.

Hope this helps.
Mike

 

[JustinEzequiel]

thanks for helping out Mike

 

[richiwatts]

I guys,

It took me a couple of hours to put together as I didn't really know what I was doing, however, I got there in the end.

It seems to work pretty well, Thank you both.

I hope you guys still don't mind helping me out with this bit with the registration numbers

Just so that i know, how do i reset it so i can keep testing it.

Thanks again guys

 

[rmikesmith]

Richi,

The following can be used to eliminate the registration number so you can test your setup again:

Sub DeleteRegistrationNum()
   With Application.System
     .ProfileString("Settings", "SerialNum") = ""
    End With
End Sub

BTW, you can also do this from the Windows Registry editor. It will be located under

HKEY_CURRENT_USER\Software\Microsoft\Office\8.0\Word\Settings

where the 8.0 may be a different number depending on the version of Office (I'm using 97).

I'm working on the function to check for valid registration number.

Regards,
Mike

 

[richiwatts]

&quot;I was just writing this message when i got yours Mike&quot;

I found out how to reset it in the register so don't worry about answering that. (you answered that so ignore)

I have been playing around with the code all day and I was wondering what this part of the code was for:

Sub YourMacro()
If CheckExpiration Then
MsgBox &quot;ok to run macro&quot;, vbInformation
Else
MsgBox &quot;not ok to run macro&quot;, vbExclamation
End If
End Sub

I never seem to get those messages up. Not that it matters but I was just wondering why.

When the registration number is entered, how would i get a message saying &quot;registration complete&quot; or &quot;invalid registration number&quot;

As you have probably noticed i am not a professional developer. 1 year ago I was doing some work with dyslexic children and during my time there I realised that the English language has so many words that sound the same and are often used wrong &quot;there/their/they're&quot;. The problem with these words are that they are not picked up by word's spell check, making it very difficult for these dyslexic children to see their mistakes. I built up a database of over 2000 of these types of words and wanted to find a way for these students to be able to use them. For the past 4 months I have been asking around forums and friends, and people have been helping me out with the code needed for what i have wanted to achieve.

Sorry if that just really bored you and thanks again for the help...

Richi

 

[rmikesmith]

Richi,

Not at all. I think it's great you took on such a project.

The Sub YourMacro stuff was just an example from JustinEzequiel of how to use the remaining code in your macro. Many people who post example code will put in MsgBox statements to demonstrate the logic with the understanding that in actual use something else, relevant to your situation, will be placed there.

Look at my reply (two back, I think). It shows the beginning of your macro procedure. I have included the line

If CheckExpiration = False Then Exit Sub

to show how you would actually implement Justin's code.

Here is the function I mentioned that will validate the registration number:

Function IsValidRegNum(ByVal SNum As String) As Boolean
Dim TempStr As String
Dim i As Long, j As Long

  Rnd -1
  Randomize 12345678

  For i = 1 To 500
    TempStr = ""
    For j = 1 To 10
      TempStr = TempStr & Int(10 * Rnd)
    Next j
    If SNum = TempStr Then
      IsValidRegNum = True
      Exit Function
    End If
  Next i
  IsValidRegNum = False
  
End Function

To use this function, look at Justin's function CheckExpiration. You will see a line that reads

If sRegistration = "a valid number" Then

. Change this to

If IsValidRegNum(sRegistration) Then

This will check the number stored in the registry against a special lookup &quot;table&quot;.

I have also put together an Excel workbook that displays 500 registration numbers (generated exactly as they are in the IsValidRegNum function) and allows you to indicate those that have been used. Post your email and I'll send it to you. There are additional details about all this but I don't have time right now to cover these.

If you have any other questions, I'll try to answer.

Regards,
Mike

 

[richiwatts]

Thanks Mike!

I will spend tomorrow putting it together and playing around with it and will post on the board if anything is unclear.

If I am going to test different numbers will i just go to the registry and delete the file there everytime to get a fresh start?

e-mail richiwatts@hotmail.com

Richi

 

[CharlesCook]

I'm using VB in Excel. Application does not seem to have a .system so I get an error when I try:

With Application.System
x = .ProfileString(&quot;HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\Forecast&quot;, &quot;QDQ&quot
MsgBox x
End With

Runtime error 438
Object doesn't support this property or method

Am I missing a Reference in Tools|References?

Thanks.... CharlesCook.com
ADP - PeopleSoft
ReportSmith - Crystal Reports - SQR - Query
Reporting - Interfaces - Data Mining

 

[rmikesmith]

CharlesCookdotcom,

You are correct. There is no System object in the Excel object model (makes no sense to me). Richi's original post referred to a Word macro. However, you might try the following:

In Tools/References, set a reference to the Microsoft Word x.x Object Library

In your routine qualify the System object as

Word.System

HTH
Mike

 

[richiwatts]

Hi Mike

I have spent the day playing around and it works really well. Many thanks!!!

One thing I did notice and you may have an easy solution:

I have created a menu button called register &quot;which runs the register macro&quot;, when you run it and put in the reg. number you can run the program, however if you press Register again the entry box is empty, if you press OK the program doesn't work (I think it sets the reg. No. to 0). After that you can't use the program until you put the licence back in. Is it not possible to make the number stay in the entry box so that you don't have to keep typing it in everytime you press the register button.

Richi

 

[rmikesmith]

Richi,

Here is a modified Register procedure:

Sub Register()
Dim sRegNum As String
Dim msg As String
Dim nRtn As Long

  On Error GoTo Register_Error
  With Application.System
    sRegNum = .ProfileString("Settings", "SerialNum")
    If IsValidRegNum(sRegNum) Then
      msg = "This macro is already registered."
      msg = msg & vbCrLf & vbCrLf & "The registration number is  " & sRegNum
      MsgBox msg, vbExclamation + vbOKOnly, "Register Macro"
    Else
      sRegNum = InputBox("Enter Registration number", "Register Macro")
      If StrPtr(sRegNum) <> 0 Then
        If IsValidRegNum(sRegNum) Then
          .ProfileString(&quot;Settings&quot;, &quot;SerialNum&quot;) = sRegNum
        Else
          msg = &quot;Invalid registration number.&quot;
          MsgBox msg, vbExclamation + vbOKOnly, &quot;Register Macro&quot;
        End If
      End If
    End If
  End With
  Exit Sub
  
Register_Error:
  If Err.Number = 5843 Then
    ' section/keys not found in registry
    Resume Next
  Else
    nRet = MsgBox(Err.Description, vbAbortRetryIgnore + vbExclamation)
    Select Case nRet
      Case vbAbort
        ' exit
      Case vbRetry
        Resume
      Case vbIgnore
        Resume Next
    End Select
  End If
End Sub

Substitute this for the existing version. Now when a user clicks the register command button, the procedure will retrieve an existing registration number, if it exists, and check to see if it is valid. If so, a message informs the user that the macro is registered and displays this number. If not, it works like the previous version, with one exception -- It checks user input to verify that the number is valid, otherwise it will not write it to the Widnows Registry.

Regards,
Mike

 

[oharab]

Mike & Justin,
Have a star each. I've been following this thread & have found it to be most interesting. It's people like you two who make this forum the valuable resource it is.

Cheers

Ben ----------------------------------------
Ben O'Hara

http://www.RobotParade.co.uk

----------------------------------------