I guess a story-telling type post would attract more upvotes and probably give some insight about how to 'solve problems' using Mathematica, so I would go into details and try to explain not only the code but also how I figured out how to write them.

To begin with, here's three QR code generated with the code, check it by yourself, they are actually scan-able~ It's also amazing that even very fine details of the image can be shown in the QR code (Note that it would better if you view these QR with your glass off XD)

How this works?

In fact, this form of QR code is not my original idea, I came across such type of QR code on internet but failed to find its origin. So I tried to figure out the principle by myself.

Carefully observe the image, one can find out that there's something odd about this QR:

The marker on the corner are three times coarser than the majority of the QR. So I initially hypothesize that the QR recognition algorithm would first average the brightness of a segment, turning it into a normal QR and then recognize it. The code I used is as follows:

Block[{img = Import["http://community.wolfram.com//c/portal/getImageAttachment?filename=mathematica1.png&userId=1340903"], dat, partitioned},
 dat = ImageData@ImagePad[Binarize[ImageResize[img, Scaled[1/3]]], -4];
 partitioned = Partition[dat, {3, 3}];
 Grid[{ImageResize[#, Dimensions@dat], BarcodeRecognize@#} & /@ 
    {Image@dat,Binarize@Image@Map[Mean@*Flatten, partitioned, {2}]}]
 ]

The result proved me wrong as the averaged version cannot be properly recognized. Then further observer the QR code, I found that there are mysterious dots even in the places which should be purely white, also the dots are a bit too structural. So I suspect that normal QR code recognition algorithm only takes the color of the center dot, so I added this to the previous code:

Map[#[[2,2]]&,partitioned,{2}]

then it worked out properly!

As we've already cracked the theory, we can now generate some of our own.

How to generate?

QR code generation

First we can use BarcodeImage to generate a QR code, for example here I would use: "This is a sample QR generated by Mathematica!" as the content of the QR code:

text = "This is a sample QR generated by Mathematica!";
qrraw = BarcodeImage[text, {"QR", "H"}, 1]
BarcodeRecognize@qrraw

Image processing

Then we create a black and white image to use as background, for example here we use the wolfram wolf icon:

Import, convert to grayscale and adjust the grayscale a bit:

img=ColorConvert[Rasterize[Graphics[{
  Inset[Import["http://community.wolfram.com//c/portal/getImageAttachment?filename=wolframwolf.png&userId=1340903"],{.6,.4},Automatic,.8],
  Text[Style["WOLFRAM",Bold,14],{.5,.92}]
},PlotRange->{{0,1},{0,1}},ImageSize->3ImageDimensions@qrraw]],"Grayscale"]^.45

which returns:

Note that in order to get enough resolution while keeping the QR code easy to scan, the dimension of the QR code is best in the range of [25,50], one can test that using ImageDimensions@img and adjust it by changing the error correction level by setting {"QR",lev} where lev can be "L", "M", "Q", or "H".

Merging

Then we should merge this two image together. Here we use the technique of dither to display grayscale image using only white and black pixels. In the process of dithering, we should notice that at center of each 9*9 pixel the value should correspond to the value in the QR image, or the QR code would be invalid. The code could be easily written out as follows:

dithering[imgdat_, qrdat_] := 
 Block[{imgdat1 = imgdat, dimx, dimy, tmp1, tmp2, f = UnitStep[# - .5] &},
  {dimx, dimy} = Dimensions@imgdat;
  Quiet@Do[
    (*Rounding*)
    tmp1 = If[Mod[{i, j}, 3] == {2, 2}, qrdat[[(i + 1)/3, (j + 1)/3]], f[imgdat1[[i, j]]]];
    tmp2 = Clip[imgdat1[[i, j]] - tmp1, {-.5, .5}];
    (*Diffuse Error*)
    imgdat1[[i, j]] = tmp1;
    imgdat1[[i, j + 1]] += 0.4375 tmp2;
    If[j != 1, imgdat1[[i + 1, j - 1]] += 0.1875 tmp2];
    imgdat1[[i + 1, j]] += 0.3125 tmp2;
    imgdat1[[i + 1, j + 1]] += 0.0625 tmp2
    , {i, dimx}, {j, dimy}];
  imgdat1
  ]

Special attention should be paid to the handling key pixels of the QR code, the error created by introducing it should not be ignored, but its influence should be limited in a range, so here a Clip in error is required, while in a traditional dithering process it would be redundant.

Apply dithering to the image and we have:

Image[ditherdat=dithering[ImageData@img, ImageData@qrraw]]

Refinement

One can see that the shape of the original image is quite well preserved and key points of the QR code are properly dealt with. Then the final step is to process the key features on the corner and edge of the QR code, which is quite trivial:

replicate = (Flatten[ConstantArray[#, {3, 3}], {{3, 1}, {4, 2}}] &);

refineqr[qrdat_] := 
 Block[{qrd = qrdat, d = Length[qrdat]},
  (*Corner*)
  (qrd[[#1 ;; 24 #1 ;; #1, #2 ;; 24 #2 ;; #2]] = replicate[qrd[[2 #1 ;; 23 #1 ;; 3 #1, 2 #2 ;; 23 #2 ;; 3 #2]]]) & @@@ {{1, 1}, {1, -1}, {-1, 1}};
  (*Edge*)
  qrd[[22 ;; d - 21, 19 ;; 21]] = Transpose[qrd[[19 ;; 21, 22 ;; d - 21]] = replicate[{Mod[Range[(d + 1)/3 - 14], 2]}]];
  qrd]

Then apply this to previously get result, we get the final result, which is scan-able:

Image[final = refineqr@ditherdat]
BarcodeRecognize@%

It's usually favourable to have a 3x zoom to the image:

Image@replicate@final

A fully packed version is shown in the attachment notebook file, where:

createqr[text,img]

would generate the same result.

Further optimizations could include using machine learning to further refine the display effect. Sharper lines, Less interfering key points and more could be expected.

ENJOY~

Update

@Henrik Schachner kindly remind me that the previous QR is not that easy to scan with average QR scanning software. So I made some tiny updates to make the QR more standardized and much more easier to scan:

refineqr[qrdat_] := 
 Block[{qrd = qrdat, d = Length[qrdat], temp = Fold[ArrayPad[#1, 1, #2] &, {{{0}}, 1, 0}], p},
  p = Position[Round@ListCorrelate[temp, qrdat[[2 ;; ;; 3, 2 ;; ;; 3]], {{1, 1}, {-1, -1}}, 0, Abs@*Subtract], 0, 2];
  (*Corner*)
  (qrd[[#1 ;; 24 #1 ;; #1, #2 ;; 24 #2 ;; #2]] = replicate[qrd[[2 #1 ;; 23 #1 ;; 3 #1, 2 #2 ;; 23 #2 ;; 3 #2]]]) & @@@ {{1, 1}, {1, -1}, {-1, 1}};
  (*Edge*)
  qrd[[22 ;; d - 21, 19 ;; 21]] = Transpose[ qrd[[19 ;; 21, 22 ;; d - 21]] = replicate[{Mod[Range[(d + 1)/3 - 14], 2]}]];
  (*Special*)
  (qrd[[3 #1 - 2 ;; 3 #1 + 12, 3 #2 - 2 ;; 3 #2 + 12]] = replicate@temp) & @@@ p;
  qrd]

after this update, the QR code would look like this:

After minor manual edition, it could be like:

Maybe this would be easier to scan due to the newly add correction block on the right-down corner.

Also, I think I found a better realization using same basic design principle here.

Attachments: