;------------------------------------------------------------------------------------------------------------------------------------------ #DefineFunction udfArrayRandom (intLower, intUpper, intRequests, intDebugMode) ; At first try to use the already registered component by ObjectCreate ... strProgId = "RvdW.Random.wsc" intEMLast = ErrorMode (@OFF) LastError () objRnd = ObjectCreate (strProgId) intLastError = LastError () ErrorMode (intEMLast) Drop (intEMLast) If intLastError > 0 ; ... then try alternative method, use the unregistered wsc script by ObjectGet. strFileWsc = FileLocate (strProgId) ; In this case Filename must be same as ProgId. If "" == strFileWsc Then ErrorEvent (-1, 7001, "udfArrayRandom: COM/OLE component wsc file not located: " : strProgId) If 1 != FileExist (strFileWsc) Then ErrorEvent (-1, 7002, "udfArrayRandom: COM/OLE component wsc file not accessible: " : strFileWsc) objRnd = ObjectGet ("script:" : strFileWsc) If !1024 & VarType (objRnd) Then ErrorEvent (-1, 7003, "udfArrayRandom: COM/OLE component not registered: " : strProgId) EndIf ; Use the COM object. ; Note: When setting intRequest less than 1, the COM object's Query method at section "Check for ANY error" will be aborted. objRnd.Init objRnd.LowerLimit = intLower ; Can be negative. objRnd.UpperLimit = intUpper objRnd.NumRequests = Max (1, intRequests) blnQueryResult = objRnd.Query Switch intDebugMode Case 0 Break Case 1 strMsgTitle = "udfArrayRandom: Debug Info" strMsgText = objRnd.ProgId : ", version " : objRnd.Version strMsgText = strMsgText : @LF : "Lower limit = " : objRnd.LowerLimit : @LF : "Upper limit = " : objRnd.UpperLimit : @LF : "NumRequests = " : objRnd.NumRequests strMsgText = strMsgText : @LF : objRnd.Debug Pause (strMsgTitle, strMsgText) Break Case 2 If !blnQueryResult strTimeYmdHms = TimeYmdHms () strFile_WWWBATCH_INI = ShortCutDir ("AppData") : "\WinBatch\Settings\WWWBATCH.INI" IniWritePvt (strTimeYmdHms, "CurrentScript", IntControl (1004, 0, 0, 0, 0), strFile_WWWBATCH_INI) IniWritePvt (strTimeYmdHms, "DebugInfo", objRnd.Debug, strFile_WWWBATCH_INI) ErrorEvent (-1, 7004, "udfArrayRandom: An error occurred, check Debug Info: " : strFile_WWWBATCH_INI) EndIf Break Case 0 EndSwitch :CANCEL arrResult = objRnd.Result ; Create WB array (VT_ARRAY|VARIANT) from the COM's VB array. objRnd = 0 ; Close COM object. If arrResult[0] == "N/A" Then arrResult = ArrDimension (0) ; On error return dim-0 array. Return arrResult ;.......................................................................................................................................... ; This UDF "udfArrayRandom" returns a dim-1 array filled with true random integer numbers. ; ; This UDF needs a proper installed COM object resp. a WSC script component accessible on the path. ; The main work is done within the COM object, written in the script language VBScript. ; The script component "RvdW.Random.wsc" calls the internet server "http://www.random.org/" to retrieve true random integers. ; ; Parameter: ; intLower ....... Lower limit of the integer to be returned. ; intUpper ....... Upper limit of the integer to be returned. ; intRequests .... Number of integers to be returned. ; intDebugMode ... 0 = Do not display debug report. ; 1 = Always display debug report. ; 2 = In case of query error write debug report to WIL's global log file WWWBATCH.INI. ; ; Return vakue: ; A dim-1 array. In case of error a dim-0 array with zero elements will be returned. ; ; This UDF is a functional test for Rob van der Woude's RANDOM.WSC component. Current Version 1.01 by DD.20120108. ; http://www.robvanderwoude.com/vbstech_internet_random_comp.php ; ; (c)Detlev Dalitz.20120108. ;.......................................................................................................................................... #EndFunction ;------------------------------------------------------------------------------------------------------------------------------------------ ; Test. DirChange (DirScript ()) arrResult = udfArrayRandom (1, 6, 3, 0) ; No debug info displayed, just return the array. ;arrResult = udfArrayRandom (1, 6, 3, 1) ; Always display debug info . ;arrResult = udfArrayRandom (1, 3, 3, 2) ; In case of error write Debug info to file WWWBATCH.INI file and throw minor error. ;arrResult = udfArrayRandom (1, 6, -1, 1) ; Bad parameter intRequest, should return an array with one element. ;arrResult = udfArrayRandom (-10, +10, 100, 0) ; Return an array with 100 elements. intRequests = ArrInfo (arrResult, 1) strMsgTitle = "udfArrayRandom|Values=" : intRequests intSum = 0 For intI = 1 To intRequests intSum = intSum + arrResult[intI - 1] fltAvg = 1.0 * intSum / intI strMsgText = "Result[" : intI - 1 : "] = " : arrResult[intI - 1] : @LF : "Sum = " : intSum : @LF : "Average = " : fltAvg Pause (strMsgTitle, strMsgText) Next :CANCEL strFileOut = "udfArrayRandom.txt" intBytesWritten = ArrayFilePut (strFileOut, arrResult) If 1 == FileExist (strFileOut) Then Run (strFileOut, "") If 1 == FileExist (strFileOut) Then FileDelete (strFileOut) Exit ;------------------------------------------------------------------------------------------------------------------------------------------ ; Example: udfArrayRandom (-10, +10, 100, 0) ;------------------------------------------------------------------------------------------------------------------------------------------ ; -6,7,6,7,-9,-9,7,3,4,-7,0,-10,0,-2,1,4,-1,-6,2,-8,; 0,4,9,-4,-4,3,-8,3,9,8,-6,-2,-1,-3,-4,0,0,8,4,-9,7,-2,-5,1,-5,3,-3,-4,2,5, ... ; ... 3,10,-3,-6,-5,5,5,-9,-5,1,; 2,9,-10,8,-5,-1,7,5,-9,-2,-4,-1,10,-5,-9,2,-8,9,-2,6,-8,5,9,1,-9,-2,0,7,-4,-2,-5,3,7,8,6,-2,-7,-9,-4,-4 ;------------------------------------------------------------------------------------------------------------------------------------------ ; -9 -4 -2 ; -9 -5-4 -2 +7 ; -9 -5-4 -2 0 +3 +7 ; -9 -5-4 -2 0 +3 +5 +7 +9 ; -9-8 -6-5-4 -2-1 0 +1+2+3+4+5 +7+8+9 ; -9-8 -6-5-4-3-2-1 0 +1+2+3+4+5+6+7+8+9 ; -10-9-8-7-6-5-4-3-2-1 0 +1+2+3+4+5+6+7+8+9+10 ; -10-9-8-7-6-5-4-3-2-1 0 +1+2+3+4+5+6+7+8+9+10 ;------------------------------------------------------------------------------------------------------------------------------------------ ;------------------------------------------------------------------------------------------------------------------------------------------ ; File: RvdW.Random.wsc ;------------------------------------------------------------------------------------------------------------------------------------------ ; <?xml version="1.0"?> ; <component> ; ; <?component error="true" debug="true"?> ; ; <registration ; description="Random" ; progid="RvdW.Random.wsc" ; version="1.01" ; classid="{bc6e9e65-6390-47fd-9b60-a81e8c18e754}" ; > ; </registration> ; <!-- version="1.01" classid="{bc6e9e65-6390-47fd-9b60-a81e8c18e754}" --> <!-- DD.20120108 --> ; <!-- version="1.00" classid="{ce1407dd-d883-4182-8c1f-bfe67f4b1278}" --> <!-- RvdW.20070815 --> ; ; <public> ; <property name="Busy"> ; <get/> ; </property> ; <property name="Debug"> ; <get/> ; </property> ; <property name="Error"> ; <get/> ; </property> ; <property name="LowerLimit"> ; <get/> ; <put/> ; </property> ; <property name="NumRequests"> ; <get/> ; <put/> ; </property> ; <property name="Result"> ; <get/> ; </property> ; <property name="UpperLimit"> ; <get/> ; <put/> ; </property> ; <property name="Version"> ; <get/> ; </property> ; <property name="ProgId"> ; <get/> ; </property> ; <method name="Query"> ; </method> ; <method name="Init"> ; </method> ; </public> ; ; <script language="VBScript"> ; <![CDATA[ ; ; ' This component uses random.org to retrieve true random integers ; ' ; ' Properties: ; ' Busy R [boolean] If TRUE results aren't available yet ; ' Debug R [string] Debugging information ; ' Error R [boolean] If TRUE check Debug property for description ; ' LowerLimit R/W [integer] Lower limit of the integer to be returned ; ' NumRequests R/W [integer] Number of integers to be returned (default=1) ; ' Result R [array int] Resulting random integers ; ' UpperLimit R/W [integer] Upper limit of the integer to be returned ; ' Version R [string] This class' version number ; ' ; ' Methods: ; ' Query( ) Start the request for (a) new random integer(s) ; ' Init( ) Reset all properties ; ' ; ' Change Log: ; ' August 15, 2007 First public release ; ' ; ' Written by Rob van der Woude ; ' http://www.robvanderwoude.com ; ; Option Explicit ; ; Dim Busy, Debug, Error, Result, Version, ProgId ; Dim LowerLimit, UpperLimit, NumRequests ; ; Init ; ; Function get_Busy( ) ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Busy value read (" & Busy & ")" ; get_Busy = Busy ; End Function ; ; ; Function get_Debug( ) ; get_Debug = Debug & vbCrLf ; End Function ; ; ; Function get_Error( ) ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Error value read (" & Error & ")" ; get_Error = Error ; End Function ; ; ; Function get_LowerLimit( ) ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] LowerLimit value read (" & LowerLimit & ")" ; get_LowerLimit = LowerLimit ; End Function ; ; ; Function put_LowerLimit( newValue ) ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Trying to set LowerLimit value to " _ ; & newValue & vbCrLf _ ; & Space(22) & "Resetting Result value" ; Result = Array( "N/A" ) ; If IsNumeric( newValue ) Then ; If CStr( CInt( newValue ) ) = CStr( newValue ) Then ; LowerLimit = newValue ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] LowerLimit value set to " & newValue ; Else ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Specified LowerLimit (" _ ; & newValue & ") is not an integer" ; Error = True ; End If ; Else ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Specified LowerLimit (" _ ; & newValue & ") is not a number" ; Error = True ; End If ; End Function ; ; ; Function get_NumRequests( ) ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] NumRequests value read (" & NumRequests & ")" ; get_NumRequests = NumRequests ; End Function ; ; ; Function put_NumRequests( newValue ) ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Trying to set NumRequests value to " _ ; & newValue & vbCrLf _ ; & Space(22) & "Resetting Result value" ; Result = Array( "N/A" ) ; If IsNumeric( newValue ) Then ; If CStr( CInt( newValue ) ) = CStr( newValue ) And newValue > 0 Then ; NumRequests = newValue ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] NumRequests value set to " & newValue ; Else ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Specified NumRequests (" _ ; & newValue & ") is not an integer greater than zero" ; Error = True ; End If ; Else ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Specified NumRequests (" _ ; & newValue & ") is not a number" ; Error = True ; End If ; End Function ; ; ; Function get_Result( ) ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Result value read (" & Join( Result, " " ) & ")" ; get_Result = Result ; End Function ; ; ; Function get_UpperLimit( ) ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] UpperLimit value read (" & UpperLimit & ")" ; get_UpperLimit = UpperLimit ; End Function ; ; ; Function put_UpperLimit( newValue ) ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Trying to set UpperLimit value to " _ ; & newValue & vbCrLf _ ; & Space(22) & "Resetting Result value" ; Result = Array( "N/A" ) ; If IsNumeric( newValue ) Then ; If CStr( CInt( newValue ) ) = CStr( newValue ) Then ; UpperLimit = newValue ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] UpperLimit value set to " & newValue ; Else ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Specified UpperLimit (" _ ; & newValue & ") is not an integer" ; Error = True ; End If ; Else ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Specified UpperLimit (" _ ; & newValue & ") is not a number" ; Error = True ; End If ; End Function ; ; ; Function get_Version( ) ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Version value read (" & Version & ")" ; get_Version = Version ; End Function ; ; ; Function get_ProgId( ) ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] ProgId value read (" & ProgId & ")" ; get_ProgId = ProgId ; End Function ; ; ; Function Query( ) ; Dim arrResult, i, intStatus, objHTTP, strAgent, strResult, strURL ; ; Query = True ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Query method started" & vbCrLf _ ; & Space(22) & "Resetting Result value" ; Result = Array( "N/A" ) ; ; ' Check if a valid LowerLimit was specified ; If Not IsNumeric( LowerLimit ) Then ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] LowerLimit value not set (" & LowerLimit & ")" ; Error = True ; End If ; ' Check if a valid UpperLimit was specified ; If Not IsNumeric( UpperLimit ) Then ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] UpperLimit value not set (" & UpperLimit & ")" ; Error = True ; End If ; ; ' Check for ANY error ; If Error Then ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] An error has occurred (Error=" _ ; & Error & ")" & vbCrLf _ ; & Space(22) & "Aborting Query method" ; Result = Array( "N/A" ) ; NumRequests = 1 ; Query = False ; Exit Function ; End If ; ; ' Format the URL for a HTTP request to random.org ; strURL = "http://www.random.org/integers/" _ ; & "?num=" & NumRequests _ ; & "&min=" & LowerLimit _ ; & "&max=" & UpperLimit _ ; & "&col=1&base=10&format=plain&rnd=new" ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] URL string set to:" & vbCrLf _ ; & Space(22) & """" & strURL & """" ; ; ' User agent string (not critical) ; strAgent = "Mozilla/4.0 (compatible; MyApp 1.01; Windows NT 5.1)" ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Agent string set to:" & vbCrLf _ ; & Space(22) & """" & strAgent & """" ; ; ; ' Prepare the HTTP request to random.org ; On Error Resume Next ; Set objHTTP = CreateObject( "WinHttp.WinHttpRequest.5.1" ) ; If Err Then ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Could not instantiate WinHTTPRequest object " _ ; & "(error: " & Err.Number & ")" & vbCrLf _ ; & Space(22) & "Aborting Query method" ; Query = False ; Exit Function ; Else ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] WinHTTPRequest object instantiated successfully" ; End If ; objHTTP.Open "GET", strURL, False ; objHTTP.SetRequestHeader "User-Agent", strAgent ; ; ' Set Busy status ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Set Busy status" ; Busy = True ; ; ' Send the HTTP request and store the results ; objHTTP.Send ; If Err Then ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Error sending WinHTTPRequest" & vbCrLf _ ; & Space(22) & "Error Number : " & Err.Number & vbCrLf _ ; & Space(22) & "Error Description : " & Err.Description & vbCrLf _ ; & Space(22) & "Error Source : " & Err.Source & vbCrLf _ ; & Space(22) & "Returned Status : " & objHTTP.Status & vbCrLf _ ; & Space(22) & "Returned Response : " & objHTTP.ResponseText & vbCrLf _ ; & Space(22) & "Aborting Query method" ; Query = False ; Exit Function ; Else ; intStatus = objHTTP.Status ; strResult = Trim( Replace( objHTTP.ResponseText, vbLf, " " ) ) ; arrResult = Split( strResult ) ; ReDim Preserve arrResult( NumRequests - 1 ) ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] WinHTTPRequest sent" & vbCrLf _ ; & Space(22) & "Returned Status : " & intStatus & vbCrLf _ ; & Space(22) & "Returned Response : " & strResult ; End If ; ; On Error Goto 0 ; ; If intStatus = 200 Then ; Result = arrResult ; Else ; ' Debug info ; Result = Array( "N/A" ) ; NumRequests = 1 ; Error = True ; End If ; ; ' Clear Busy status and release WinHTTPRequest object ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Clear Busy status" ; Busy = False ; Set objHTTP = Nothing ; Debug = Debug & vbCrLf _ ; & "[" & Now & "] Query method ended normally" ; Query = True ; End Function ; ; ; Function Init( ) ; ProgId = "RvdW.Random.wsc" ; Version = "1.01" ; NumRequests = 1 ; LowerLimit = "N/A" ; UpperLimit = "N/A" ; Result = "N/A" ; Busy = "False" ; Error = "False" ; Debug = vbCrLf & "[" & Now & "] Component initialized" ; Init = True ; End Function ; ; ]]> ; </script> ; ; </component> ;------------------------------------------------------------------------------------------------------------------------------------------