/LCMS/CMYK/CMYK Example
Feedback.

Function:
You find this example project in your Plugins Download as a Realbasic project file within the examples folder: /LCMS/CMYK/CMYK Example
This example is the version from Fri, 4th Feb 2010.
Notes: Last modified: Fri, 4th Feb 2010

Class CMYKExample
Inherits Window
  // Controls
  ControlInstance
  End ControlInstance
  ControlInstance
  End ControlInstance
  ControlInstance
  End ControlInstance
  ControlInstance
  End ControlInstance
  ControlInstance
  End ControlInstance
  ControlInstance
  End ControlInstance
  ControlInstance
  End ControlInstance
  ControlInstance
    Sub Change() Handles Event
      run lastfile
    End Sub
  End ControlInstance
  
  // Properties
  Protected Dim lastfile As folderitem
  
  // Event implementations
  Sub EnableMenuItems()
    FileLoadCMYKJPEG.Enable
  End Sub
  Sub DropObject(obj As DragItem)
    dim f as FolderItem
    
    do
      if obj.FolderItemAvailable then
        f=obj.FolderItem
        lastfile=F
        run f
      end if
    loop until not obj.NextItem
  End Sub
  Sub Open()
    me.AcceptFileDrop "special/any"
    
    
  End Sub
  
  // Methods
  Sub runColorSync(inputpic as picture)
    dim p as Picture
    dim m as MemoryBlock
    dim cb,co as ColorSyncBitmapMBS
    dim cw as ColorSyncWorldMBS
    dim i,c as integer
    dim ci as ColorSyncProfileInfoMBS
    dim ip,op as ColorSyncProfileMBS
    dim n as String
    dim e as integer
    dim f as FolderItem
    dim j as JPEGExporterMBS
    dim fi,fo as FolderItem
    
    fi=GetFolderItem("Generic RGB Profile.icc")
    fo=GetFolderItem("Generic CMYK Profile.icc")
    
    ip=fi.OpenAsColorSyncProfileMBS
    op=fo.OpenAsColorSyncProfileMBS
    
    p=NewPicture(200,200,32)
    
    p.Graphics.DrawPicture inputpic,0,0
    
    originalc.Backdrop=p
    
    cb=CreateColorSyncBitmapMBS(p,false)
    
    const cmCMYKSpace                   = &h0002
    const cmLong8ColorPacking           = &h0800
    
    co=new ColorSyncBitmapMBS
    co.ColorSpaceType=cmCMYKSpace+cmLong8ColorPacking
    co.data=NewMemoryBlock(200*200*4)
    co.Height=200
    co.PixelSize=32
    co.RowBytes=200*4
    co.Width=200
    
    cw=NewColorSyncWorldMBS(ip,op)
    
    e=cw.MatchBitmap(cb,co)
    
    bc.Backdrop=getpicture(co,"black",3)
    cc.Backdrop=getpicture(co,"cyan",0)
    mc.Backdrop=getpicture(co,"magenta",1)
    yc.Backdrop=getpicture(co,"yellow",2)
    
    f=GetFolderItem("CMYK Example output CS.jpg")
    
    j=new JPEGExporterMBS
    
    j.File=f
    j.ExportCMYK co.data,co.Width,co.Height,co.RowBytes
    
    'MsgBox str(j.ErrorCode)+" "+j.ErrorMessage
  End Sub
  Function getpicture(c as colorsyncbitmapMBS,s as string,nn as integer) As picture
    // converts a ColorSyncBitmapMBS to a picture taking only one channel with offset nn
    
    dim p as Picture
    dim r as RGBSurface
    dim x,y as integer
    dim m as MemoryBlock
    dim n as integer
    dim i as integer
    
    p=NewPicture(200,200,32)
    r=p.RGBSurface
    m=c.Data
    n=nn
    
    for x=0 to 199
      for y=0 to 199
        
        i=255-m.byte(n)
        
        r.Pixel(y,x)=rgb(i,i,i)
        
        n=n+4
      Next
    next
    
    p.Graphics.ForeColor=rgb(255,0,0)
    p.Graphics.DrawString s,10,10
    
    Return p
  End Function
  Sub runColorMatching(inputpic as picture)
    dim p as Picture
    dim m as MemoryBlock
    dim cb,co as CMBitmapMBS
    dim cw as CMTransformMBS
    dim i,c as integer
    dim ip,op as CMProfileMBS
    dim n as String
    dim e as integer
    dim fi,fo as FolderItem
    dim f as FolderItem
    dim j as JPEGExporterMBS
    
    fi=GetFolderItem("Generic RGB Profile.icc")
    fo=GetFolderItem("Generic CMYK Profile.icc")
    
    ip=fi.OpenAsCMProfileMBS
    op=fo.OpenAsCMProfileMBS
    
    p=NewPicture(200,200,32)
    
    p.Graphics.DrawPicture inputpic,0,0
    
    originalc.Backdrop=p
    
    cb=LCMSMBS.CreateBitmapFromPicture(p)
    
    co=new CMBitmapMBS
    
    'icSigCmykData                       = 0x434D594BL,
    
    ' #define CHANNELS_SH(c)         ((c) << 3)
    ' #define BYTES_SH(b)            (b)
    ' #define COLORSPACE_SH(s)       ((s) << 16)
    ' #define PT_CMYK      6
    '
    ' (COLORSPACE_SH(PT_CMYK)|CHANNELS_SH(4)|BYTES_SH(1))
    
    co.ColorSpaceType=&h434D594B
    
    co.data=NewMemoryBlock(200*200*8)
    co.Height=200
    co.Width=200
    co.RowBytes=200*8
    
    cw=LCMSMBS.CreateTransform(ip,op,0)
    
    if cw.Transform(cb,co) then
      
      bc.Backdrop=getpictureCM(co,"black",6)
      cc.Backdrop=getpictureCM(co,"cyan",0)
      mc.Backdrop=getpictureCM(co,"magenta",2)
      yc.Backdrop=getpictureCM(co,"yellow",4)
      
      f=GetFolderItem("CMYK Example output CM.jpg")
      
      j=new JPEGExporterMBS
      
      j.File=f
      j.ExportCMYK shinkblock(co.data),200,200,200*4
      
      'MsgBox str(j.ErrorCode)+" "+j.ErrorMessage
    end if
    
    
  End Sub
  Function getpictureCM(c as cmbitmapMBS, s as string,nn as integer) As picture
    // converts a CMBitmapMBS to a picture taking only one channel with offset nn
    
    dim p as Picture
    dim r as RGBSurface
    dim x,y as integer
    dim m as MemoryBlock
    dim n as integer
    dim i as integer
    
    p=NewPicture(200,200,32)
    r=p.RGBSurface
    m=c.Data
    n=nn
    
    for x=0 to 199
      for y=0 to 199
        
        i=m.ushort(n)\257
        
        i=255-i
        
        r.Pixel(y,x)=rgb(i,i,i)
        
        n=n+8
      Next
    next
    
    p.Graphics.ForeColor=rgb(255,0,0)
    p.Graphics.DrawString s,10,10
    
    Return p
  End Function
  Function shinkblock(m as memoryBlock) As memoryBlock
    // CM uses 2 bytes per subpixel, but we need one byte.
    
    dim o as MemoryBlock
    dim s1,s2 as integer
    dim n1,n2,u as integer
    
    s1=m.Size
    
    s2=s1/2
    o=NewMemoryBlock(s2+1024)
    
    if o<>nil then
      u=s2-1
      for n2=0 to u
        o.Byte(n2)=m.Short(n1)\257
        
        n1=n1+2
      next
      
      Return o
    end if
  End Function
  Sub runRBCM(inputpic as picture, noblack as boolean)
    dim p as Picture
    dim m as MemoryBlock
    dim f as FolderItem
    dim j as JPEGExporterMBS
    dim x,y,xx,yy as integer
    dim r as RGBSurface
    dim n as integer
    dim c as color
    dim rr,gg,bb as integer
    dim kk as integer
    
    p=NewPicture(200,200,32)
    
    p.Graphics.DrawPicture inputpic,0,0
    
    originalc.Backdrop=p
    
    m=NewMemoryBlock(200*200*4)
    
    r=p.RGBSurface
    xx=p.Width-1
    yy=p.Height-1
    
    n=0
    
    if noblack then
      for y=0 to yy
        for x=0 to xx
          
          
          c=r.Pixel(x,y)
          
          // without black part it's faster:
          
          m.Byte(n)=255-c.red // c
          n=n+1
          m.Byte(n)=255-c.green // m
          n=n+1
          m.Byte(n)=255-c.blue // y
          n=n+1
          m.Byte(n)=0 // k
          n=n+1
        next
      next
      
    else
      for y=0 to yy
        for x=0 to xx
          
          // with black
          
          c=r.Pixel(x,y)
          
          rr=255-c.red
          gg=255-c.green
          bb=255-c.blue
          kk=min(min(rr,gg),bb)
          rr=rr-kk
          gg=gg-kk
          bb=bb-kk
          
          m.Byte(n)=rr // c
          n=n+1
          m.Byte(n)=gg // m
          n=n+1
          m.Byte(n)=bb // y
          n=n+1
          m.Byte(n)=kk // k
          n=n+1
          
        next
      next
    end if
    
    cc.Backdrop=getpictureRBCM(m,p.Width,p.Height,"cyan",0)
    mc.Backdrop=getpictureRBCM(m,p.Width,p.Height,"magenta",1)
    yc.Backdrop=getpictureRBCM(m,p.Width,p.Height,"yellow",2)
    bc.Backdrop=getpictureRBCM(m,p.Width,p.Height,"black",3)
    
    if noblack then
      f=GetFolderItem("CMYK Example output CMRB1.jpg")
    else
      f=GetFolderItem("CMYK Example output CMRB2.jpg")
    end if
    
    j=new JPEGExporterMBS
    
    j.File=f
    j.ExportCMYK m,p.Width,p.Height,p.Width*4
    
    'MsgBox str(j.ErrorCode)+" "+j.ErrorMessage
  End Sub
  Function getpictureRBCM(m as memoryblock, w as integer,h as integer, s as string,nn as integer) As picture
    // converts a memoryblock to a picture taking only one channel with offset nn
    
    dim p as Picture
    dim r as RGBSurface
    dim x,y as integer
    dim n as integer
    dim i as integer
    dim ww,hh as integer
    
    ww=w-1
    hh=h-1
    p=NewPicture(w,h,32)
    r=p.RGBSurface
    n=nn
    
    for x=0 to ww
      for y=0 to hh
        
        i=m.byte(n)
        
        i=255-i
        
        r.Pixel(y,x)=rgb(i,i,i)
        
        n=n+4
      Next
    next
    
    p.Graphics.ForeColor=rgb(255,0,0)
    p.Graphics.DrawString s,10,10
    
    Return p
  End Function
  Sub loadjpeg(f as folderItem)
    dim j as JPEGImporterMBS
    dim m as MemoryBlock
    
    j=new JPEGImporterMBS
    
    j.File=f
    j.ImportCMYK
    
    Title=f.DisplayName+" ("+str(j.Width)+" x "+str(j.Height)+")"
    
    m=j.PictureData
    
    if m=nil then
      MsgBox "No data imported!?"
    else
      cc.Backdrop=getpictureJPEG(m,min(200,j.Width),min(200,j.Height),"cyan",0,j.Width*4)
      mc.Backdrop=getpictureJPEG(m,min(200,j.Width),min(200,j.Height),"magenta",1,j.Width*4)
      yc.Backdrop=getpictureJPEG(m,min(200,j.Width),min(200,j.Height),"yellow",2,j.Width*4)
      bc.Backdrop=getpictureJPEG(m,min(200,j.Width),min(200,j.Height),"black",3,j.Width*4)
    end if
    
  End Sub
  Function getpictureJPEG(m as memoryblock, w as integer,h as integer, s as string,nn as integer,rowbytes as integer) As picture
    // converts a JPEG memoryblock to a picture taking only one channel with offset nn
    
    dim p as Picture
    dim r as RGBSurface
    dim x,y as integer
    dim n as integer
    dim i as integer
    dim ww,hh as integer
    dim d as integer
    
    ww=w-1
    hh=h-1
    p=NewPicture(w,h,32)
    r=p.RGBSurface
    d=nn
    
    for x=0 to ww
      n=d
      for y=0 to hh
        
        i=m.byte(n)
        
        r.Pixel(y,x)=rgb(i,i,i)
        
        n=n+4
      Next
      d=d+rowbytes
    next
    
    p.Graphics.ForeColor=rgb(255,0,0)
    p.Graphics.DrawString s,10,10
    
    Return p
  End Function
  Protected Sub run(f as folderitem)
    dim p as Picture
    
    if f<>nil then
      p=f.OpenAsPicture
      if p<>nil then
        if PopupMenu1.ListIndex=0 then
          runColorSync p
        elseif PopupMenu1.ListIndex=1 then
          runColorMatching p
        elseif PopupMenu1.ListIndex=2 then
          runRBCM p,true
        else
          runRBCM p,false
        end if
      end if
    end if
  End Sub
End Class

Class App
Inherits Application
  // Event implementations
  Function UnhandledException(error As RuntimeException) As Boolean
    
    #if DebugBuild
    #else
      if error isa NilObjectException then
        MsgBox "There was a nil object exception somewhere."
      else
        MsgBox "There was an exception somewhere."
      end if
      
      Return true
    #endif
    
  End Function
End Class