Determ if QuickTime is installed:
(This solution will only work on Mac.)
Dim s as string
Dim b as boolean
Dim i,resp as integer
b=system.gestalt("qtim",resp)
If b then
s=Hex(resp)
For i =Len(s) downto 1
s=Left(s,i)+"."+Mid(s,i+1)
Next
MsgBox s
else
msgbox "not installed"
End if
Get the PPP Status:
Here's the code to get the PPP status:
Function PPPstatus() As String
dim po,sl as integer
dim s as string
Dim a as AppleEvent
a = NewAppleEvent("netw","RAst", "MACS")
If a.Send Then
s=a.replystring
po=instr(s,"RAmsTEXT")+8
sl=ReadLong(mid(s,po))
po=po+4
// this returns the status text displayed in
//the PPP control panel
return mid(s,po,sl)
else
return "ERROR"
End if
End Function
Function ReadLong(Str As String) As Integer
dim theint as integer
theint = theint + (16777216*asc(mid(str,1,1)))
theint = theint + (65536*asc(mid(str,2,1)))
theint = theint + (256*asc(mid(str,3,1)))
theint = theint + asc(mid(str,4,1))
return theint
End Function
Time Connected:
Returns the totals second since you got connected using remote access
Dim SecConnected as String
ae = NewAppleEvent("netw","RAst","MACS")
If ae.send then
SecConnected = ae.ReplyRecord.StringParam("RAsc")
if SecConnected <> "0" then
msgbox "Time connected: " + SecConnected
else
msgbox "You are not connected"
end if
else
msgbox "Some funky error"
end if
Get Computer Owner and Name:
Yes. These are stored in system resources.
ID -16096 stores the Owner name
ID -16413 stores the Computer name
The following code will return them:
dim theRes, theOwner as String
dim theLength as Integer
theRes = App.ResourceFork.GetResource("STR ", -16096) // this is a System resource; the
// System resource fork is always open
theLength = Asc(Left(theRes, 1)) // Pascal string: the first byte indicates the length
theOwner = Mid(theRes, 2, theLength)
Get the System Font:
Declare sub GetFontName lib "InterfaceLib" (id as integer,fontname as ptr) inline68k("A8FF")
Declare sub GetSysFont lib "InterfaceLib" () as integer
Dim sysfont as memoryblock
sysfont = newMemoryBlock(256)
GetFontName GetSysFont(), sysfont
msgbox "The system font is " + sysfont.pstring(0)
Get Finder Labels Color and Name:
This function returns the color of a label in c and the name in s for a label number given in labelNumber.
Sub GetLabelAndColor(labelNumber as integer, ByRef s as string, ByRef c as color)
dim labelColor, labelStringPtr as MemoryBlock
dim err as integer
labelColor = NewMemoryBlock(6)
labelStringPtr = NewMemoryBlock(255)
Declare Function GetLabel lib "CarbonLib" (labelNumber as integer, labelColor as Ptr, labelStringPtr as Ptr) as Integer
err = GetLabel(labelNumber,labelColor,labelStringPtr)
if err = 0 then
c = rgb(labelColor.byte(0), labelColor.byte(2),labelColor.byte(4))
s = labelStringPtr.Pstring(0)
else
msgbox "Error: " + str(err)
end if
End Sub
Get the comment of a file:
Function GetComment(f as folderItem) As string
Declare Function PBDTGetCommentSync Lib "InterfaceLib" (paramBlock as Ptr) as Short Inline68K("205F702AA2603E80")
Declare Function PBDTGetPath Lib "InterfaceLib" (paramBlock as Ptr) as Short Inline68K("205F7020A2603E80")
dim rec, data ,name as MemoryBlock
dim err,DTRefNum,volumeIDX as integer
//volumeIDX is the volume number changed to the desired volume
rec = NewMemoryBlock(120)
data = NewMemoryBlock(200)
name = NewMemoryBlock(512)
rec.Ptr(18)=name // ioNamePtr
rec.Short(22) = Volume(volumeIDX).MacVRefNum
rec.Ptr(32)=data // ioDTBuffer
err = PBDTGetPath(rec)
if err = 0 then
DTRefNum = rec.Short(24)
else
return false
end if
rec = NewMemoryBlock(120)
data = NewMemoryBlock(400)
name = NewMemoryBlock(512)
name.PString(0) = f.Name
rec.Ptr(18)=name // ioNamePtr
rec.Short(24) = DTRefNum // ioDTRefNum
rec.Ptr(32) = data // ioDTBuffer
rec.Long(36) = 400 // ioDTReqCount
rec.Long(48) = f.MacDirID // ioDirID
err = PBDTGetCommentSync(rec)
if err = 0 then
return data.CString(0)
else
return ""
end if
return ""
End Function
Determs if an application with a given creator exists:
Function IsAPPL(code as string) As boolean
//returns true if appl exists in db.
Declare Function PBDTGetAPPLSync Lib "CarbonLib" (paramBlock as Ptr) as Short
Declare Function PBDTGetPath Lib "CarbonLib" (paramBlock as Ptr) as Short
dim rec, data ,name as MemoryBlock
dim err,DTRefNum,volumeIDX as integer
//volumeIDX is the volume number changed to the desired volume
rec = NewMemoryBlock(120)
data = NewMemoryBlock(200)
name = NewMemoryBlock(512)
rec.Ptr(18)=name // ioNamePtr
rec.Short(22) = Volume(volumeIDX).MacVRefNum
rec.Ptr(32)=data // ioDTBuffer
err = PBDTGetPath(rec)
if err = 0 then
DTRefNum = rec.Short(24)
else
return false
end if
if lenb(code) = 4 then
rec = NewMemoryBlock(120)
data = NewMemoryBlock(200)
name = NewMemoryBlock(512)
rec.Ptr(18)=name // ioNamePtr
rec.Short(24) = DTRefNum
rec.Ptr(32)=data // ioDTBuffer
rec.Cstring(52) = code
err = PBDTGetAPPLSync(rec)
if err = 0 then
return true
end if
end if
return false
End Function
Bring your Application to the front (getfocus):
You need to declare a global property CurProc as memoryblock, if you have an application class on your project
place this code on the Open event of your application, else on the open event of your start up form.
Sub Open()
declare sub GetCurrentProcess lib "InterfaceLib" (proc as ptr) inline68K("3F3C0037A88F")
//CurProc as memoryblock, declared as a global property
CurProc = NewMemoryBlock(8)
GetCurrentProcess CurProc
End Sub
Sub DoBringMeToFront()
declare sub SetFrontProcess lib "InterfaceLib" (proc as ptr) inline68K("3F3C003BA88F")
SetFrontProcess CurProc
End Sub
else you may call a function like this:
Sub bringMeToFront()
declare sub GetCurrentProcess lib "InterfaceLib" (proc as ptr) inline68K("3F3C0037A88F")
declare sub SetFrontProcess lib "InterfaceLib" (proc as ptr) inline68K("3F3C003BA88F")
dim CurProc as memoryblock
CurProc = NewMemoryBlock(8)
GetCurrentProcess CurProc
SetFrontProcess CurProc
End Sub
Bitwise Utilities:
Function SetBit(Value as integer,TheBit as integer) as Integer
return bitwiseOR(Value,pow(2,TheBit))
End Function
Function ClearBit(Value as integer,TheBit as integer) as Integer
return bitwiseAND(Value,bitwiseXOR(&hFFFFFFFF,pow(2,TheBit)))
End Function
Function GetBit(Value as integer,TheBit as integer) as Boolean
return (Value/pow(2,TheBit)) mod 2 = 1
End Function
//which is the same as
Function GetBit(Value as integer,TheBit as integer) as Boolean
if (Value/pow(2,TheBit)) mod 2 = 1 then
return true
else
return false
end if
End Function
Computing the Difference between two dates in days:
Function GetDateDiff(d1 as Date,d2 as date) As Integer
dim TheDiff as Double
//d1 is start date, d2 end date
if d1.Year > d2.year then
return -1
end if
if d2.Year - d1.year > 1 then
return -1
end if
TheDiff = d2.TotalSeconds - d1.TotalSeconds
Return TheDiff * 86400 //use 604800 for weeks
End Function
Adjust the current time to a particular time zone:
Function GetAdjustedTime(d as Date,thetmz as String) As Date
dim TotalS as Double, dn as Date, tmz as string, tmzv as integer
tmz = "IDL,-12,BT,-11,AHST,-10,YST,-9,PST,-8,MST,-7,CST,-6,EST,-5,CDT,-5,EDT,-4,PDT,-7,MDT,-6,AST,-4,BST,-3,AT,-2"
tmz = tmz + ",WAT,-1,GMT,0,CET,1,EET,2,USZ1S,3,ZP4,4,ZP5,5,ZP6,6,SST,7,CCT,8,JST,9,GST,10,EADT,11,NZT,12,NZDT,12"
for i = 1 to (countFields(tmz,",") - 1) step 2
if thetmz = nthfield(tmz,",",i) then
tmzv = val(nthfield(tmz,",",i+1))
exit
end if
next
TotalS = d.TotalSeconds + (tmzv * 60) * 60
dn = new Date
dn.TotalSeconds = TotalS
Return dn
End Function
If you already know the offset of the given time zone you can just use: d.TotalSeconds + (tmzv * 60) * 60 replacing tmzv with the given offset.
Compute the age of a person with a given birthdate:
dim BirthDate,TodayDate as date
dim TheAge as Double
if not ParseDate("09/6/1974",BirthDate) then
msgbox "What on earth? An Error!"
return
end if
TodayDate = New Date //initialize to today
TheAge = (TodayDate.Year - BirthDate.Year) - 1
if TodayDate.Month = BirthDate.Month then
if TodayDate.Day >= BirthDate.Day then
TheAge = TheAge + 1
end if
elseif TodayDate.Month > BirthDate.Month then
TheAge = TheAge + 1
end if
msgbox str(TheAge) + " Years"
Display Alert Resources:
Sub Action()
Declare Function Alert Lib "InterfaceLib" (alertID as Short, dummy as integer) as integer
//these are just like Alert but use their one icon (stop,note and caution) feel free to use them
Declare Function StopAlert Lib "InterfaceLib" (alertID as Short, dummy as integer) as integer
Declare Function NoteAlert Lib "InterfaceLib" (alertID as Short, dummy as integer) as integer
Declare Function CautionAlert Lib "InterfaceLib" (alertID as Short, dummy as integer) as integer
Declare Sub ParamText Lib "InterfaceLib" (param0 as PString, param1 as PString, param2 as PString, param3 as PString)
dim i as integer
//ParamText will substitute the special strings ^0 up to ^4 with the text you set it
//ParamText "Hello Jose was here","","",""
i = Alert(129,0)
End Sub
Show and Hide Help Balloons and determ the state of Balloon Help:
dim i as integer
Declare Function HMSetBalloons Lib "InterfaceLib" (flag as Boolean) as Short Inline68K("303C0104A830")
Declare Function HMGetBalloons Lib "InterfaceLib" () as Boolean Inline68K("303C0007A830")
i = HMSetBalloons(true)
//Toogle balloon help on and off depending on the current state
if HMGetBalloons() then
//is on turn them off
i = HMSetBalloons(false)
else
//is off turn them on
i = HMSetBalloons(true)
end if
// a better way to toggle ballo ons on and off would be: i = HMSetBalloons(NOT HMGetBalloons())
Use HMSetBalloons(false) to turn them off
Get a Unique ID for a resource of the given type:
Use this function when you want to add a new resource to a file and avoid duplicating or overriding an existing resource. The ID will be greater to any ID found for the given type
in any open resource fork, meaning that the ID may not fallow the sequence in your fork.
Declare Function UniqueID Lib "InterfaceLib" (theType as OSType) as Short Inline68K("A9C1")
Dim ID as integer
ID = UniqueID("cicn")
To overcome the global nature of UniqueID use this instead
Declare Function Unique1ID Lib "InterfaceLib" (theType as OSType) as Short Inline68K("A9C1")
Unique1ID will return a unique ID for the current fork. If you call this function sometime right after you open
your fork then is more likely that yours is the current.
Color to grey:
1. NTSC and PAL method:
c = rgb(c.Red * 0.299,c.Green * 0.587,c.Blue * 0.114)
2. Average of Colors method:
w = (c.red + c.green + c.blue)/3
c = rgb(c.Red * w,c.Green * w,c.Blue * w)
3. ITU-R method:
c = rgb(c.Red * 0.2125,c.Green * 0.7154,c.Blue * 0.0721)
Basic HTML Decode:
Here is a snippet of the bare minimum required to decode HTML :
HTMLDecode = replaceAll(HTMLDecode," "," ")
HTMLDecode = replaceAll(HTMLDecode,""",chr(34))
HTMLDecode = replaceAll(HTMLDecode,"&","&")
HTMLDecode = replaceAll(HTMLDecode,"<","<")
HTMLDecode = replaceAll(HTMLDecode,">",">")
Use OLEObject to access MS Outlook
I decided to put together an example on how to automate Outlook access using OLE.
Dim obj,olNameSpace,olFolder,olItems,olItem as OLEObject
Dim v as Variant,i,c,t as integer
Dim params(1) as Variant
obj = New OLEObject("outlook.application")
params(1) = "MAPI"
olNameSpace = obj.invoke("GetNameSpace",params)
params(1) = "10"
olFolder = olNameSpace.invoke("GetDefaultFolder",params)
olItems = olFolder.Property("Items")
c = olItems.property("Count")
dim sEmail,sFullName,sCell,sWork,sHome,sNick as string
dim sCompany as string
for i = 1 to c
Params(1) = i
//Since RB has no methods to access OLE Collections we can call it as
//a method, this work with most COM servers.
olItem = olItems.invoke("Item",Params)
sEmail = olItem.property("EMail1Address")
sFullName = olItem.property("FullName")
sCell = olItem.property("MobileTelephoneNumber")
sWork = olItem.property("BusinessTelephoneNumber")
sHome = olItem.property("HomeTelephoneNumber")
sNick = olItem.property("NickName")
sCompany = olItem.property("CompanyName")
msgbox "Found: " + sEmail + endOfLine + sFullName + endOfLine + sWork + endOfLine + sCell + endOfLine + sHome
next
Exception err as OLEException
Msgbox err.message
Basic URLDecode:
Function URLDecode(Data as string) As String
Dim HexCH,CH as string
Dim sData as string
Dim sPos as integer
sData = ReplaceAll(Data, "+", " ")
sPos =inStr(sData, "%")
While sPos > 0
HexCH = Mid(sData, sPos + 1, 2)
CH = char(Val("&H" + HexCH))
sData = ReplaceAll(sData, "%" + HexCH, CH)
sPos = inStr(sData, "%")
Wend
Return sData
End Function
Basic URLEncode:
Function URLEncode(Data as string) As String
dim c,l,i as integer
dim ch,s,sEncoded as string
s = Data
l = Len(s)
for i = 1 to l
c = asc(mid(s,i,1))
if c < 33 or c > 128 then
sEncoded = sEncoded + "%" + Hex(c)
else
sEncoded = sEncoded + str(c)
end if
next
Return s
End Function
