2004-05-18
DD-Software
 Main Index |
 Backward |
 Forward |
 Top |
 Bottom |
| Page Date 2004-05-18 DD-Software |
|
|
|
MyWbtHelp current version |
|
||||
udfSegSeven (numstr, padlen, mode) |
||||
;------------------------------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfsegseven",IntControl(77,103,0,0,0),@TAB) Then Goto skip_udfsegseven
#DefineFunction udfSegSeven (numstr, padlen, mode)
numstr=StrTrim(numstr)
Select mode
Case 0
If !IsInt(numstr) Then Return ("")
numstr=0+numstr
neg=(numstr<0)
If neg Then numstr=-numstr
Break
Case 1
neg=0
numstr=StrUpper(numstr)
Break
EndSelect
D0=Arrayize(" _ , , _ , _ , , _ , _ , _ , _ , _ , _ , , _ , , _ , _ ",",")
D1=Arrayize("| |, |, _|, _|,|_|,|_ ,|_ , |,|_|,|_|,|_|,|_ ,| , _|,|_ ,|_ ",",")
D2=Arrayize("|_|, |,|_ , _|, |, _|,|_|, |,|_|, _|,| |,|_|,|_ ,|_|,|_ ,| ",",")
A=Arrayize(" , , ",",")
If neg Then A[1]=" _ "
numlen=StrLen(numstr)
For p=1 To numlen
Select mode
Case 0
d=StrSub(numstr,p,1)
Break
Case 1
d=Char2Num(StrSub(numstr,p,1))-48
d=d-(7*(d>9))
Break
EndSelect
A[0]=StrCat(A[0],D0[d])
A[1]=StrCat(A[1],D1[d])
A[2]=StrCat(A[2],D2[d])
Next
padlen=padlen<<2
numstr = (StrCat(StrFixLeft(A[0]," ",padlen),@CRLF,StrFixLeft(A[1]," ",padlen),@CRLF,StrFixLeft(A[2]," ",padlen)))
Drop(A,D0,D1,D2)
Return (numstr)
;..........................................................................................................................................
; Returns a string with number formatted as seven segment number.
; mode=0 = numstr is integer
; mode=1 = numstr is hexstring
; padlen = left pad length
;
; Detlev Dalitz.20020219
;..........................................................................................................................................
#EndFunction
:skip_udfsegseven
;------------------------------------------------------------------------------------------------------------------------------------------
; --- test ---
BoxesUp("700,100,960,240", @NORMAL)
BoxTextFont(1,"Fixedsys",200,99,49)
BoxColor(1,"0,0,0",0)
BoxTextColor(1,"0,221,0")
StopText="Press [Shift+Ctrl] to stop"
:test1
n=0
While !IsKeyBottom(@CTRL&@SHIFT)
hex=Num2Char((n&15)+48+7*((n&15)>9))
BoxDataTag(1,"1")
BoxText(StrCat(StopText,@CRLF,udfSegSeven(hex,1,1)))
BoxDataClear(1,"1")
n=n+1
If (n>15) Then n=0
TimeDelay(.5)
EndWhile
BoxText("stop1")
TimeDelay(2)
:test2
n=-1000
t1=GetTickCount()
While !IsKeyBottom(@CTRL&@SHIFT)
BoxDataTag(1,"1")
BoxText(StrCat(StopText,@CRLF,udfSegSeven(n,5,0)))
BoxDataClear(1,"1")
n=n+1
EndWhile
BoxText("stop2")
TimeDelay(2)
:test3
n=0
t1=GetTickCount()
While !IsKeyBottom(@CTRL&@SHIFT)
t2=GetTickCount()
If (t2>(t1+1000))
BoxDataTag(1,"1")
BoxText(StrCat(StopText,@CRLF,udfSegSeven(n,6,0)," sec"))
BoxDataClear(1,"1")
t1=t2
EndIf
n=n+1
TimeDelay(.9)
EndWhile
BoxText("stop3")
TimeDelay(2)
BoxShut()
Exit
;------------------------------------------------------------------------------------------------------------------------------------------
*EOF*
|
||||
|
||||
udfIsValidCreditCard (CardNumber) |
||||
#DefineFunction udfIsValidCreditCard (CardNumber)
; validates Credit Card, accepts CardNumber as string[16]
C=1
T=0
A=0
L=StrLen(CardNumber)
While (C<=L)
If (L mod 2)
T=Int(StrSub(CardNumber,C,1))
If !(C mod 2)
T=T+T
If (T>9)
T=T-9
EndIf
EndIf
A=A+T
C=C+1
Else
T=Int(StrSub(CardNumber,C,1))
If (C mod 2)
T=T+T
If (T>9)
T=T-9
EndIf
EndIf
A=A+T
C=C+1
EndIf
EndWhile
Return (!(A mod 10))
; if udfIsValidCreditCard("4712070086659474")
; message("Card #%cNumber%","VALID CREDIT CARD")
; Else
; message("Card #%cNumber%","INVALID CREDIT CARD")
; Endif
; appears to work - stan littlefield, stanl@btitelecom.net
; Sunday, May 13, 2001 01:56 PM
; slightly modified by Detlev Dalitz.20020208
#EndFunction
;--- test ---
msgtitle = "Test CreditCard"
CardNumber = "5232100430024684"
msgtext = StrCat(CardNumber,@crlf,ItemExtract(1+udfIsValidCreditCard(CardNumber),"invalid,valid",",")," number")
message(msgtitle,msgtext)
CardNumber = "4712070086659474"
msgtext = StrCat(CardNumber,@crlf,ItemExtract(1+udfIsValidCreditCard(CardNumber),"invalid,valid",",")," number")
message(msgtitle,msgtext)
Exit
|
||||
|
||||
udfIsValidRentenVsnr (sVsnr) |
||||
;------------------------------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfisvalidrentenvsnr",IntControl(77,103,0,0,0),@TAB) Then Goto skip_udfisvalidrentenvsnr
#DefineFunction udfIsValidRentenVsnr (sVsnr)
If (StrLen(sVsnr)<>12) Then Return (@FALSE)
If !IsNumber(StrSub(sVsnr,1,8)) Then Return (@FALSE)
If !IsNumber(StrSub(sVsnr,10,3)) Then Return (@FALSE)
For i=1 To 13
n%i% = 0
Next
n1 = 2 * StrSub(sVsnr,1,1)
n2 = StrSub(sVsnr,2,1)
n3 = 2 * StrSub(sVsnr,3,1)
n4 = 5 * StrSub(sVsnr,4,1)
n5 = 7 * StrSub(sVsnr,5,1)
n6 = StrSub(sVsnr,6,1)
n7 = 2 * StrSub(sVsnr,7,1)
n8 = StrSub(sVsnr,8,1)
n9 = 2 * (Char2Num(StrSub(sVsnr,9,1))-64) / 10
n10 = (Char2Num(StrSub(sVsnr,9,1))-64) mod 10
n11 = 2 * StrSub(sVsnr,10,1)
n12 = StrSub(sVsnr,11,1)
For i=1 To 12
n%i% = (n%i%/10)+(n%i% mod 10)
Next
For i=1 To 12
n13 = n13 + n%i%
Next
n13 = n13 mod 10
IsValidRentenVsnr = (StrSub(sVsnr,12,1)==n13)
Return (IsValidRentenVsnr)
;..........................................................................................................................................
; This function "udfIsValidRentenVsnr" returns a boolean value @false..@true resp. 0..1
; which indicates if the given german social insurance number is valid or not.
; Diese Funktion prueft die Gueltigkeit der Deutschen Rentenversicherungsnummer.
; Vsnr = String[12] = "99999999X999", e.g. "53011254D041"
;
; Detlev Dalitz.20010727
;..........................................................................................................................................
#EndFunction
;------------------------------------------------------------------------------------------------------------------------------------------
:skip_udfisvalidrentenvsnr
;--- test ---
sVsnr = "53011254D041"
sMsgTitle = "Test Sozialversicherungsnummer"
sMsgText = StrCat(sVsnr,@LF,ItemExtract(1+udfIsValidRentenVsnr(sVsnr),"ist falsch.,ist in Ordnung.",","))
Message(sMsgTitle,sMsgText)
Exit
;------------------------------------------------------------------------------------------------------------------------------------------
*EOF*
|
||||
|
||||
udfRulerScale (iLength, iModeBase, iModeDigit) |
||||
;------------------------------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfrulerscale",IntControl(77,103,0,0,0),@TAB) Then Goto skip_udfrulerscale
#DefineFunction udfRulerScale (iLength, iModeBase, iModeDigit)
If (iLength<=0) Then Return ("")
iModeBase = Min(1,Max(0,iModeBase))
iModeDigit = Min(1,Max(0,iModeDigit))
iPMax = 0
iN = iLength
While 1
iN = iN/10
If !iN Then Break
iPMax = iPMax+1
EndWhile
sRuler = StrCat(StrSub(StrFill("0123456789",iLength+1),1+iModeBase,iLength),@CRLF)
For iP=1 To iPMax
sRow = ""
iNMax = iLength/(10**iP)
For iN=0 To iNMax
iDigit = iN mod 10
If iModeDigit Then sFill = iDigit
Else sFill = "_"
sFill = StrFill(sFill,(10**iP)-1)
sRow = StrCat(sRow,iDigit,sFill)
Next
sRow = StrSub(sRow,1+iModeBase,iLength)
sRuler = StrCat(sRow,@CRLF,sRuler)
Next
Return (sRuler)
;------------------------------------------------------------------------------
; This udf "udfRulerScale" creates row/s with numbered columns.
;
; For example: udfRulerScale (32, 0, 1)
; 00000000001111111111222222222233
; 01234567890123456789012345678901
;
; For example: udfRulerScale (32, 1, 0)
; _________1_________2_________3__
; 12345678901234567890123456789012
;
; iLength ........ The length resp. width of the ruler string.
; iModeBase=0 ... Zero based ruler string e.g. "01234"
; iModeBase=1 ... One based ruler string e.g. "12345"
; iModeDigit=0 ... Use Underline character e.g. "_________1_________2"
; iModeDigit=1 ... Use digits to fill the row e.g. "00000000011111111112"
;
; Detlev Dalitz.20020725
;------------------------------------------------------------------------------
#EndFunction
:skip_udfRulerScale
;------------------------------------------------------------------------------------------------------------------------------------------
;--- test ---
MsgTitle = "Demo udfRulerScale (iLength)"
sTmpFile = FileCreateTemp("TMP")
hfa = FileOpen(sTmpFile,"APPEND")
MsgText = StrCat("Test1 udfRulerScale (7,1,1)",@LF,udfRulerScale(7,1,1))
FileWrite(hfa,MsgText)
Pause(MsgTitle,MsgText)
MsgText = StrCat("Test2 udfRulerScale (64,0,0)",@LF,udfRulerScale(64,0,0))
FileWrite(hfa,MsgText)
Pause(MsgTitle,MsgText)
MsgText = StrCat("Test3 udfRulerScale (64,0,1)",@LF,udfRulerScale(64,0,1))
FileWrite(hfa,MsgText)
Pause(MsgTitle,MsgText)
MsgText = StrCat("Test4 udfRulerScale (64,1,0)",@LF,udfRulerScale(64,1,0))
FileWrite(hfa,MsgText)
Pause(MsgTitle,MsgText)
MsgText = StrCat("Test5 udfRulerScale (64,1,1)",@LF,udfRulerScale(64,1,1))
FileWrite(hfa,MsgText)
Pause(MsgTitle,MsgText)
MsgText = StrCat("Test6 udfRulerScale (132,1,0)",@LF,udfRulerScale(132,1,0))
FileWrite(hfa,MsgText)
Pause(MsgTitle,MsgText)
MsgText = StrCat("Test7 udfRulerScale (1024,1,0)",@LF,udfRulerScale(1024,1,0))
FileWrite(hfa,MsgText)
Pause(MsgTitle,MsgText)
FileClose(hfa)
If FileExist(sTmpFile)
; Take a look and wait for closing notepad.
RunZoomWait("notepad",sTmpFile)
FileDelete(sTmpFile)
EndIf
:CANCEL
Exit
;------------------------------------------------------------------------------------------------------------------------------------------
*EOF*
|
||||
|
||||
Testing the SELECT SWITCH CASE statement |
||||
;==============================================================================================================================================================
; Testing the SELECT SWITCH CASE statement
; Detlev Dalitz.20010326.20020104
; hint: do the test in WinBatch Studio
; test result will be appended at end of this script
;==============================================================================================================================================================
TheLogo = "*** SELECT / SWITCH decision table ***"
Gosub AskCases
Gosub AskBreaks
Gosub AskContinues
Gosub InitResultString
Gosub OpenProgressWindow
iv = (2 ** (cases + 1))
While (iv > 0)
iv = iv - 1
Gosub GenerateTestcase
Gosub TheTestModule
Gosub AppendTestToResultString
EndWhile
Gosub CloseProgressWindow
Gosub DisplayResultToScreen
Gosub AppendTableToThisScript
:cancel
Exit
;==============================================================================================================================================================
;==============================================================================================================================================================
:TheTestModule
For i=1 To 7
c%i% = -1
Next
s = ItemExtract(1,list,@tab)
For i=1 To cases
c%i% = ItemExtract(i + 1,list,@tab)
p%i% = cases + 1 + i
CaseEnd%i% = StrCat("if !isDefined(CaseEnd",i+1,") then goto SelectEnd") ; unusual, just for the test
; CaseEnd%i% = StrCat("if !isDefined(c",i+1,") then goto SelectEnd") ; unusual, just for the test
If (ItemLocate(i, BreakList,@tab ) > 0) Then CaseEnd%i% = "BREAK"
If (ItemLocate(i, ContinueList,@tab ) > 0) Then CaseEnd%i% = "CONTINUE"
Next
;
; Helpfile says:
; The Select statement allows selection among multiple blocks of statements,
; depending on the value of an expression. The expression must evaluate to an
; integer. When a case statement is found, the expression following the case
; statement is evaluated,and if the expression evaluates to the same value as the
; expression following the Select statement, execution of the following statements
; is initiated.
;
; What helpfile says is:
; "if case_expression value is same value as the select_expression".
; But it's a little bit more tricky than documentation says,
; and it's not so obvious in all cases.
; The Select statement knows two special keywords to control the flow:
; "break" and "continue".
; If using _no_ "break" statement in a case statement and if one of the following
; case_expression has the same value as select_expression, then the one
; case_instruction will be executed _and_ furthermore all subsequent cases too,
; without any evaluating of their own case_expressions!
; If using "continue" statement the following case_expression will be evaluated
; and executed only if it has the same value of select_expression.
; Using normal "break" statement works in standard behaviour like a single
; if_then statement.
; So the Select/Switch statement enables total control over complex logical structures.
; To see, in which way your special Select/Switch statement would work, run this script.
; It gives you a decision table by simulating all true/false combinations
; of "opened", "continued" and "breaked" cases. Hope you enjoy it.
Select s
Case c1
list = ItemReplace("x",p1,list,@tab)
%CaseEnd1%
Case c2
list = ItemReplace("x",p2,list,@tab)
%CaseEnd2%
Case c3
list = ItemReplace("x",p3,list,@tab)
%CaseEnd3%
Case c4
list = ItemReplace("x",p4,list,@tab)
%CaseEnd4%
Case c5
list = ItemReplace("x",p5,list,@tab)
%CaseEnd5%
Case c6
list = ItemReplace("x",p6,list,@tab)
%CaseEnd6%
Case c7
list = ItemReplace("x",p7,list,@tab)
%CaseEnd7%
:SelectEnd
EndSelect
Return
;==============================================================================================================================================================
;==============================================================================================================================================================
:GenerateTestcase
v = cases + 1
list = ""
ivt = (2 ** v) - 1
Gosub DisplayProgressWindow
If (iv == ivt)
item = "1"
Else
item = "0"
EndIf
For i=1 To v
list = ItemInsert(item,-1,list,@tab)
Next
If !((iv == 0) || (iv == ivt))
index = v
b = iv
While (b > 0)
item = b mod 2
b = b / 2
list = ItemReplace(item,index,list,@tab)
index = index - 1
EndWhile
EndIf
For i=1 To cases
list = ItemInsert("-",-1,list,@tab)
Next i
Drop(b,i,index,item,ivt,v)
Return
;==============================================================================================================================================================
:OpenProgressWindow
BoxOpen(TheLogo,"")
Return
;==============================================================================================================================================================
:DisplayProgressWindow
ProgressStr=StrCat("Generate Testcase # ",ivt+1,"/",iv+1)
BoxText(ProgressStr)
Drop(ProgressStr)
Return
;==============================================================================================================================================================
:CloseProgressWindow
BoxShut()
Return
;==============================================================================================================================================================
:InitResultString
; s = the select value
; b = the break statement
; c = the continue statement
; cn = the value of case n
; an = the action of case n
ResultStr = ""
ResultStr = ItemInsert(StrCat(TheLogo),-1,ResultStr,@cr)
ResultStr = ItemInsert("",-1,ResultStr,@cr)
ResultStr = ItemInsert("",-1,ResultStr,@cr)
ResultStr = ItemInsert("s",-1,ResultStr,@tab)
For i=1 To cases
str = StrCat("c",i)
ResultStr = ItemInsert(str,-1,ResultStr,@tab)
Next i
ResultStr = ItemInsert("",-1,ResultStr,@tab)
For i=1 To cases
str = StrCat("a",i)
ResultStr = ItemInsert(str,-1,ResultStr,@tab)
Next i
ResultStr = ItemInsert("",-1,ResultStr,@cr)
ResultStr = ItemInsert("",-1,ResultStr,@tab)
For i=1 To cases
str = ""
If (ItemLocate(i,BreakList,@tab) > 0) Then str = "b"
If (ItemLocate(i,ContinueList,@tab) > 0) Then str = "c"
ResultStr = ItemInsert(str,-1,ResultStr,@tab)
Next i
ResultStr = ItemInsert("",-1,ResultStr,@cr)
ResultStr = ItemInsert("",-1,ResultStr,@cr)
Drop(i,str)
Return
;==============================================================================================================================================================
:AppendTestToResultString
For i=1 To cases+1
ResultStr = ItemInsert(ItemExtract(i,list,@tab),-1,ResultStr,@tab)
Next i
ResultStr = ItemInsert("",-1,ResultStr,@tab)
For i=cases+2 To (cases+cases+1)
ResultStr = ItemInsert(ItemExtract(i,list,@tab),-1,ResultStr,@tab)
Next i
ResultStr = ItemInsert("",-1,ResultStr,@cr)
Drop(i)
Return
;==============================================================================================================================================================
:DisplayResultToScreen
ResultStr = StrReplace(ResultStr,StrCat(@cr,@tab),@cr)
IntControl (63, 50, 100, 900, 900)
AskItemlist("Decision Table", ResultStr, @cr, @unsorted, @single)
Return
;==============================================================================================================================================================
:AppendTableToThisScript
ResultStr = StrCat(@cr,StrFill("-",65),@cr,ResultStr,@cr,TimeYmdHms(),@cr,StrFill("-",65))
ResultStr = StrReplace(ResultStr,@cr,StrCat(@crlf,";",@tab))
ThisScriptPathname = IntControl(1004,0,0,0,0) ; full path and file name of the current WinBatch program.
filename = ThisScriptPathname ; or other filename you want
handle = FileOpen(filename, "APPEND")
FileWrite(handle, ResultStr)
FileClose(handle)
Drop(handle)
Return
;==============================================================================================================================================================
:AskCases
CaseChoice = ""
For i=2 To 7
CaseChoice = ItemInsert(i,-1,CaseChoice,@tab)
Next i
cases = ""
While (cases == "")
IntControl (63, 50, 100, 900, 600)
cases = AskItemlist("How many CASE's?",CaseChoice, @tab, @unsorted, @single)
EndWhile
Drop(i,CaseChoice)
Return
;==============================================================================================================================================================
:AskBreaks
BreakChoice = ""
For i=0 To cases
BreakChoice = ItemInsert(i,-1,BreakChoice,@tab)
Next i
BreakList = ""
While (BreakList == "")
IntControl (63, 50, 100, 900, 600)
BreakList = AskItemlist("Which CASE's with BREAK? (select mutiple cases, select single 0 if no break)", BreakChoice, @tab, @unsorted, @extended)
EndWhile
Drop(i,BreakChoice)
Return
;==============================================================================================================================================================
:AskContinues
ContinueChoice = ""
For i=0 To cases
ContinueChoice = ItemInsert(i,-1,ContinueChoice,@tab)
Next i
ContinueList = ""
While (ContinueList == "")
IntControl (63, 50, 100, 900, 600)
ContinueList = AskItemlist("Which CASE's with CONTINUE? (select mutiple cases, select single 0 if no continue)", ContinueChoice, @tab, @unsorted, @extended)
EndWhile
Drop(i,ContinueChoice)
Return
;==============================================================================================================================================================
;==============================================================================================================================================================
; -----------------------------------------------------------------
; *** SELECT / SWITCH decision table ***
;
; s c1 c2 c3 a1 a2 a3
; b b b
;
; 1 1 1 1 x - -
; 1 1 1 0 x - -
; 1 1 0 1 x - -
; 1 1 0 0 x - -
; 1 0 1 1 - x -
; 1 0 1 0 - x -
; 1 0 0 1 - - x
; 1 0 0 0 - - -
; 0 1 1 1 - - -
; 0 1 1 0 - - x
; 0 1 0 1 - x -
; 0 1 0 0 - x -
; 0 0 1 1 x - -
; 0 0 1 0 x - -
; 0 0 0 1 x - -
; 0 0 0 0 x - -
;
; 2002:02:02:12:00:20
; -----------------------------------------------------------------
; -----------------------------------------------------------------
; *** SELECT / SWITCH decision table ***
;
; s c1 c2 c3 a1 a2 a3
; c c c
;
; 1 1 1 1 x x x
; 1 1 1 0 x x -
; 1 1 0 1 x - x
; 1 1 0 0 x - -
; 1 0 1 1 - x x
; 1 0 1 0 - x -
; 1 0 0 1 - - x
; 1 0 0 0 - - -
; 0 1 1 1 - - -
; 0 1 1 0 - - x
; 0 1 0 1 - x -
; 0 1 0 0 - x x
; 0 0 1 1 x - -
; 0 0 1 0 x - x
; 0 0 0 1 x x -
; 0 0 0 0 x x x
;
; 2002:02:02:12:01:07
; -----------------------------------------------------------------
; -----------------------------------------------------------------
; *** SELECT / SWITCH decision table ***
;
; s c1 c2 c3 a1 a2 a3
; b c b
;
; 1 1 1 1 x - -
; 1 1 1 0 x - -
; 1 1 0 1 x - -
; 1 1 0 0 x - -
; 1 0 1 1 - x x
; 1 0 1 0 - x -
; 1 0 0 1 - - x
; 1 0 0 0 - - -
; 0 1 1 1 - - -
; 0 1 1 0 - - x
; 0 1 0 1 - x -
; 0 1 0 0 - x x
; 0 0 1 1 x - -
; 0 0 1 0 x - -
; 0 0 0 1 x - -
; 0 0 0 0 x - -
;
; 2002:02:02:12:04:27
; -----------------------------------------------------------------
;==============================================================================================================================================================
|
||||
|
||||
Russell's Binary Clock |
||||
; ------------------------------------------------------------------------------------------------
; Binary clock
; by Russell
; ------------------------------------------------------------------------------------------------
; may need the udf or the extender ...
; AddExtender("wilx34i.dll")
; If you want to use the extender to perform the base conversions,
; then uncomment the AddExtender statement above and furthermore the lines Bottom
; in the script which call the "xBaseConvert" function with following "StrFixLeft" statement.
; Make sure do comment the lines which call the "udfConvertToBase" function.
; ------------------------------------------------------------------------------------------------
If itemlocate("udfconverttobase", IntControl(77,103,0,0,0), @tab) then goto skip_udfconverttobase
#DefineFunction udfConvertToBase (num, base, width)
;terminate(vartype(num)<>1,"udfConvertToBase (num, base, width)","num must be integer")
;terminate(vartype(base)<>1,"udfConvertToBase (num, base, width)","base must be integer")
;terminate(vartype(width)<>1,"udfConvertToBase (num, base, width)","width must be integer")
;terminate((base<2)||(base>36),"udfConvertToBase (num, base, width)","base must be in range 2..36")
b=""
While (num>0)
b=strcat(strsub("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ",1+(num mod base),1),b)
num=int(num/base)
EndWhile
If (b=="") then b="0"
If (width>0) then b=strfixleft(b,"0",width)
Return (b)
; Conf: WinBatch
; From: kdmoyers admin@guden.com
; Date: Thursday, December 27, 2001 12:50 PM
; Slightly modified by Detlev Dalitz.20020204
#EndFunction
:skip_udfconverttobase
; ------------------------------------------------------------------------------------------------
; Tell WIL not to complain when box is closed
IntControl(12, 4, 0, 0, 0)
; Enable Close button
IntControl(1008, 1, 0, 0, 0)
DKBLUE="0,0,128"
BLUE="0,0,255"
LTBLUE="128,180,255"
LTGRAY="192,192,192"
GRAY="150,150,150"
DKGRAY="64,64,64"
GREEN="0,255,0"
RED="255,0,0"
BLACK="0,0,0"
WHITE="255,255,255"
YELLOW="255,255,0"
BoxesUp("0,0,100,125",@normal)
BoxCaption(1,"Time")
BoxNew(2,"0,0,1000,1000",0)
BoxColor(2,BLACK,0)
BoxDrawRect(2,"0,0,1000,1000",2)
BoxDataTag(2,"Time")
; Assign window positions for binary 1 or 0 for hour, minute, second
; Since we'll only see a max value of 59 (111011), we only need 6 positions.
sec6 = "800,750,900,900" ;Position of seconds 1
sec5 = "660,750,760,900" ; 2
sec4 = "520,750,620,900" ; 4
sec3 = "380,750,480,900" ; 8
sec2 = "240,750,340,900" ; 16
sec1 = "100,750,200,900" ; 32
min6 = "800,500,900,650"
min5 = "660,500,760,650"
min4 = "520,500,620,650"
min3 = "380,500,480,650"
min2 = "240,500,340,650"
min1 = "100,500,200,650"
hour6 = "800,250,900,400"
hour5 = "660,250,760,400"
hour4 = "520,250,620,400"
hour3 = "380,250,480,400"
hour2 = "240,250,340,400"
hour1 = "100,250,200,400"
; If you want a 12 hour clock (AM/PM), set clock12 = 1.
; Otherwise, hours are 0 - 23
clock12 = 0
While 1
BoxDataClear(2,"Time")
TOD = TimeYmdHms()
; Get the hour from the time of day
hours = 0+itemextract(4,TOD,":")
If clock12 == 1
If hours > 12
hours = hours - 12
BoxCaption(1,"PM")
else
BoxCaption(1,"AM")
EndIf
EndIf
binhour = udfConvertToBase(hours,2,6)
; binhour = xBaseConvert(hours,10,2) ; Convert to binary
; binhour = StrFixLeft(binhour,"0",6) ; Pad left so we always have 6 digits (1 = 000001)
; For each binary postion "on", turn on that position in the clock
For i=6 to 1 by -1
If StrSub(binhour,i,1) == "1"
BoxColor(2,RED,0) ;on
else
BoxColor(2,BLACK,0) ;off
EndIf
BoxDrawCircle(2,hour%i%,2) ; Coordinates from above
Next
minute = 0+itemextract(5,TOD,":")
binmin = udfConvertToBase(minute,2,6)
; binmin = xBaseConvert(minute,10,2)
; binmin = StrFixLeft(binmin,"0",6)
For i=6 to 1 by -1
If StrSub(binmin,i,1) == "1"
BoxColor(2,BLUE,0)
else
BoxColor(2,BLACK,0)
EndIf
BoxDrawCircle(2,min%i%,2)
Next
second = 0+itemextract(6,TOD,":")
binsec = udfConvertToBase(second,2,6)
; binsec = xBaseConvert(second,10,2)
; binsec = StrFixLeft(binsec,"0",6)
For i=6 to 1 by -1
If StrSub(binsec,i,1) == "1"
BoxColor(2,GREEN,0)
else
BoxColor(2,BLACK,0)
EndIf
BoxDrawCircle(2,sec%i%,2)
Next
timedelay(1); lest we hog the CPU
EndWhile
Exit
|
||||
|
||||
Testing the allowed characters for identifier names |
||||
; Check which characters are allowed
; for building identifier names in WinBatch
; Detlev Dalitz.20010101
; Test Range is Num2Char(2..255)
MagicNumbers = "135,136,158,159,185" ; horrible
For cluster=0 to 15
BoxOpen("Processing", "Be patient")
list = ""
For num=0 to 15
CharNum = (cluster * 16) + num
If CharNum==0 then continue
If CharNum==1 then continue
char = num2char(CharNum)
BoxText(StrCat(CharNum,@tab,char))
Skip = @false
If ItemLocate(CharNum,MagicNumbers,",") > 0
Skip = (@YES==AskYesNo("Caution", "Skip over next character ?"))
EndIf
If Skip
LastErrMsg = "===> magic character <==="
char = ""
else
Error = 0
SimpleCmd = StrCat(char,"=1")
IntControl(73,2,0,0,0)
%SimpleCmd%
LastErrMsg = IntControl(34,Error,0,0,0)
If LastErrMsg == "" then LastErrMsg = "=== good character ==="
EndIf
item = StrCat(Charnum,@tab,char,@tab,LastErrMsg)
list = iteminsert(item,-1,list,num2char(1))
If Error==0 then drop(%char%)
Next num
BoxShut()
IntControl(63, 200, 200, 800, 700)
AskItemList("Number Character ErrorMessage", list, num2char(1), @unsorted, @single)
Next cluster
Exit
:WBERRORHANDLER
Error=LastError()
Return
|
||||
|
||||
How to convert numberstring to number |
||||
; convert numberstring to integer number num = "-999999999" num = 0+num ; gives num=-999999999 num = "999999999" num = 0+num ; gives num=999999999 ; convert numberstring to floating point number num = "-1234567890.1234567890" num = 0.0+num ; gives num=-1234567890.000000 num = "+1234567890.1234567890" num = 0.0+num ; gives num=1234567890.000000 ; Convert a numberstring with trailing minus sign ; to a negative number with leading minus sign ; using WinBatch substitution feature num = "999999999-" If %num%0==%num%-0 then num=-%num%0 ; gives num=-999999999 Exit |
||||
|
||||
udfKeepPlus (number) |
||||
#DefineFunction udfKeepPlus(number)
Return (StrCat(StrFill("+",(number>0)),number))
; If number is greater than zero then this udf returns number string with leading plus sign.
; Detlev Dalitz.2001:07:26:23:02:18
#EndFunction
; --- test ---
number = 221
numberstr = udfKeepPlus(number)
Message("Demo udfKeepPlus (number)",StrCat("number=",number,@crlf,"numberstr=",numberstr))
Exit
|
||||
|
||||
udfDIWriteJpg (SourceFile, TargetFile, Quality, ProgressiveFlag, DeleteSourceFlag) |
||||
If (ItemLocate("udfdiwritejpg",IntControl(77,103,0,0,0),@tab)>0) Then Goto skip_udfdiwritejpg
#DefineFunction udfDiWriteJpg (SourceFile, TargetFile, Quality, ProgressiveFlag, DeleteSourceFlag)
If !FileExist(SourceFile) Then Return (2)
DeleteSourceFlag = Min(@true,Max(@false,DeleteSourceFlag))
ProgressiveFlag = Min(@true,Max(@false,ProgressiveFlag))
Quality = Min(100,Max(0,Quality))
DIjpgTempInputFile = "C:\tmp.bmp" ; not good but dll needs it, 'kludgy'
DIjpgDll = StrCat(DirWindows(1),"DIjpg.dll") ; maybe choose your own dll folder path
FileCopy(SourceFile,DIjpgTempInputFile,@false)
If !FileExist(DIjpgTempInputFile) Then Return (2)
result = DllCall(DIjpgDll,long:"DIWriteJpg",lpstr:TargetFile,long:Quality,long:ProgressiveFlag)
If (result == 1)
FileDelete(DIjpgTempInputFile)
If DeleteSourceFlag Then FileDelete(SourceFile)
EndIf
Return (result)
;
; InputFilename must be "C:\tmp.bmp" ; 'kludgy', but dll needs this filename!
; Quality = 100(best)..0(worst)
; ProgressiveFlag = 0..1 (@false..@true)
; DeleteSouceFlag = 0..1 (@false..@true), if @true then delete sourcefile
;
; DI_FAILURE 0
; DI_SUCCESS 1
; DI_ERR_INFILE 2
; DI_ERR_OUTFILE 3
; DIjpg.dll is a free dll, part of the Independent JPEG Group's software.
; JVERSION "6b 27-Mar-1998" JCOPYRIGHT "Copyright (C) 1998, Thomas G. Lane".
; search on the internet for: dijpgdll.zip, dijpgvbe.zip, dijpgsrc.zip.
; DILIB official site www.disoft.com
;
; WinBatch wrapper by Detlev Dalitz.20011111.20020607
#EndFunction
:skip_udfdiwritejpg
; --- test ---
TempFile = FileCreateTemp("TMP") ; create temp file and use it for creating testfile names
FileDelete(TempFile) ; we do not use this tempfile
SourceFile = StrCat(TempFile,".bmp") ; build a sourcefilename, append extension ".bmp"
TargetFile = StrCat(TempFile,".jpg") ; build a targetfilename, append extension ".jpg"
Quality = 65 ; compression level
ProgressiveFlag = @true ; progressive mode
DeleteSourceFlag = @true ; delete sourcefile after converting
Snapshot(0) ; Take snapshot of entire screen
size = BinaryClipget(0,8)
bb = BinaryAlloc(size)
BinaryClipget(bb,8)
bb2 = BinaryAlloc(size+14)
BinaryPokestr(bb2,0,"BM")
BinaryPoke4(bb2,2,size+14)
PixelWrapExists = @false ; set this to @true, if created bmp file has pixels wrapped
tableloc = BinaryPeek4(bb,0) + 14 + (PixelWrapExists*12)
BinaryPoke4(bb2,10,tableloc)
BinaryCopy(bb2,14,bb,0,size)
BinaryWrite(bb2,SourceFile)
BinaryFree(bb2)
BinaryFree(bb)
result = udfDiWriteJpg (SourceFile, TargetFile, Quality, ProgressiveFlag, DeleteSourceFlag)
Display(1,"Demo udfDIWriteJpg Snapshot",StrCat(result,@crlf,"Ready."))
Exit
|
||||
| Download: dijpgdll.zip dijpgsrc.zip dijpgvbe.zip |
||||
|
||||
Unicode with ADO stream object |
||||
; -----------------------------------------------------------------------------
; Using the ADO stream object to convert from normal text to unicode
; -----------------------------------------------------------------------------
; prepare the testcase
; we use WIL's browser.exe to look into the files
browser = StrCat(DirHome(),"browser.exe")
; get temp file name
tempfile = FileCreateTemp("TMP")
FileDelete(tempfile) ; we do not use this tempfile
; build source filename
ansifile = StrCat(tempfile,".ansi.txt")
; build target filename
unifile = StrCat(tempfile,".unicode.bin")
; create source file with ansi charset
fw = FileOpen(ansifile,"write")
FileWrite(fw,"This text appears")
FileWrite(fw,"1st converted to unicode charset")
FileWrite(fw,"2nd converted back to ansi charset.")
FileClose(fw)
; use ADO stream obcekt
SA = ObjectOpen("ADODB.Stream")
SB = ObjectOpen("ADODB.Stream")
SA.Open
SB.Open
; Because "unicode" is the default charset
; and input file may have another type of charset,
; we have to tell the stream object what charset is actually used.
; Select a charset name from the list under registry key
; "HKEY_CLASSES_ROOT\MIME\Database\Charset"
; e.g. "iso-8859-1" or "utf-8" or "windows-1252"
; define the current charsets
SA.charset = "Windows-1252"
SB.charset = "unicode"
SA.LoadFromFile (ansifile)
SA.Position = 0 ; for sure
SA.CopyTo (SB) ; copy ansi stream buffer to unicode stream buffer
SB.SaveToFile (unifile,2) ; save unicode stream to file
SA.close()
SB.close()
ObjectClose(SA)
ObjectClose(SB)
; take a look into the files
Run(browser, ansifile)
Run(browser, unifile)
; -----------------------------------------------------------------------------
; Using the ADO stream object to convert from unicode to normal text.
; -----------------------------------------------------------------------------
; build a source filename
; we use the unicode file from testcase above.
; build a target filename
backtoansifile = StrCat(tempfile,".backtoansi.txt")
; use ADO stream object
SA = ObjectOpen("ADODB.Stream")
SB = ObjectOpen("ADODB.Stream")
SA.Open
SB.Open
SA.charset = "unicode"
SB.charset = "Windows-1252"
SA.LoadFromFile (unifile)
SA.Position = 0
SA.CopyTo (SB)
SB.SaveToFile (backtoansifile,2)
SA.close()
SB.close()
ObjectClose(SA)
ObjectClose(SB)
; take a look into the ansi file
Run(browser, backtoansifile)
; -----------------------------------------------------------------------------
If (@yes == AskYesNo("TEST: Ansi to Unicode to Ansi ","Delete test files?"))
FileDelete(ansifile)
FileDelete(unifile)
FileDelete(backtoansifile)
EndIf
Exit
; Detlev Dalitz.20020621
; -----------------------------------------------------------------------------
|
||||
|
||||
udfArrangeDesktopIcons (wparam) |
||||
#DefineFunction udfArrangeDesktopIcons (wparam)
AddExtender("wwctl34i.dll")
window1 = cWndByWndSpec("Progman","EXPLORER",1,0)
window2 = cWndbyid(window1,0)
ControlHandle = cWndbyid(window2,1)
cSetFocus(ControlHandle)
LVM_ARRANGE = 4118
result = cSendMessage(ControlHandle, LVM_ARRANGE, wparam, 0)
Return (result)
; with wparam =
; LVA_ALIGNLEFT = 1 ; Aligns items along the left edge of the window.
; LVA_ALIGNTOP = 2 ; Aligns items along the top edge of the window.
; LVA_SNAPTOGRID = 5 ; Snaps all icons to the nearest grid position.
; LVA_DEFAULT = 0 ; Aligns items according to the list-view control's current
; alignment styles (the default value).
; Returns @TRUE if successful, or @FALSE otherwise.
; Detlev Dalitz.20020622
#EndFunction
; --- test ---
LVA_ALIGNLEFT = 1
LVA_ALIGNTOP = 2
LVA_DEFAULT = 0
LVA_SNAPTOGRID = 5
;result = udfArrangeDesktopIcons (LVA_DEFAULT)
result = udfArrangeDesktopIcons (LVA_SNAPTOGRID)
;result = udfArrangeDesktopIcons (LVA_ALIGNLEFT)
;result = udfArrangeDesktopIcons (LVA_ALIGNTOP)
Exit
|
||||
|
||||
udfGoldenSection (width, height) |
||||
;----------------------------------------------------------------------------------------------------
; udfGoldenWidth (height) ; DD.2002:06:26:11:37:09
; udfGoldenHeight (width) ; DD.2002:06:26:11:37:09
; udfGoldenSection (width, height) ; DD.2002:06:26:11:37:09
;----------------------------------------------------------------------------------------------------
#DefineFunction udfGoldenWidth (height)
Return (@goldenratio * height)
#EndFunction
#DefineFunction udfGoldenHeight (width)
Return (width / @goldenratio)
#EndFunction
#DefineFunction udfGoldenSection (width, height)
Return (StrCat(@goldenratio*height,@tab,width/@goldenratio))
; k = 1.61803398874989484820458683436564 ; k = 0.5 * (1 + (5 ** 0.5))
#EndFunction
; --- test ---
msgtitle = "Demo udfGoldenSection (width, height)"
width = 200
height = 100
goldensection = udfGoldenSection(width,height)
goldenwidth = ItemExtract(1,goldensection,@tab)
goldenheight = ItemExtract(2,goldensection,@tab)
gwidth = udfGoldenWidth(height)
gheight = udfGoldenHeight(width)
msgtext = StrCat("Raw:",@crlf)
msgtext = StrCat(msgtext,"width x height",@tab," = ",width," x ",height,@crlf,@crlf)
msgtext = StrCat(msgtext,"Golden Section:",@crlf)
msgtext = StrCat(msgtext,"width x height",@tab," = ",goldenwidth," x ",goldenheight,@crlf,@crlf)
msgtext = StrCat(msgtext,"width x height",@tab," = ",gwidth," x ",gheight,@crlf)
Message(msgtitle,msgtext)
Exit
|
||||
|
||||
udfDailyWorkDispatcher |
||||
;----------------------------------------------------------------------------------------------------
; udfDailyWorkDispatcher_1 () ; DD.2002:07:01:23:53:43
;
; udfDailyWorkDispatcher_2 () ; DD.2002:07:01:23:53:43
; udfDailyWorkSunday () ; DD.2002:07:01:23:53:43
; udfDailyWorkMonday () ; DD.2002:07:01:23:53:43
; udfDailyWorkTuesday () ; DD.2002:07:01:23:53:43
; udfDailyWorkWednesday () ; DD.2002:07:01:23:53:43
; udfDailyWorkThursday () ; DD.2002:07:01:23:53:43
; udfDailyWorkFriday () ; DD.2002:07:01:23:53:43
; udfDailyWorkSaturday () ; DD.2002:07:01:23:53:43
;----------------------------------------------------------------------------------------------------
; Note:
;
; Instead of udf... (User Defined Function)
;
; #DefineFunction xyz (parameters)
; ; parameters are visible
; ; global variables are hidden
; #EndFunction
;
;
; You can use uds... (User Defined Subroutine)
;
; #DefineSubRoutine xyz (parameters)
; ; parameters are visible
; ; global variables are visible
; #EndSubroutine
;
;
; Or just code the dispatcher routine in main program e.g. using gosub statements ...
;
;----------------------------------------------------------------------------------------------------
; Following two code examples are only two of a variety of solutions ...
;----------------------------------------------------------------------------------------------------
#DefineFunction udfDailyWorkDispatcher_1 ()
DayOfWeek = (5 + TimeJulianDay(TimeYmdHms())) mod 7
Goto %DayOfWeek%
:0
Message("Sunday Work","do your work now")
Return (0)
:1
Message("Monday Work","do your work now")
Return (1)
:2
Message("Tuesday Work","do your work now")
Return (2)
:3
Message("Wednesday Work","do your work now")
Return (3)
:4
Message("Thursday Work","do your work now")
Return (4)
:5
Message("Friday Work","do your work now")
Return (5)
:6
Message("Saturday Work","do your work now")
Return (6)
#EndFunction
;----------------------------------------------------------------------------------------------------
#DefineFunction udfDailyWorkSunday ()
Message("Sunday Work","do your work now")
Return (0)
#EndFunction
#DefineFunction udfDailyWorkMonday ()
Message("Monday Work","do your work now")
Return (1)
#EndFunction
#DefineFunction udfDailyWorkTuesday ()
Message("Tuesday Work","do your work now")
Return (2)
#EndFunction
#DefineFunction udfDailyWorkWednesday ()
Message("Wednesday Work","do your work now")
Return (3)
#EndFunction
#DefineFunction udfDailyWorkThursday ()
Message("Thursday Work","do your work now")
Return (4)
#EndFunction
#DefineFunction udfDailyWorkFriday ()
Message("Friday Work","do your work now")
Return (5)
#EndFunction
#DefineFunction udfDailyWorkSaturday ()
Message("Saturday Work","do your work now")
Return (6)
#EndFunction
#DefineFunction udfDailyWorkDispatcher_2 ()
Select (5 + TimeJulianDay(TimeYmdHms())) mod 7
Case 0 ; Sunday
result = udfDailyWorkSunday ()
Break
Case 1 ; Monday
result = udfDailyWorkMonday ()
Break
Case 2 ; Tuesday
result = udfDailyWorkTuesday ()
Break
Case 3 ; Wednesday
result = udfDailyWorkWednesday ()
Break
Case 4 ; Thursday
result = udfDailyWorkThursday ()
Break
Case 5 ; Friday
result = udfDailyWorkFriday ()
Break
Case 6 ; Saturday
result = udfDailyWorkSaturday ()
Break
EndSelect
Return (result)
#EndFunction
;----------------------------------------------------------------------------------------------------
; --- test ---
result = udfDailyWorkDispatcher_1 ()
result = udfDailyWorkDispatcher_2 ()
Exit
|
||||
|
||||
Unicode with 'OpenAsTextStream' from 'Scripting.FileSystemObject' |
||||
; Unicode with 'OpenAsTextStream' from 'Scripting.FileSystemObject'
ForReading = 1 ; Open a file for reading only. You can't write to this file.
ForWriting = 2 ; Open a file for writing.
ForAppending = 8 ; Open a file and write to the end of the file.
TristateUseDefault = -2 ; Opens the file using the system default.
TristateTrue = -1 ; Opens the file as Unicode.
TristateFalse = 0 ; Opens the file as ASCII.
; Create testfile
testfile = "d:\temp\test.txt"
objFSO = ObjectOpen("Scripting.FileSystemObject")
objFile = objFSO.CreateTextFile(testfile)
objFile.WriteLine("Unicode capabilities of 'Scripting.FileSystemObject'")
objFile.WriteLine("This is a testfile.")
objFile.Close
ObjectClose(objFile)
ObjectClose(objFSO)
; Read ascii textfile, write back as unicode.
objFSO = ObjectOpen("Scripting.FileSystemObject")
objFile = objFSO.GetFile(testfile)
objStream = objFile.OpenAsTextStream(ForReading,TristateFalse) ; read ascii
Buffer = objStream.Readall
ObjectClose(objStream)
objStream = objFile.OpenAsTextStream(ForWriting,TristateTrue) ; write unicode
objStream.Write(Buffer)
ObjectClose(objStream)
ObjectClose(objFile)
ObjectClose(objFSO)
RunZoomWait(StrCat(DirHome(),"browser.exe"),testfile)
; Read unicode, write back as ascii.
objFSO = ObjectOpen("Scripting.FileSystemObject")
objFile = objFSO.GetFile(testfile)
objStream = objFile.OpenAsTextStream(ForReading,TristateTrue) ; read unicode
Buffer = objStream.Readall
ObjectClose(objStream)
objStream = objFile.OpenAsTextStream(ForWriting,TristateFalse) ; write ascii
objStream.Write(Buffer)
ObjectClose(objStream)
ObjectClose(objFile)
ObjectClose(objFSO)
RunZoomWait(StrCat(DirHome(),"browser.exe"),testfile)
; Delete testfile
objFSO = ObjectOpen("Scripting.FileSystemObject")
objFile = objFSO.GetFile(testfile)
objFile.Delete
ObjectClose(objFile)
ObjectClose(objFSO)
Exit
|
||||
|
||||
udfIsPrimeNumber (iNumber) |
||||
#DefineFunction udfIsPrimeNumber (iNumber)
iLimit = Int(Sqrt(iNumber))
bPrime = @true
For i=2 To iLimit
bPrime = iNumber mod i
If !bPrime Then Break
Next
Return (bPrime)
#EndFunction
; --- test ---
BoxOpen("Demo udfIsPrime (iNumber)","")
n = 1000
PrimeList = ""
For i=1 To n
If udfIsPrimeNumber(i)
BoxText (StrCat(i,@tab,"prime"))
PrimeList = ItemInsert(i,-1,PrimeList,@tab)
EndIf
Next
BoxShut()
prime = AskItemlist("PrimeNumbers",PrimeList,@tab,@unsorted,@single)
:cancel
Exit
|
||||
|
||||
udfSetSystemTimeByTimeServer (sTimeServerAddress, iTimeZoneHoursShift) |
||||
;------------------------------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfsetsystemtimebytimeserver",IntControl(77,103,0,0,0),@TAB) Then Goto skip_udfsetsystemtimebytimeserver
#DefineFunction udfSetSystemTimeByTimeServer (sTimeServerAddress, iTimeZoneHoursShift)
AddExtender("wwwsk34i.dll")
socket = sOpen()
If !socket Then Return ("")
If !sConnect (socket,sTimeServerAddress,"37") Then Return ("")
bit32time = sRecvNum(socket,4)
sClose(socket)
seconds = (bit32time & 2147483647) - 61505154 + (iTimeZoneHoursShift*3600) ; Adjust number in seconds.
If (seconds<=0) Then Return ("")
If !IntControl(58,TimeAdd("1970:01:01:00:00:00",StrCat("0:0:0:0:0:",seconds)),0,0,0) Then Return ("")
Return (TimeYmdHms())
; This function "udfSetTimeByTimeServer" tries to connect to an Internet Time Server Service port 37
; and will set the local computer time accordingly.
; On success the function returns the current system time as a DateTime string.
; On failure it returns an empty string.
;
; Based on article:
; Topic: Getting Time from a Time Server
; Conf: WinBatch
; From: Marty marty+bbs@winbatch.com
; Date: Tuesday, July 16, 2002 12:02 AM
;
; See further details on:
; NIST Time & Frequency Division (http://www.bldrdoc.gov/timefreq)
; View the Network Time Service page:
; All current time servers. NIST Time Protocol (RFC-868).
;
; iTimeServerAddress ..... IP-number or domain name.
; iTimeZoneHoursShift ... Shifted plus/minus hours against Greenwich Meantime UTC; e.g. +2=GermanyWuppertalDaylight.
; cGMT = 61505154
#EndFunction
:skip_udfsetsystemtimebytimeserver
;------------------------------------------------------------------------------------------------------------------------------------------
; --- test ---
Display(3,"System Time is", udfSetSystemTimeByTimeServer("131.107.1.10",2)) ; Microsoft, Redmond, Washington
Display(3,"System Time is", udfSetSystemTimeByTimeServer("time-nw.nist.gov",2)) ; Microsoft, Redmond, Washington
Display(3,"System Time is", udfSetSystemTimeByTimeServer("ntp2.ptb.de",2)) ; Physikalisch Technische Bundesanstalt 2
Display(3,"System Time is", udfSetSystemTimeByTimeServer("192.53.103.104",2)) ; Physikalisch Technische Bundesanstalt 2
Exit
;------------------------------------------------------------------------------------------------------------------------------------------
|
||||
|
||||
udfFactorNumberToExpr (iNumber) |
||||
;------------------------------------------------------------------------------------------------------------------------------------------
#DefineFunction udfFactorNumberToExpr (iNumber)
If !IsInt(iNumber) Then Return ""
iNumber=Abs(iNumber)
If iNumber<4 Then Return iNumber
s=""
n=iNumber
d=2
k=0
m=1
While !(n mod d)
n=n/d
m=m*d
k=k+1
EndWhile
Switch k
Case 0
Break
Case 1
s=StrCat(s,d,@CR)
Break
Case k
s=StrCat(s,d,@LF,k,@CR)
EndSwitch
d=3
While 1
k=0
While !(n mod d)
n=n/d
m=m*d
k=k+1
EndWhile
Switch k
Case 0
Break
Case 1
s=StrCat(s,d,@CR)
Break
Case k
s=StrCat(s,d,@LF,k,@CR)
EndSwitch
d=d+2
If d*d>iNumber Then Break
EndWhile
If n==iNumber
s=iNumber
Else
If m<>iNumber
d1=iNumber/m
s=StrCat(s,d1,@CR)
EndIf
EndIf
z=StrLen(s)
If StrSub(s,z,1)==@CR Then s=StrSub(s,1,z-1)
s=StrReplace(s,@LF,"**")
s=StrReplace(s,@CR," * ")
Return s
;..........................................................................................................................................
; "Factor Number To Algebraic Expression"
; Factor a number and return its prime factors in a string as an algebraic expression.
; For example: udfFactorNumberToExpr (76) returns "2**2 * 19".
;
; Note: We use @LF and @CR as intermediate tokens
; to speed up the algorithm's StrCat operations.
;
; Author ; Delgove Jean-Jacques
; Date : 28 may 2002
; Purpose : Find prime factor of integer value.
;
; Modified by Detlev Dalitz.20020708
;..........................................................................................................................................
#EndFunction
;------------------------------------------------------------------------------------------------------------------------------------------
; --- test ---
iMax = 2000
sFilename = FileCreateTemp("TMP")
hFW = FileOpen(sFilename,"WRITE")
Exclusive(@ON)
iStart = GetTickCount()
For i=1 To iMax
FileWrite(hFW,StrCat(i,"=",udfFactorNumberToExpr(i)))
Next
iStop = GetTickCount()
Exclusive(@OFF)
FileWrite(hFW,StrCat("Time in seconds = ",(iStop-iStart)/1000.0))
FileClose(hFW)
RunWait("notepad",sFilename)
FileDelete(sFilename)
Exit
;------------------------------------------------------------------------------------------------------------------------------------------
*EOF*
|
||||
|
||||
udfPDFGetNumPages (sFilename) |
||||
;------------------------------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfpdfgetnumpages",IntControl(77,103,0,0,0),@TAB) Then Goto skip_udfpdfgetnumpages
#DefineFunction udfPDFGetNumPages (sFilename)
; On Error GoTo Label :WBERRORHANDLER
IntControl(73,1,0,0,0)
; Sets the file sharing mode for file reads.
; 1 ... Allow other open operations for read access.
iLastIC39 = IntControl(39,1,0,0,0)
; Define some constants.
@01=" "
@02=" "
@03=" /"
@04=" />"
@05=" /Type /Pages "
@06=" [ "
@07=" ] "
@08=" << "
@09=" >> "
@10=""
@11="#"
@12="#* #*"
@13="%%%%EOF"
@14="%%PDF"
@15=","
@16="/"
@17="/Count "
@18="/Pages "
@19="/Parent "
@20="/Prev "
@21="/Root "
@22="["
@23="]"
@24="<<"
@25=">>"
@26="1234567890"
@27="n"
@28="startxref"
@29="trailer"
@30="xref"
iFileIsUndefined = 0
iFileIsEmpty = -1
iFileIsDamaged = -2
iFileIsNoPdf = -3
; Check filesize.
iNumPages = iFileIsUndefined
iFilesize = FileSizeEx(sFilename)
If !iFilesize Then iNumPages = iFileIsEmpty
If !iFilesize Then Goto ExitUdf
iNoPdf = @FALSE
iNoEof = @FALSE
iNoStartXref = @FALSE
iAlternativeSearch = @FALSE
; Define a binary buffer.
iChunk = 1024
hBB = BinaryAlloc(iChunk)
; Read backwards into pdf file.
iEod = BinaryReadEx(hBB,0,sFilename,Max(0,iFilesize-iChunk),iChunk) - 1
; Find EOF marker.
iOffset = BinaryIndexEx(hBB,iEod,@13,@BACKSCAN,1) ; "[pct][pct]EOF"
iNoEof = (iOffset==-1)
; Find startxref section.
If iNoEof Then iOffset = iEod
iOffsetEnd = iOffset
sStartXref = @28
iLenStartXref = 9
iOffset = BinaryIndexEx(hBB,iOffset,sStartXref,@BACKSCAN,1)
iNoStartXref = (iOffset==-1)
iAlternativeSearch = (iNoEof||iNoStartXref)
If iAlternativeSearch Then Goto EXITNORMALSEARCH
iOffset = iOffset + iLenStartXref ; Jump over last search item.
iOffsetStartXref = Int(StrClean(BinaryPeekStr(hBB,iOffset,iOffsetEnd-iOffset),@26,@10,@TRUE,2))
; Create a list of pointers to the xref tables.
sDelimBol = StrCat(@LF,@02)
sListXref = @10
iObjFound = @FALSE
iOffsetXref = iOffsetStartXref
While @TRUE
; Read first line xref.
; Assumption: xref is found within the first 20 byte.
BinaryReadEx(hBB,0,sFilename,iOffsetXref,20)
BinaryEodSet(hBB,20)
BinaryReplace(hBB,@CR,@LF,@TRUE)
sExtract = BinaryPeekStr(hBB,0,20)
sExtract = StrClean(sExtract,sDelimBol,@02,@TRUE,2)
iPos = StrIndex(sExtract,sDelimBol,1,@FWDSCAN)
; Xref subsection begins here.
iOffsetXref = iOffsetXref + iPos
sExtract = BinaryPeekStr(hBB,0,20)
sExtract = ItemExtract(1,sExtract,@LF)
sExtract = StrTrim(sExtract)
; If the pdf structure is damaged, then we use the alternative search algorithm.
iAlternativeSearch = (sExtract!=@30)
If iAlternativeSearch Then Break
While @TRUE
; Read xref subsection header.
BinaryReadEx(hBB,0,sFilename,iOffsetXref,20)
BinaryEodSet(hBB,20)
BinaryReplace(hBB,@CR,@LF,@TRUE)
sExtract = BinaryPeekStr(hBB,0,20)
sExtract = StrClean(sExtract,sDelimBol,@02,@TRUE,2)
iPos = StrIndex(sExtract,sDelimBol,1,@FWDSCAN)
; Following xref subsection entries begin here.
iOffsetXref = iOffsetXref + iPos
sExtract = BinaryPeekStr(hBB,0,20)
sExtract = ItemExtract(1,sExtract,@LF)
sExtract = StrTrim(sExtract)
; If we reach the trailer section, then we break out.
If (sExtract==@29) Then Break
; If there are no two numbers, then we break out.
If !StrIndexWild(StrClean(StrClean(sExtract,@26,@02,@TRUE,2),@26,@11,@TRUE,1),@12,1) Then Break
;iSectionStart = ItemExtract(1,sExtract,@02)
iSectionCount = ItemExtract(2,sExtract,@02)
; Build our list of pointers.
sItemXref = ItemInsert(iOffsetXref,-1,sExtract,@02)
sListXref = ItemInsert(sItemXref,-1,sListXref,@15)
; Next subsection begins here.
iOffsetXref = iOffsetXref + (iSectionCount * 20)
EndWhile
; Read the trailer section.
; Find link to previous xref table, if there is one.
iOffset = iOffsetXref
sSearch = @20
GoSub ReadChunks
If (iOffset==-1) Then Break
GoSub GetSearchValue
If (iSearchValue==-1) Then Break
iOffsetXref = iSearchValue
EndWhile
If iAlternativeSearch Then Goto EXITNORMALSEARCH
; Count items in the list of pointers.
iCountXref = ItemCount(sListXref,@15)
; Now start working.
; Find the trailer section beyond the xref section.
iOffset = iOffsetStartXref
sSearch = @29
GoSub ReadChunks
sSearch = @21
GoSub ReadChunks
GoSub GetSearchValue
iObjRoot = iSearchValue
; Find offset for object.
iObj = iObjRoot
GoSub FindOffset
iOffsetRoot = iObjOffset
; Read Root object. Find Pages element.
iOffset = iOffsetRoot
sSearch = @18
GoSub ReadChunks
GoSub GetSearchValue
iObjPages = iSearchValue
; Find offset for object.
iObj = iObjPages
GoSub FindOffset
iOffsetPages = iObjOffset
; Read Pages object. Find Count element.
iOffset = iOffsetPages
sSearch = @17
GoSub ReadChunks
GoSub GetSearchValue
iNumPages = iSearchValue
:EXITNORMALSEARCH
BinaryFree(hBB)
If iAlternativeSearch Then GoSub AlternativeSearch
If (iNumPages==iFileIsUndefined)
; Check pdf signature in first 1024 byte.
iChunk = 1024
hBB = BinaryAlloc(iChunk)
BinaryReadEx(hBB,0,sFilename,0,iChunk)
iNoPdf = (BinaryIndexEx(hBB,0,@14,@FWDSCAN,@TRUE)==-1) ; "[pct]PDF"
If iNoPdf Then iNumPages = iFileIsNoPdf
Else iNumPages = iFileIsDamaged
BinaryFree(hBB)
Else
If iNoStartXref Then iNumPages = iFileIsDamaged
EndIf
:ExitUdf
IntControl(39,iLastIC39,0,0,0)
Return (iNumPages)
;..........................................................................................................................................
:FindOffset
iObjOffset = -1
For i=1 To iCountXref
sItemXref = ItemExtract(i,sListXref,@15)
iSectionStart = Int(ItemExtract(1,sItemXref,@02))
iSectionCount = Int(ItemExtract(2,sItemXref,@02))
If !((iObj < iSectionstart) || (iObj > (iSectionStart + iSectionCount - 1)))
iOffsetXref = Int(ItemExtract(3,sItemXref,@02))
iIndex = iObj - iSectionStart
iOffset = iOffsetXref + (iIndex * 20)
BinaryReadEx(hBB,0,sFilename,iOffset,18)
BinaryEodSet(hBB,18)
sExtract = BinaryPeekStr(hBB,0,18)
iInUse = (ItemExtract(3,sExtract,@02)==@27)
If !iInUse Then Continue
iObjOffset = Int(ItemExtract(1,sExtract,@02))
Break
EndIf
Next
Return
;..........................................................................................................................................
:GetSearchValue
BinaryReadEx(hBB,0,sFilename,iOffset,iChunk)
BinaryReplace(hBB,@CR,@02,@TRUE)
BinaryReplace(hBB,@LF,@02,@TRUE)
sExtract = BinaryPeekStr(hBB,0,iChunk)
iPos1 = StrIndex(sExtract,sSearch,1,@FWDSCAN)
If iPos1
iPos1 = iPos1 + StrLen(sSearch)
iPos2 = StrScan(sExtract,@04,iPos1,@FWDSCAN)
sExtract = StrSub(sExtract,iPos1,iPos2-iPos1)
iSearchValue = Int(sExtract)
Else
iSearchValue = -1
EndIf
Return
;..........................................................................................................................................
:ReadChunks
iLenSearch = StrLen(sSearch)
While @TRUE
BinaryReadEx(hBB,0,sFilename,iOffset,iChunk)
BinaryReplace(hBB,@CR,@02,@TRUE)
BinaryReplace(hBB,@LF,@02,@TRUE)
iOffsetEnd1 = BinaryIndexEx(hBB,0,@25,@FWDSCAN,1)
If (iOffsetEnd1>-1)
BinaryEodSet(hBB,iOffsetEnd1)
EndIf
iOffsetEnd2 = BinaryIndexEx(hBB,0,sSearch,@FWDSCAN,1)
If (iOffsetEnd2>-1)
iOffset = iOffset + iOffsetEnd2
Break
EndIf
If (iOffsetEnd1>-1)
iOffset = -1
Break
EndIf
iOffset = iOffset + iChunk - iLenSearch
If (iOffset>iFileSize) Then Break
EndWhile
Return
;..........................................................................................................................................
:AlternativeSearch
; Prepare data.
hBB = BinaryAlloc(iFilesize)
BinaryRead(hBB,sFilename)
iSize1=BinaryReplace(hBB,@22,@10,@TRUE)
iSize2=BinaryReplace(hBB,@23,@10,@TRUE)
iSize3=BinaryReplace(hBB,@24,@10,@TRUE)
iSize4=BinaryReplace(hBB,@25,@10,@TRUE)
iSize5=BinaryReplace(hBB,@16,@10,@TRUE)
BinaryFree(hBB)
hBB = BinaryAlloc(iFilesize + 2*iSize1 + 2*iSize2 + 2*iSize3 + 2*iSize4 + iSize5)
BinaryRead(hBB,sFilename)
BinaryReplace(hBB,@CR,@02,@TRUE)
BinaryReplace(hBB,@LF,@02,@TRUE)
BinaryReplace(hBB,@22,@06,@TRUE)
BinaryReplace(hBB,@23,@07,@TRUE)
BinaryReplace(hBB,@24,@08,@TRUE)
BinaryReplace(hBB,@25,@09,@TRUE)
BinaryReplace(hBB,@16,@03,@TRUE)
While BinaryReplace(hBB,@01,@02,@TRUE)
EndWhile
; Search for the Pages object.
sSearch = @05
iOffsetR = BinaryEodGet(hBB)-1
iOffsetL = 0
iDirection = 1
While @TRUE
iDirection = !iDirection
If iDirection
iOffset1 = BinaryIndexEx(hBB,iOffsetL,sSearch,@FWDSCAN,1)
Else
iOffset1 = BinaryIndexEx(hBB,iOffsetR,sSearch,@BACKSCAN,1)
EndIf
If (iOffset1==-1) Then Break
iOffset2 = BinaryIndexEx(hBB,iOffset1,@24,@BACKSCAN,1)
If !iDirection Then iOffsetR = iOffset2
iOffset3 = BinaryIndexEx(hBB,iOffset1,@25,@FWDSCAN,1)
If iDirection Then iOffsetL = iOffset3
iOffset4 = BinaryIndexEx(hBB,iOffset2,@19,@FWDSCAN,1)
If ((iOffset4<iOffset3)&&(iOffset4>-1)) Then Continue
sExtract = BinaryPeekStr(hBB,iOffset2,iOffset3-iOffset2+1)
iPos = StrIndex(sExtract,@17,1,@FWDSCAN)
If !iPos Then Continue
iPos = iPos+7
iEow = StrScan(sExtract,@04,iPos,@FWDSCAN)
sExtract = StrSub(sExtract,iPos,iEow-iPos)
iNumPages = Int(sExtract)
If iNumPages Then Break
EndWhile
BinaryFree(hBB)
Return
;..........................................................................................................................................
:WBERRORHANDLER
WbError = LastError()
WbTextcode = WbError
If WbError==1668||WbError==2669||WbError==3670
; 1668 ; "Minor user-defined error"
; 2669 ; "Moderate user-defined error"
; 3670 ; "Severe user-defined error"
WbError = ItemExtract(1,IntControl(34,-1,0,0,0),":")
WbTextcode = -1
EndIf
WbErrorString = IntControl(34,WbTextcode,0,0,0)
WbErrorDateTime = StrCat(TimeYmdHms(),"|",StrFixLeft(GetTickCount()," ",10))
WbErrorFile = StrCat(DirWindows(0),"WWWBATCH.INI")
IniWritePvt(WbErrorDateTime,"ErrorValue" ,WbError ,WbErrorFile)
IniWritePvt(WbErrorDateTime,"ErrorString" ,WbErrorString ,WbErrorFile)
IniWritePvt(WbErrorDateTime,"ScriptLine" ,WbErrorHandlerLine ,WbErrorFile)
IniWritePvt(WbErrorDateTime,"ScriptOffset" ,WbErrorHandlerOffset ,WbErrorFile)
IniWritePvt(WbErrorDateTime,"VarAssignment",WbErrorHandlerAssignment,WbErrorFile)
IniWritePvt("","","",WbErrorFile)
WbErrorMsgText = StrCat(WbErrorDateTime,@LF,@LF)
WbErrorMsgText = StrCat(WbErrorMsgText,"LastError value:",@LF,WbError,@LF,@LF)
WbErrorMsgText = StrCat(WbErrorMsgText,"LastError string:",@LF,WbErrorString,@LF,@LF)
; Line in script that caused Error.
WbErrorMsgText = StrCat(WbErrorMsgText,"WbErrorHandlerLine:",@LF,WbErrorHandlerLine,@LF,@LF)
; Offset into script of error line, in bytes.
WbErrorMsgText = StrCat(WbErrorMsgText,"WbErrorHandlerOffset:",@LF,WbErrorHandlerOffset,@LF,@LF)
; Variable being assigned on error line, or "" if none.
WbErrorMsgText = StrCat(WbErrorMsgText,"WbErrorHandlerAssignment:",@LF,WbErrorHandlerAssignment,@LF,@LF)
If (WbErrorHandlerAssignment>"") Then %WbErrorHandlerAssignment% = "eeek"
Message("wbErrorHandler",WbErrorMsgText)
Exit
;..........................................................................................................................................
; This function udfPDFGetNumPages returns the number of pages for a given PDF file.
; Return values:
; n ... The number of pages, greater than zero.
; -1 ... The given file has a size of zero byte or does not exist.
; -2 ... The given file seems to be a pdf file but it is damaged.
; -3 ... The given file seems to be not an Adobe pdf file.
;
; Detlev Dalitz.20021114.20030116.20030117.20030119. ...
; 20030823 Bug Report by Mimmo Montalenti.
; 20030825 Revised version, should handle linearized pdf files too.
; 20030827 New algorithm (xref walker).
; 20030829 Added an alternative search algorithm to handle weird pdf files too.
; 20030830 Some small bugfixes.
; 20030831 Some small refinements.
;..........................................................................................................................................
#EndFunction
:skip_udfpdfgetnumpages
;------------------------------------------------------------------------------------------------------------------------------------------
; --- test ---
; Create a simple pdf file with one page.
sTempFile = FileCreateTemp("TMP")
FileDelete(sTempFile)
sTempFolder = FilePath(sTempFile)
sFilename = "simple.pdf"
sFilename = StrCat(sTempFolder,sFilename)
hFW = FileOpen(sFilename,"WRITE")
FileWrite(hFW,"%%PDF-1.0") ; One duplicated percent sign.
FileWrite(hFW,"1 0 obj")
FileWrite(hFW,"<<")
FileWrite(hFW,"/Type /Catalog")
FileWrite(hFW,"/Pages 3 0 R")
FileWrite(hFW,"/Outlines 2 0 R")
FileWrite(hFW,">>")
FileWrite(hFW,"endobj2 0 obj")
FileWrite(hFW,"<<")
FileWrite(hFW,"/Type /Outlines")
FileWrite(hFW,"/Count 0")
FileWrite(hFW,">>")
FileWrite(hFW,"endobj")
FileWrite(hFW,"3 0 obj")
FileWrite(hFW,"<<")
FileWrite(hFW,"/Type /Pages ")
FileWrite(hFW,"/Count 1 ")
FileWrite(hFW,"/Kids [4 0 R]")
FileWrite(hFW,">>")
FileWrite(hFW,"endobj")
FileWrite(hFW,"4 0 obj")
FileWrite(hFW,"<<")
FileWrite(hFW,"/Type /Page")
FileWrite(hFW,"/Parent 3 0 R")
FileWrite(hFW,"/Resources << /Font << /F1 7 0 R >> /ProcSet 6 0 R")
FileWrite(hFW,">>")
FileWrite(hFW,"/MediaBox [0 0 612 792]")
FileWrite(hFW,"/Contents 5 0 R")
FileWrite(hFW,">>")
FileWrite(hFW,"endobj")
FileWrite(hFW,"5 0 obj")
FileWrite(hFW,"<< /Length 44 >>")
FileWrite(hFW,"stream")
FileWrite(hFW,"BT")
FileWrite(hFW,"/F1 24 Tf")
FileWrite(hFW,"100 100 Td (Hello World) Tj")
FileWrite(hFW,"ET")
FileWrite(hFW,"endstream")
FileWrite(hFW,"endobj")
FileWrite(hFW,"6 0 obj")
FileWrite(hFW,"[/PDF /Text]")
FileWrite(hFW,"endobj")
FileWrite(hFW,"7 0 obj")
FileWrite(hFW,"<<")
FileWrite(hFW,"/Type /Font")
FileWrite(hFW,"/Subtype /Type1")
FileWrite(hFW,"/Name /F1")
FileWrite(hFW,"/BaseFont /Helvetica")
FileWrite(hFW,"/Encoding /MacRomanEncoding")
FileWrite(hFW,">>endobj")
FileWrite(hFW,"xref")
FileWrite(hFW,"0 8")
FileWrite(hFW,"0000000000 65535 f")
FileWrite(hFW,"0000000010 00000 n")
FileWrite(hFW,"0000000080 00000 n")
FileWrite(hFW,"0000000132 00000 n")
FileWrite(hFW,"0000000198 00000 n")
FileWrite(hFW,"0000000349 00000 n")
FileWrite(hFW,"0000000451 00000 n")
FileWrite(hFW,"0000000482 00000 n")
FileWrite(hFW,"trailer")
FileWrite(hFW,"<<")
FileWrite(hFW,"/Size 8")
FileWrite(hFW,"/Root 1 0 R")
FileWrite(hFW,">>")
FileWrite(hFW,"startxref")
FileWrite(hFW,"597")
FileWrite(hFW,"%%%%EOF") ; Two duplicated percent signs.
FileClose(hFW)
sMsgTitle = "Demo udfPDFGetNumPages (sFilename)"
sFilename = "simple.pdf"
iPages = udfPDFGetNumPages (sFilename)
sMsgText = StrCat("PDF Filename",@TAB,sFilename,@LF,"PDF Pages",@TAB,iPages,@LF)
Message(sMsgTitle,sMsgText)
; FileDelete(sFilename)
Exit
;------------------------------------------------------------------------------------------------------------------------------------------
;*EOF*
|
||||
|
||||
udfImgClipPut (sFilenameImage) |
||||
;------------------------------------------------------------------------------------------------------------------------------------------
#DefineFunction udfImgClipPut (sFilenameImage)
If !FileExist(sFilenameImage) Then Return (0)
AddExtender("WWIMG34I.DLL") ; Load the WIL Pixie Extender.
sFilenameTemp = FileCreateTemp("TMP")
If (1 <> ImgConvert(sFilenameImage,StrCat("DIB:",sFilenameTemp))) Then Return (0)
iBBsize = FileSize(sFilenameTemp)
If (0 == iBBSize) Then Return (0)
hBB = BinaryAlloc(iBBsize)
BinaryRead(hBB,sFilenameTemp)
BinaryClipPut(hBB,8) ; 8=CF_DIB
BinaryFree(hBB)
FileDelete(sFilenameTemp)
Return (iBBSize)
;..........................................................................................................................................
; This user defined function "udfImgClipPut" uses the 'ImgConvert' function of the WinBatch 'Pixie' Extender.
; This function converts an input image file to a DIB formatted temporary file
; and puts the DIB content to Windows Clipboard,
; from where it can be pasted into some graphical application.
; The temporary DIB file is deleted afterwards.
; On success this function returns the DIB size in Byte, on failure it returns 0.
;
; Detlev Dalitz.20020904
;..........................................................................................................................................
#EndFunction
; --- test ---
sFilenameImage = StrCat(DirHome(),"WBOwl.bmp")
iResult = udfImgClipPut (sFilenameImage)
If iResult
;Examine results
Run("mspaint","")
While !WinExist("~Paint")
TimeDelay(2)
EndWhile
If WinExist("~Paint")
WinActivate("~Paint")
SendKey("^v") ; Paste Clipboard content to MSPaint.
EndIf
EndIf
Exit
;------------------------------------------------------------------------------------------------------------------------------------------
*EOF*
|
||||
|
||||
udfImgFileClipPut (sFilenameImage) |
||||
;------------------------------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfimgfileclipput",IntControl(77,103,0,0,0),@TAB) Then Goto skip_udfimgfileclipput
#DefineFunction udfImgFileClipPut (sFilenameImage)
If 0==FileSizeEx(sFilenameImage) Then Return (0)
sFilenameConvertExe = "P:\Program Files\ImageMagick\convert.exe" ; Change the application path to your needs.
sFilenameConvertExe = FileNameShort(sFilenameConvertExe)
sFilenameImage = FileNameShort(sFilenameImage)
sFilenameTemp = FileCreateTemp("TMP")
sRunParams = StrCat(sFilenameImage," DIB:",sFilenameTemp)
iLastErrorMode = ErrorMode(@OFF)
iResult = RunHideWait(sFilenameConvertExe,sRunParams)
ErrorMode(iLastErrorMode)
If 0==iResult Then Return (0)
iBBsize = FileSize(sFilenameTemp)
If 0==iBBSize Then Return (0)
hBB = BinaryAlloc(iBBsize)
BinaryRead(hBB,sFilenameTemp)
BinaryClipPut(hBB,8) ; 8=CF_DIB
BinaryFree(hBB)
FileDelete(sFilenameTemp)
Return (iBBSize)
;..........................................................................................................................................
; This user defined function "udfImgFileClipPut" uses the external commandline application 'convert.exe',
; which is one of the 'ImageMagick' commandline utilities to create, edit, or convert images.
; The ImageMagick 'convert.exe' recognizes many input image formats and converts to differing output image format.
; This function "udfFileReadImageToClipboard" converts an input image file to a DIB formatted temporary file
; and puts the DIB content to Windows Clipboard, from where it can be pasted into some graphical application.
; The temporary DIB file is deleted afterwards.
; On success this function returns the DIB size in Byte, on failure it returns 0.
;
; Reference:
; ImageMagick is copyrighted by ImageMagick Studio LLC, a non-profit organization.
; ImageMagick is available for free, may be used to support both open and proprietary applications,
; and may be redistributed without fee.
; ImageMagick is available as ftp://ftp.imagemagick.org/pub/ImageMagick/
; The official ImageMagick Website page is http://www.imagemagick.org
; The author is magick@wizards.dupont.com.
;
; Detlev Dalitz.20020904
;..........................................................................................................................................
#EndFunction
:skip_udfimgfileclipput
;------------------------------------------------------------------------------------------------------------------------------------------
; --- test ---
sFilenameImage = StrCat(DirHome(),"WBOwl.bmp")
iResult = udfImgFileClipPut(sFilenameImage)
If iResult
Run("mspaint","")
While !WinExist("~Paint")
TimeDelay(2)
EndWhile
If WinExist("~Paint")
WinActivate("~Paint")
SendKey("^v") ; Paste Clipboard content to MSPaint.
Pause("Demo udfFileReadImageToClipboard (sFilenameImage)","Press OK to continue ...")
If WinExist("~Paint") Then WinClose("~Paint")
EndIf
EndIf
Exit
;------------------------------------------------------------------------------------------------------------------------------------------
*EOF*
|
||||
|
||||
If-Conditions, Inadequacies and Inadmissibilities |
||||
;------------------------------------------------------------------------------------------------------------------------------------------
; If-Conditions, Inadequacies and Inadmissibilities
;------------------------------------------------------------------------------------------------------------------------------------------
a=1
b=2
; This is syntactical ok.
If a==1
If b==2
c=3
EndIf
EndIf
Drop(a,b,c,d,e)
; This runs.
a=1
b=2
If a==1 Then If b==2 Then c=3
Drop(a,b,c,d,e)
; This runs.
a=1
b=2
If a==1 Then
If b==2 Then
c=3
EndIf
EndIf
Drop(a,b,c,d,e)
; This runs.
a=1
b=2
If a==1 Then If b==2 Then
c=3
EndIf
Drop(a,b,c,d,e)
; This is a failure.
a=1
b=2
If a==1 Then If b==2 Then
c=3
EndIf
EndIf ; <<<<<< 3357: End error: No match found.
Drop(a,b,c,d,e)
; This is a failure.
a=1
b=2
If a==1 Then If b==2 Then c=3
EndIf ; <<<<<< 3357: End error: No match found.
Drop(a,b,c,d,e)
; This runs.
a=1
b=0
If a==1 Then If b==2 Then c=3
Else c=9
Else d=9
Drop(a,b,c,d,e)
; This is a failure.
a=1
b=0
If a==1 Then If b==2 Then c=3
Else c=9
Else d=9
EndIf ; <<<<<< 3357: End error: No match found.
Drop(a,b,c,d,e)
; This runs.
a=1
b=2
If a==1 Then
If b==2 Then c=3
Else c=9
Else d=9
EndIf
Drop(a,b,c,d,e)
; This is a failure.
a=1
b=2
If a==1 Then
If b==2 Then
c=3
Else c=0 ; <<<<<< 3050: No IF to relate to THEN or ELSE is currently valid
Else d=0
EndIf
EndIf
Drop(a,b,c,d,e)
Exit
;------------------------------------------------------------------------------------------------------------------------------------------
|
||||
|
|
udfIIF (condition, truevalue, falsevalue) |
;------------------------------------------------------------------------------------------------------------
If ItemLocate("udfiif",IntControl(77,103,0,0,0),@TAB) Then Goto skip_udfiif
#DefineSubRoutine udfIIF (condition, truevalue, falsevalue)
If condition Then Return (truevalue)
Return (falsevalue)
#EndSubRoutine
:skip_udfiif
;------------------------------------------------------------------------------------------------------------
; --- Testcase 1 ; "Answer = eleven" ; "Answer = 70"
cProgVer = 11
cProgType = "STANDARD"
; --- Testcase 2 ; "Answer = other" ; "Answer = 99"
;cProgVer = 12
;cProgType = "PRO"
; --- Testcase 3 ; "Answer = eleven" ; "Answer = 75"
;cProgVer = 11
;cProgType = "PRO"
answer = udfIIF(cProgVer==11,"eleven","other")
Message("Demo udfIIF (condition, truevalue, falsevalue)",StrCat("Answer = ",answer))
; Nested udf's work fine too.
answer = udfIIF(cProgVer==11, udfIIF(cProgType=="STANDARD", 70, udfIIF(cProgType=="PRO", 75, 0)), 99)
Message("Demo udfIIF (condition, truevalue, falsevalue)",StrCat("Answer = ",answer))
Exit
;------------------------------------------------------------------------------------------------------------
*EOF*
|
|
|
udfIsInNumbers (iDigit)
|
;------------------------------------------------------------------------------------------------------------------------------------------
#DefineFunction udfIsInNumbers (iDigit)
Return (!!StrIndex("0123456789",iDigit,1,@FWDSCAN))
#EndFunction
#DefineFunction udfIsInAlphaNC (sChar) ; Ignorecase.
Return (!!StrIndexNC("ABCDEFGHIJKLMNOPQRSTUVWXYZ",sChar,1,@FWDSCAN))
#EndFunction
#DefineFunction udfIsInAlphaUC (sChar) ; Uppercase.
Return (!!StrIndex("ABCDEFGHIJKLMNOPQRSTUVWXYZ",sChar,1,@FWDSCAN))
#EndFunction
#DefineFunction udfIsInAlphaLC (sChar) ; Lowercase.
Return (!!StrIndex("abcdefghijklmnopqrstuvwxyz",sChar,1,@FWDSCAN))
#EndFunction
Exit
;------------------------------------------------------------------------------------------------------------------------------------------
*EOF*
;------------------------------------------------------------------------------------------------------------------------------------------
If ItemLocate("udfisalpha",IntControl(77,103,0,0,0),@TAB) Then Goto skip_udfisalpha
#DefineFunction udfIsAlpha (sString)
Return ((""!=sString)&&(""==StrClean(StrLower(sString),"esdiltnmarcpohfguwbxkyvjqz","",@TRUE,1)))
;..........................................................................................................................................
; This function "udfIsAlpha" returns a boolean value,
; which indicates if the given sString contains only alpha characters or not.
; 'Alpha characters' is the char set of [a-zA-Z].
;
; Detlev Dalitz.20031013
;..........................................................................................................................................
#EndFunction
:skip_udfisalpha
;------------------------------------------------------------------------------------------------------------------------------------------
; --- test ---
sString = "123abc"
iResult1 = udfIsAlpha(sString) ; ==> 0 = @FALSE.
sString = "abcABC"
iResult2 = udfIsAlpha(sString) ; ==> 1 = @TRUE.
sString = ""
iResult3 = udfIsAlpha(sString) ; ==> 0 = @FALSE.
Exit
;------------------------------------------------------------------------------------------------------------------------------------------
;*EOF*
|
|
|
How to prevent a called script from eaten up udf/uds slots |
;------------------------------------------------------------------------------------------------------------------------------------------
; How to prevent a called script from eaten up udf/uds slots.
;------------------------------------------------------------------------------------------------------------------------------------------
; Testcase to check how udf/uds declarations are counted while WinBatch runtime,
; both cases, run once in a script or in a loop by calling a script.
;------------------------------------------------------------------------------------------------------------------------------------------
; The maximum number of UDFs in a main plus called Winbatch scripts is 100.
; (Changed to 200 in version 2002D or newer).
; Each declaration of an udf/uds, even with the same name, increments the internal counter by 1.
; This design flaw can let scripts run into problems when running code in loops.
; Though the second udf/uds declaration uses the same name like it has been used prior by the first declaration
; the second udf/uds declaration's code definition is completely ignored,
; each declaration with the same name eatens up a slot in the internal udf/uds table.
;------------------------------------------------------------------------------------------------------------------------------------------
; Detlev Dalitz.20031004
;------------------------------------------------------------------------------------------------------------------------------------------
; The WinBatch interpreter processes lines from top to down.
; So let us walk along with the following lines.
; 1.
; At first we look into the internal parameters list of lists (IntControl(77,...))
; to make sure whatever udf/uds are registrated so far.
sUDFList = IntControl(77,103,0,0,0) ; 1. ==> ""
iUDFDefined = IntControl(77,090,0,0,0) ; 1. ==> 0
; Here we define/declare an User Defined Function with the name "udf".
; We use the udf later in the main part of the script.
#DefineFunction udf ()
Return 1
#EndFunction
; After the first declaration the internal parameters list gives the following status.
sUDFList = IntControl(77,103,0,0,0) ; 2. ==> "udf@TAB"
iUDFDefined = IntControl(77,090,0,0,0) ; 2. ==> 1
; 2.
; Now we let follow a second declaration/define statement with the same name,
; but we do not want to allow it to be loaded twice, because this would eat up a "udf slot".
; The following declaration is skipped by the Goto statement.
If ItemLocate("udf",IntControl(77,103,0,0,0),@TAB) Then Goto skip_udf
#DefineFunction udf ()
Return 2
#EndFunction
:skip_udf
;3.
; --- Main ---
; The internal parameters list gives the following status.
sUDFList = IntControl(77,103,0,0,0) ; 3. ==> "udf@TAB"
iUDFDefined = IntControl(77,090,0,0,0) ; 3. ==> 1
iResult = udf () ; ==> 1
Display(1,iUDFDefined,sUDFList)
; Set the counter for our testcase.
If !IsDefined(ii)
ii = 1
Else
ii = ii + 1
If ii>2 Then Return
EndIf
; 4.
; Now let us see how the script and the udf declarations will behave
; when calling it in a loop.
Call(IntControl(1004,0,0,0,0),"")
;5.
; At least we see, that jumping over the declaration code by a Goto statement
; will help us to prevent the WinBatch interpreter from registrating and counting
; more than one udf under the same name.
; The "unprotected udf" is registrated each time when it is seen by the interpreter.
; The "protected udf" is skipped each time the script runs.
; The following Message will show three entries at least, all named "udf".
; This is the result count of the "unprotected" declarations.
; The "protected" declarations are not showing up.
Message(iUDFDefined,sUDFList) ; ==> Should be '3|"udf@TABudf@TABudf@TAB"'
; While there is no other native implemented method
; to control the loading/unloading of udf/uds
; it will be good programming behaviour (well, it is in fact a "workaround")
; to use such a Goto/Skip construct as shown above.
; This can make secure a script not to run into eaten up slot problems.
Exit
;------------------------------------------------------------------------------------------------------------------------------------------
;*EOF*
|
|
|
How to prevent a script from trashing its Param* variables when calling a second script |
;===========================================================================================================================================
; How to prevent a script from trashing its Param* variables when calling a second script.
;===========================================================================================================================================
; This article is based on a posting
; From: snowsnowsnow gazelle@interaccess.com
; Date: Sunday, October 05, 2003 08:57 PM
; Conf: WinBatch
; Detlev Dalitz.20031006
;===========================================================================================================================================
; To demonstrate what is going on, we build a testcase.
; The testcase uses two script files.
;------------------------------------------------------------------------------------------------------------------------------------------
; The called script. Cut it out and save it to diskfile "CalledScript.wbt".
;------------------------------------------------------------------------------------------------------------------------------------------
; ;*BOF* CalledScript.wbt
;
; ;------------------------------------------------------------------------------------------------------------------------------------------
; #DefineFunction udfAdd (x, y)
; Return x+y
; #EndFunction
; ;------------------------------------------------------------------------------------------------------------------------------------------
;
; ; In case this script is called from another script then return at this point.
; If ((RtStatus()==0) &&(IntControl(77,80,0,0,0)>0)) Then Return (1) ; @RTSTATUS_WBINTERPRETER=0
; If ((RtStatus()==10)&&(IntControl(77,80,0,0,0)>1)) Then Return (1) ; @RTSTATUS_WBSTUDIODEBUG=10
;
; ; --- test ---
; a=100
; b=200
; c=udfAdd(a,b)
; Message("Sum",StrCat("a + b = c",@LF,a," + ",b," = ",c))
; Exit
;
; ;*EOF* CalledScript.wbt
;------------------------------------------------------------------------------------------------------------------------------------------
;------------------------------------------------------------------------------------------------------------------------------------------
; The main caller script "MainScript.wbt".
;------------------------------------------------------------------------------------------------------------------------------------------
;*BOF*
; Simulate the commandline input.
; The main script has received one parameter from commandline input.
Param0 = 1
Param1 = "xxx"
; UDF Declaration in main script.
;------------------------------------------------------------------------------------------------------------------------------------------
#DefineFunction udfLoadFunctionsFrom2ndScript ()
;Return Call("CalledScript.wbt","") ; Call the other script. Change path as needed.
Return Call("w:\winbatch\prod\howto\CalledScript.wbt","") ; Call the other script. Change path as needed.
;..........................................................................................................................................
; This function calls another script without trashing the main script's Param* variables.
;..........................................................................................................................................
#EndFunction
;------------------------------------------------------------------------------------------------------------------------------------------
; --- Main ---
; Call the 2nd script.
udfLoadFunctionsFrom2ndScript()
; Check if Param0 is still defined.
iP0 = Param0 ; ==> 1
; Check if Param1 is still defined.
sP1 = Param1 ; ==> "xxx"
; Check if the external declared function is useable.
iSum = udfAdd(1,2) ; ==> 3
Exit
;*EOF* MainScript.wbt
;------------------------------------------------------------------------------------------------------------------------------------------
; Test result:
; The main script's Param* variables are still alive.
; The user defined function works in the main script as defined in the 2nd script.
; Keep in mind, that, if the 2nd script defines some variables, which should be global to the main script,
; they will not become global to the main script, because they are local to the caller udf.
; By using a caller-UDF the main script knows nothing about the variables in the called script.
; The main script does know only the names of functions and subroutines, which are always global to the main script.
;
; This behaviour can be altered by using a caller-UDS, which allows the 2nd script to make global variables visible to the main script.
; But going this way, the Param* variables in the main script will be damaged.
; In any case, it would be the best way to copy the main script's Param* variables into a set of personal variables,
; and then invoke the 2nd script with a caller-UDF or caller-UDS as it will be appropriate.
; For ii=0 to Param0
; ParamMain%ii% = Param%ii%
; Next
;===========================================================================================================================================
;*EOF*
|
|
|
udfDTAddDays (sDateTime, iDayDiff) |
#DefineFunction udfDTAddDays (sDateTime, iDayDiff)
sMonth = ItemExtract(1,sDateTime,"/")
sDay = ItemExtract(2,sDateTime,"/")
sYear = ItemExtract(3,sDateTime,"/")
sYmdHms = StrCat(sYear,":",sMonth,":",sDay)
sYmdHms = TimeAdd(sYmdHms,StrCat("0:0:",iDayDiff))
sYear = ItemExtract(1,sYmdHms,":")
sMonth = ItemExtract(2,sYmdHms,":")
sDay = ItemExtract(3,sYmdHms,":")
sDateTime = StrCat(sMonth,"/",sDay,"/",sYear)
Return (sDateTime)
;..........................................................................................................................................
; The goal of the code is to take a date entered
; on a form "4/5/03" or "04/05/2003",
; translate it to time code "2003:04:05:00:00:00",
; add 30 days "2003:05:05:00:00:00",
; then translate it back to human readable "05/05/2003".
;
; sDateTime is ordered by "month/day/year".
; sDateTime: "4/5/03" ==> "05/05/2003"
; sDateTime: "04/05/2003" ==> "05/05/2003"
;..........................................................................................................................................
#EndFunction
; --- test ---
sDateTime11 = "4/5/03"
sDateTime12 = udfDTAddDays(sDateTime11,30) ; "05/05/2003"
sDateTime21 = "04/05/2003"
sDateTime22 = udfDTAddDays(sDateTime21,30) ; "05/05/2003"
Exit
;------------------------------------------------------------------------------------------------------------------------------------------
|
|
|
udfDOSSort (sFilenameIn, sFilenameOut, iDirection, iKeyStart)
|
;------------------------------------------------------------------------------------------------------------------------------------------
#DefineFunction udfDOSSort (sFilenameIn, sFilenameOut, iDirection, iKeyStart)
; Empty filenames are not allowed.
If (sFilenameIn=="") Then Return (@FALSE)
If (sFilenameOut=="") Then Return (@FALSE)
sFilenameIn = FileNameShort(sFilenameIn)
FileClose(FileOpen(sFilenameOut,"WRITE"))
sFilenameOut = FileNameShort(sFilenameOut)
sDosSortExe = "SORT.EXE"
; Try to find the sort executable on the system path.
sDosSortExe = FileLocate(sDosSortExe)
If (sDosSortExe=="")
; Try to find the sort executable in WinBatch system folder.
sDosSortExe = StrCat(DirHome(),sDosSortExe)
sDosSortExe = FileLocate(sDosSortExe)
; If sort executable not found, then return immediately.
If (sDosSortExe=="") Then Return (@FALSE)
EndIf
sDosSortExe = FileNameShort(sDosSortExe)
; Build the command string.
sDosCmd = ""
sDosCmd = ItemInsert("/c",-1,sDosCmd," ")
sDosCmd = ItemInsert(sDosSortExe,-1,sDosCmd," ")
If (iDirection==@DESCENDING) Then sDosCmd = ItemInsert("/R",-1,sDosCmd," ")
If (iKeyStart>0) Then sDosCmd = ItemInsert(StrCat("/+",iKeyStart),-1,sDosCmd," ")
sDosCmd = ItemInsert(StrCat("<",sFilenameIn),-1,sDosCmd," ")
sDosCmd = ItemInsert(StrCat(">",sFilenameOut),-1,sDosCmd," ")
Return RunWait(Environment("comspec"),sDosCmd)
;..........................................................................................................................................
;
;..........................................................................................................................................
; DOS sort command syntax:
; SORT [/R] [/+n] [<] [Laufwerk1:][Pfad1]Dateiname1 [> [Laufwerk2:][Pfad2] Dateiname2]
;..........................................................................................................................................
#EndFunction
;------------------------------------------------------------------------------------------------------------------------------------------
;------------------------------------------------------------------------------------------------------------------------------------------
#DefineFunction udfDOSBSort (sFilenameIn, sFilenameOut, iDirection, iMatchCase, iKeyStart, iKeySize)
; Empty filenames are not allowed.
If (sFilenameIn=="") Then Return (@FALSE)
If (sFilenameOut=="") Then Return (@FALSE)
sFilenameIn = FileNameShort(sFilenameIn)
FileClose(FileOpen(sFilenameOut,"WRITE"))
sFilenameOut = FileNameShort(sFilenameOut)
sDosSortExe = "BSORT.EXE"
; Try to find the sort executable on the system path.
sDosSortExe = FileLocate(sDosSortExe)
If (sDosSortExe=="")
; Try to find the sort executable in WinBatch system folder.
sDosSortExe = StrCat(DirHome(),sDosSortExe)
sDosSortExe = FileLocate(sDosSortExe)
; If sort executable not found, then return immediately.
If (sDosSortExe=="") Then Return (@FALSE)
EndIf
sDosSortExe = FileNameShort(sDosSortExe)
; Build the command string.
sDosCmd = ""
sDosCmd = ItemInsert("/c",-1,sDosCmd," ")
sDosCmd = ItemInsert(sDosSortExe,-1,sDosCmd," ")
If (iDirection==@DESCENDING) Then sDosCmd = ItemInsert("/R",-1,sDosCmd," ")
If (iMatchCase==@FALSE) Then sDosCmd = ItemInsert("/I",-1,sDosCmd," ")
If (iKeyStart>0) Then sDosCmd = ItemInsert(StrCat("/B ",iKeyStart),-1,sDosCmd," ")
If (iKeySize>0) Then sDosCmd = ItemInsert(StrCat("/L ",iKeySize),-1,sDosCmd," ")
sDosCmd = ItemInsert(StrCat("<",sFilenameIn),-1,sDosCmd," ")
sDosCmd = ItemInsert(StrCat(">",sFilenameOut),-1,sDosCmd," ")
Return RunWait(Environment("comspec"),sDosCmd)
;..........................................................................................................................................
;
;..........................................................................................................................................
; Big Sort. Copyright (c) 1987 by TurboPower Software. Version 5.06
;
; Usage: BSORT [Options] <InputFile >OutputFile
;
; Options:
; /R Sort in reverse order
; /I Sort ignoring case
; /B n Sort with key starting in column n
; /L n Sort with maximum key length of n characters
;..........................................................................................................................................
#EndFunction
;------------------------------------------------------------------------------------------------------------------------------------------
;--- test ---
sFilenameIn = IntControl(1004,0,0,0,0) ; Use this script as test input file.
sFilenameIn = FileNameShort(sFilenameIn)
sFilenameTemp = FileCreateTemp("TMP")
sFilenameOut = StrCat(sFilenameTemp,".txt")
FileMove(sFilenameTemp,sFilenameOut,@FALSE)
FileDelete(sFilenameOut)
iDirection = @DESCENDING
iKeyStart = 1
If udfDOSSort(sFilenameIn,sFilenameOut,iDirection,iKeyStart)
RunWait(sFilenameOut,"")
EndIf
FileDelete(sFilenameOut)
iDirection = @DESCENDING
iMatchCase = @FALSE
iKeyStart = 1
iKeySize = 1
If udfDOSBSort(sFilenameIn,sFilenameOut,iDirection,iMatchCase,iKeyStart,iKeySize)
RunWait(sFilenameOut,"")
EndIf
FileDelete(sFilenameOut)
Exit
;------------------------------------------------------------------------------------------------------------------------------------------
;*EOF*
|
|
Download BSORT.EXE: bsort.zip 8 KB
|
|
|
How to convert color bmp to grayscale bmp image file. |
;------------------------------------------------------------------------------------------------------------------------------------------
; How to convert color bmp to grayscale bmp image file.
;------------------------------------------------------------------------------------------------------------------------------------------
; We use the WinBatch 'Pixie Extender'.
; The Pixie Extender is a robust tool box that provides functions
; to read and write images in the following formats:
; GIFs, JPEGs, BMPs, and can read some other file formats.
;
; In this test case we create a temporary transfer file
; using the PGM Portable graymap format (gray scale).
;------------------------------------------------------------------------------------------------------------------------------------------
; Look at the following example.
;------------------------------------------------------------------------------------------------------------------------------------------
AddExtender("WWIMG34I.DLL") ; Load the 'Pixie Extender'.
sImageColor = StrCat(DirHome(),"WBOwl.bmp") ; Filename of input color bmp file.
sImageGray = StrCat(DirHome(),"WBOwl.gray.bmp") ; Filename of output grayscale bmp file.
sTemp = FileCreateTemp("") ; Create temporary helper file.
ImgConvert(sImageColor,StrCat("PGM:",sTemp)) ; Convert color bmp file to grayscale pgm file.
ImgConvert(sTemp,sImageGray) ; Convert pgm file to bmp file.
If FileExist(sTemp) Then FileDelete(sTemp) ; Delete temporary helper file.
RunWait(sImageGray,"") ; Take a look to the new file, using default viewer application.
If FileExist(sImageGray) Then FileDelete(sImageGray) ; Cleanup this test.
Exit
;------------------------------------------------------------------------------------------------------------------------------------------
;*EOF*
|
|
|
How to split a big text file into smaller files of n lines size each. |
;==========================================================================================================================================
; How to split a big text file into smaller files of n lines size each? Detlev Dalitz.20040331
;==========================================================================================================================================
;------------------------------------------------------------------------------------------------------------------------------------------
; Wednesday, March 31, 2004 12:15 AM
; Hi,
; can you help me with following problem?
; I have "big" file with more than 2800000 lines. I need split this file to smaller files with 64000 lines.
;
; Thanks Patrik
; patrikm patrikm@moravia-it.com
;------------------------------------------------------------------------------------------------------------------------------------------
; >How often do you have to do this task?
; Many times - I have database export and I need work with these data in Excel
;
; >Is the file a text file, line delimited by CRLF sequence?
; Lines are delimited with CRLF sequence
;
; >What filesize overall?
; About 400 MB
;------------------------------------------------------------------------------------------------------------------------------------------
; As a test case we use this script as test input file.
sFilename = IntControl(1004,0,0,0,0)
; Reality case, e.g. 2800000 lines, 400 MB.
;sFilename = "drive:\folder\bigfile.txt" ; <== Change path to your needs.
iFilesize = FileSize(sFilename)
Terminate(!iFileSize,"Error",StrCat(sFilename,@LF,"Filesize is zero."))
; --------------
@P1 = "{1}"
@P2 = "{2}"
sMsgTitle = "SplitBigFile"
sMsgText = "Searching split points ..."
BoxOpen(sMsgTitle,sMsgText)
sMsgTextMask = StrCat(sMsgText,@LF,sFilename,@LF,iFileSize,"/",@P1)
; --- Pass 1 ---
; We walk through the big file,
; and count the occurances of search literal,
; and calculate where split points are,
; and collect split offsets into an itemlist.
; What do we search? We search for CRLF sequences in the big text file.
sSearch = @CRLF
iSearchLen = StrLen(sSearch)
; As a test case we create split files with a size of 20 lines each (= 20 CRLF's).
iMaxSearch = 20
; Big text file to split into files of 64000 lines each.
;iMaxSearch = 64000 ; <== Change number to your needs.
; Chunk size can be adjusted to smaller or bigger chunks,
; depends on file size and system ressources.
iChunkSize = iFilesize/100 ; <== Change chunk size to your needs.
iChunkCount = 1+(iFilesize/iChunkSize)
sListSplit = ""
iOffsetFile = 0
iCountSearch = 0
hBB = BinaryAlloc(iChunkSize)
While iChunkCount
iOffsetBB = 0
iResult = BinaryReadEx(hBB,iOffsetBB,sFilename,iOffsetFile,iChunkSize)
While (iOffsetBB < iChunkSize)
iOffsetBB = BinaryIndexEx(hBB,iOffsetBB,sSearch,@FWDSCAN,@TRUE)
If (iOffsetBB < 0) Then Break
iOffsetBB = iOffsetBB + iSearchLen
iCountSearch = iCountSearch + 1
If !(iCountSearch mod iMaxSearch)
iOffsetSplit = iOffsetFile + iOffsetBB
sListSplit = ItemInsert(iOffsetSplit,-1,sListSplit,@TAB)
BoxText(StrReplace(sMsgTextMask,@P1,iOffsetSplit))
EndIf
EndWhile
iChunkCount = iChunkCount - 1
iOffsetFile = iOffsetFile + iChunkSize
EndWhile
If (iOffsetSplit < iFileSize)
sListSplit = ItemInsert(iFileSize,-1,sListSplit,@TAB)
BoxText(StrReplace(sMsgTextMask,@P1,iFileSize))
EndIf
BinaryFree(hBB)
; --- Pass 2 ---
; Create the split files.
iCount = ItemCount(sListSplit,@TAB)
iCountLen = StrLen(iCount)
sMsgText = "Writing split files ..."
BoxText(sMsgText)
sMsgTextMask = StrCat(sMsgText,@LF,iCount,"/",@P1,@LF,@P2)
sFileOutMask = StrCat(sFilename,".part.",iCount,".",@P1,".txt")
iSplitBegin = 0
iSplitEnd = 0
For ii=1 To iCount
; For better filename sort we make the counter number fixed length.
si = StrFixLeft(ii,"0",iCountLen) ; <== Change format to your needs.
; or leave the counter number as is.
; si = ii
iSplitEnd = ItemExtract(ii,sListSplit,@TAB)
iBBSize = iSplitEnd - iSplitBegin
hBB = BinaryAlloc(iBBSize)
iResult = BinaryReadEx(hBB,0,sFilename,iSplitBegin,iBBSize)
sFilenameOut = StrReplace(sFileOutMask,@P1,si)
BinaryWrite(hBB,sFilenameOut)
BinaryFree(hBB)
iSplitBegin = iSplitEnd
BoxText(StrReplace(StrReplace(sMsgTextMask,@P1,si),@P2,sFilenameOut))
Next
BoxShut()
; Look into the folder.
Run("explorer.exe",StrCat("/select, ",sFileName,"*.txt"))
Exit
;------------------------------------------------------------------------------------------------------------------------------------------
;==========================================================================================================================================
;*EOF*
|
| Page Date 2004-05-18 DD-Software |
|
|
|
MyWbtHelp current version |