Skip to main content

Copying an image from the clipboard, modifying it and returning it to the clipboard


I have a Mathematica script to help me copy images from PDFs and then make the (presumably white or nearly white) background transparent. Typically, I am looking at the PDF in Adobe Acrobat and I use the snapshot tool to copy the image to Microsoft Window's clipboard. Then I paste the image into mathematica and assign it the name q. Where I typed {IMAGE} below is where I paste the image into the code:


q = {IMAGE};
p = ColorNegate[Binarize[ImageApply[Min, q], 0.99]];
s = SetAlphaChannel[q, p];
Export["img.png", s];

I run the code and I get a PNG with a transparent background and then I can insert the png with the transparent background into OneNote.


The point of doing this is images with a transparent background are easier to arrange since the don't obscure the other texts. This makes it a snap to place graphs and equations in my notes.


I would like to make this even easier by enhancing my script. This is why I am asking for help. My goals are:





  1. Is there some Mathematica command I can use to copy the image from the clipboard automatically without having to manually paste it.




  2. Is there a way to get Mathematica to place the image back into the clipboard with a transparent background, thus cutting out the step of using a file.




What I have found is if I use a command like CopyToClipboard[s], it doesn't work.




  1. Are there any other enhancements that would make the whole process more automated?


(A side note: it's been a while since I wrote this code, but if I remember correctly, I convert the image to black and white, figure out the background then use the pixels that were designated as background to figure out which pixels to set as transparent in the original image.)



Answer



Here are two functions that'll do what you need.


putClipboardImage[img_Image] := Module[{nb},
nb = CreateDocument[{}, Visible -> False, WindowSelected -> False];
NotebookWrite[nb,
Cell[BoxData@ToBoxes@Image[img, Magnification -> 1]]];
SelectionMove[nb, All, CellContents];

FrontEndTokenExecute[nb, "CopySpecial", "MGF"];
NotebookClose[nb]
]

getClipboardImage[] := Module[{tag},
Catch[NotebookGet@ClipboardNotebook[] /.
r_RasterBox :>
Block[{},
Throw[Image[First[r], "Byte", ColorSpace -> "RGB"], tag] /;
True];

$Failed, tag]
]

Warning: if the image is very small, this method will pad it with some wide pixels. It is copying the cell contents, not the image itself. If the image is small than the cell height, it'll get padded.


Copying


The reason the image can't be pasted to every program when using CopyToClipboard is that it is placed onto the clipboard as a metafile (as well as a Mathematica expression), but not as a bitmap.


My function works by writing the image into a new hidden notebook, then invoking the Edit -> Copy As -> Bitmap command programmatically, to ensure that the image is placed on the clipboard as a bitmap. This works on Windows, but on OS X it's probably necessary to change MGF to something else, as the same command is not available (try PDF). On Linux this functionality is simply not available.


Pasting


Pasting works by accessing the special object ClipboardNotebook[] and reading its contents. The unusual looking ReplaceAll - Throw - Catch construct is just a performance optimization to avoid unpacking the array representing the image data.


I used the same techniques in the image uploader palette.



Comments

Popular posts from this blog

front end - keyboard shortcut to invoke Insert new matrix

I frequently need to type in some matrices, and the menu command Insert > Table/Matrix > New... allows matrices with lines drawn between columns and rows, which is very helpful. I would like to make a keyboard shortcut for it, but cannot find the relevant frontend token command (4209405) for it. Since the FullForm[] and InputForm[] of matrices with lines drawn between rows and columns is the same as those without lines, it's hard to do this via 3rd party system-wide text expanders (e.g. autohotkey or atext on mac). How does one assign a keyboard shortcut for the menu item Insert > Table/Matrix > New... , preferably using only mathematica? Thanks! Answer In the MenuSetup.tr (for linux located in the $InstallationDirectory/SystemFiles/FrontEnd/TextResources/X/ directory), I changed the line MenuItem["&New...", "CreateGridBoxDialog"] to read MenuItem["&New...", "CreateGridBoxDialog", MenuKey["m", Modifiers-...

How to thread a list

I have data in format data = {{a1, a2}, {b1, b2}, {c1, c2}, {d1, d2}} Tableform: I want to thread it to : tdata = {{{a1, b1}, {a2, b2}}, {{a1, c1}, {a2, c2}}, {{a1, d1}, {a2, d2}}} Tableform: And I would like to do better then pseudofunction[n_] := Transpose[{data2[[1]], data2[[n]]}]; SetAttributes[pseudofunction, Listable]; Range[2, 4] // pseudofunction Here is my benchmark data, where data3 is normal sample of real data. data3 = Drop[ExcelWorkBook[[Column1 ;; Column4]], None, 1]; data2 = {a #, b #, c #, d #} & /@ Range[1, 10^5]; data = RandomReal[{0, 1}, {10^6, 4}]; Here is my benchmark code kptnw[list_] := Transpose[{Table[First@#, {Length@# - 1}], Rest@#}, {3, 1, 2}] &@list kptnw2[list_] := Transpose[{ConstantArray[First@#, Length@# - 1], Rest@#}, {3, 1, 2}] &@list OleksandrR[list_] := Flatten[Outer[List, List@First[list], Rest[list], 1], {{2}, {1, 4}}] paradox2[list_] := Partition[Riffle[list[[1]], #], 2] & /@ Drop[list, 1] RM[list_] := FoldList[Transpose[{First@li...

plotting - How to draw lines between specified dots on ListPlot?

I would like to create a plot where I have unconnected dots and some connected. So far, I have figured out how to draw the dots. My code is the following: ListPlot[{{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4,13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full] I have thought using ListLinePlot command, but I don't know how to specify to the command to draw only selected lines between the dots. Do have any suggestions/hints on how to do that? Thank you. Answer One possibility would be to use Epilog with Line : ListPlot[ {{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4, 13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full, Epilog -> { Line[ ...