Classic Control Menu 1.0 Sourcecode
App.BundleLocalizedString:
Function BundleLocalizedString(s as string) As string
dim t as String
t=app.BundleLocalizedStringMBS(s)
if t="" then
Return s
else
Return t
end if
Exception
End Function
App.MakeImages:
Sub MakeImages()
dim i as IconMBS
dim f as IconFamilyMBS
dim x,y as integer
dim r as RGBSurface
dim c as color
dim n as integer
dim b as Boolean
// find the icon
i=new IconMBS("APPL","bxls")
// extract parts
f=i.IconFamily
// Copy the nice small icon
ClassicOn=f.Small32BitData.CloneMBS
ClassicMask=f.Small8BitMask.CloneMBS
b=ClassicMask.InvertMBS(0,0,16,16)
// now make a grayscale copy
ClassicOff=Classicon.CloneMBS
r=ClassicOff.RGBSurface
for x=0 to 15
for y=0 to 15
c=r.Pixel(x,y)
n=(c.red+c.blue+c.green)\3
c=rgb(n,n,n)
r.Pixel(x,y)=c
next
next
Exception
End Sub
App.MakePictureBlock:
Function MakePictureBlock(p as picture,m as picture) As memoryBlock
dim b as MemoryBlock
dim x,y as integer
dim w,h as integer
dim n as integer
dim w1,h1 as integer
dim c as color
dim r as RGBSurface
dim rm as RGBSurface
w=min(m.Width,p.Width)
h=min(m.Height,p.Height)
w1=w-1
h1=h-1
b=NewMemoryBlock(w*h*4)
n=0
r=p.RGBSurface
rm=m.RGBSurface
for y=0 to h1
for x=0 to w1
c=r.Pixel(x,y)
b.Byte(n)=c.red
n=n+1
b.Byte(n)=c.green
n=n+1
b.Byte(n)=c.blue
n=n+1
c=rm.Pixel(x,y)
b.Byte(n)=c.red // Use Red from mask for alpha
n=n+1
next
next
Return b
Exception
End Function
App.updateStatus:
Sub updateStatus()
dim p as ProcessMBS
p=new ProcessMBS
p.GetFirstProcess
do
'DebugMessageMBS """"+p.Name+""""
if p.MacCreator="bbox" then
'DebugMessageMBS "Classic running."
SetClassicActive
Return
end if
loop until not p.GetNextProcess
'DebugMessageMBS "Classic not running."
SetClassicNotActive
Exception
End Sub
App.SetClassicActive:
Sub SetClassicActive()
s.SetImageWithMemoryBlock PictureOn,16,16
items(1).Enabled=false
items(2).Enabled=true
Exception
End Sub
App.SetClassicNotActive:
Sub SetClassicNotActive()
s.SetImageWithMemoryBlock PictureOff,16,16
items(1).Enabled=true
items(2).Enabled=false
Exception
End Sub
App.Open:
Sub Open()
dim f as FolderItem
dim i as MyCocoamenuitem
RegisterPlugins
DebugMessageEnableMBS true
// Watch application launches:
c=new CarbonEvents
c.Listen
// Load Menu bundle
s=new CocoaStatusItemMBS
f=getfolderitem("StatusItem.bundle")
if not s.LoadStatusItem then
if not s.LoadStatusItemFile(f) then
f=DesktopFolder.Child("StatusItem.bundle")
if not s.LoadStatusItemFile(f) then
beep
quit
end if
end if
if not s.Available then
beep
quit
end if
end if
MakeImages
PictureOn=MakePictureBlock(Classicon,ClassicMask)
PictureOff=MakePictureBlock(Classicoff,ClassicMask)
// Create statusitem
s.CreateMenu(24)
s.HighlightMode=true
s.Title=NewCFStringMBS("")
// create a menu to attach to the statusitem
m=new CocoaMenuMBS
m.CreateMenu
// Create menu items
i=new MyCocoamenuitem
i.CreateMenuItem NewCFStringMBS(BundleLocalizedString("Start")),nil
i.ID=1
m.AddItem i
items.Append i
i=new MyCocoamenuitem
i.CreateMenuItem NewCFStringMBS(BundleLocalizedString("Stop")),nil
i.ID=2
m.AddItem i
items.Append i
i=new MyCocoamenuitem
i.CreateMenuItem NewCFStringMBS(BundleLocalizedString("OpenSysPrefs")),nil
i.ID=3
m.AddItem i
items.Append i
// I'd like to kill, but we can't kill it as it doesn't show up on the ProcessMBS class
// BTW, it's a root process so we may not even be able to kill it in case we get the ProcessID
'i=new MyCocoamenuitem
'i.CreateMenuItem NewCFStringMBS(BundleLocalizedString("ForceQuit")),nil
'i.ID=4
'm.AddItem i
'items.Append i
i=new MyCocoamenuitem
i.CreateSeparator
m.AddItem i
items.Append i
i=new MyCocoamenuitem
i.CreateMenuItem NewCFStringMBS(BundleLocalizedString("Quit")),nil
i.ID=5
m.AddItem i
items.Append i
// attach menu
s.Menu=m
updateStatus
Exception
End Sub
App.Close:
Sub Close()
if s<>nil then
s.Close
DelayMBS 0.2 // wait for events to flush
end if
Exception
End Sub
MyCocoamenuitem.launchPref:
Sub launchPref()
dim s as Shell
s=new Shell
s.Execute "/usr/bin/open /System/Library/PreferencePanes/Classic.prefPane"
Exception
End Sub
MyCocoamenuitem.ForceQuit:
Sub ForceQuit()
// Doesn't work. Kills Classic Support, but not the TrueBlueEnvironment
dim p as ProcessMBS
p=new ProcessMBS
p.GetFirstProcess
do
if p.MacCreator="bbox" then
DebugMessageMBS "Kill Classic: "+str(p.KillProcess)
Return
end if
loop until not p.GetNextProcess
DebugMessageMBS "Classic process not found!"
Exception
End Sub
MyCocoamenuitem.StartClassic:
Sub StartClassic()
dim f as FolderItem
f=LaunchServicesFindApplicationForInfoMBS("","com.apple.Classic","Classic Startup.app")
if f=nil then
DebugMessageMBS "Failed to find Classic Startup.app"
else
f.Launch
end if
Exception
End Sub
MyCocoamenuitem.StopClassic:
Sub StopClassic()
dim s as String
dim a as AppleScriptMBS
s="tell application ""Classic Support"" to quit"
a=new AppleScriptMBS
a.Compile s
if a.Lasterror=0 then
a.Execute
end if
if a.Lasterror<>0 then
DebugMessageMBS "AppleScript error with StopClassic: "+str(a.Lasterror)
end if
Exception
End Sub
MyCocoamenuitem.Action:
Sub Action(id as integer)
Select case id
case 1
StartClassic
case 2
StopClassic
case 3
launchPref
case 4
ForceQuit
case 5
quit
end Select
Exception
End Sub
CarbonEvents.ApplicationLaunched:
Sub ApplicationLaunched(ProcessSerial as memoryblock)
app.updateStatus
End Sub
CarbonEvents.ApplicationTerminated:
Sub ApplicationTerminated(ProcessSerial as memoryblock)
app.updateStatus
End Sub
Links
MBS Filemaker Plugins - Pfarrgemeinde St. Arnulf Nickenich