MT Write Clipping : Source

Source

--- This source is written in HyperTalk for CompileIt!

global myType:OStype, mySize:longInt, myactSize:longInt,tgType:OStype
global theAEEvent:R,theReply:R, handerRefCon:LongInt, tgtType:OSType

codeResource "osax"

pascal function WriteToTextClip:I theAEEvent:R, theReply:R, handerRefCon:L

  put AESizeOfParam(theAEEvent@,keyDirectObject,myType,mySize) into err

  if err <> 0 then
    return err
  end if
  if mySize = 0 then
    return 0
  end if

  put NewPtrClear(78) into myWorkPtr
  put myWorkPtr into myDescPtr
  put myWorkPtr + 8 into myFssPtr


  if myType = "PICT" then
    put "PICT" into tgType
    put "clpp" into tgFtype
  else
    put "TEXT" into tgType
    put "clpt" into tgFtype
  end if

  put AEGetParamDesc(theAEEvent@,keyDirectObject,tgType,myDescPtr@) into err
  if err <> 0 then
    DisPosPtr myWorkPtr
    return err
  end if

  put myDescPtr@.dataHandle into myStrHandle

  put HandToHand(myStrHandle) into err
  put AEDisposeDesc(myDescPtr@) into xerr
  if err <> 0 then
    DisPosPtr myWorkPtr
    return err
  end if

  put false into myURLFlg

  if myType <> "PICT" then
    put AEGetParamDesc(theAEEvent@,"urlC","bool",myDescPtr@) into err
    if err = 0 then
      put myDescPtr@.dataHandle@@.booleanType into myURLFlg
      put AEDisposeDesc(myDescPtr@) into err
    end if
  end if

  if myURLFlg then
    put "ilht" into tgFtype
  end if

  put AEGetParamPtr(theAEEvent@,"tgfl",typeFSS,typeCode,myFssPtr,70,myactSize) into err
  if err <> 0 then
    DisPosPtr myWorkPtr
    DisposHandle myStrHandle
    return err
  end if

  put FSpCreate(myFssPtr@, "drag", tgFtype, 0) into err


  if err = -48 then
    put FSpDelete(myFssPtr@) into err
    if err = 0 then
      put FSpCreate(myFssPtr@, "drag", tgFtype, 0) into err
    end if
  end if

  if err<>0 then
    DisPosPtr myWorkPtr
    DisposHandle myStrHandle
    return err
  end if

  FSpCreateResFile myFssPtr@, "drag", tgFtype, 0

  put ResError() into err
  if err<>0 then
    DisPosPtr myWorkPtr
    DisposHandle myStrHandle
    return err
  end if

  put FSpOpenResFile(myFssPtr@, 0) into myRef
  if myRef < 0 then
    put ResError() into err
    DisPosPtr myWorkPtr
    DisposHandle myStrHandle
    return err
  end if

  if myURLFlg then
    put NewHandleClear(48) into dragHandle
    put NumToChar(1) into dragHandle@@.charType[3]
    put NumToChar(4) into dragHandle@@.charType[7]
    put NumToChar(2) into dragHandle@@.charType[15]
    put NumToChar(1) into dragHandle@@.charType[22]
    put NumToChar(1) into dragHandle@@.charType[38]
  else
    put NewHandleClear(32) into dragHandle
    put NumToChar(1) into dragHandle@@.charType[3]
    put NumToChar(4) into dragHandle@@.charType[7]
    put NumToChar(1) into dragHandle@@.charType[15]
    put NumToChar(1) into dragHandle@@.charType[22]
  end if

  put tgType into dragHandle@@.OStype[5]
  if myURLFlg then
    put "url " into dragHandle@@.OStype[9]
  end if

  addResource dragHandle,"drag",128,""
  put ResError() into err
  if err<>0 then
    CloseResFile myRef
    DisposHandle dragHandle
    DisposHandle myStrHandle
    DisPosPtr myWorkPtr
    return err
  end if

  ReleaseResource dragHandle

  if myURLFlg then
    put myStrHandle into myURLHandle
    put HandToHand(myURLHandle) into err
    if err<>0 then
      CloseResFile myRef
      DisposHandle myStrHandle
      DisPosPtr myWorkPtr
      return err
    end if

    addResource myURLHandle,"url ",256,""
    put ResError() into err
    if err<>0 then
      CloseResFile myRef
      DisposHandle myStrHandle
      Disposhandle myURLHandle
      DisPosPtr myWorkPtr
      return err
    end if

    ReleaseResource myURLHandle

  end if


  addResource myStrHandle,tgType,256,""

  put ResError() into err
  if err<>0 then
    CloseResFile myRef
    DisPosPtr myWorkPtr
    DisposHandle myStrHandle
    return err
  end if

  ReleaseResource myStrHandle

  CloseResFile myRef
  put FlushVol(nil,(myFssPtr@.IntegerType)) into err

  DisposPtr myWorkPtr


  return 0

end WriteToTextClip