クリップボードにBitmap形式で保存できない不具合の修正。

src/QRCodeLib/BitConverter.bas

@@ -23,9 +23,9 @@ Public Function GetBytes(ByVal arg As Variant, Optional ByVal reverse As Boolean
         Case VbVarType.vbLong
             ReDim ret(3)
             ret(0) = arg And &HFF&
-            ret(1) = (arg And &HFF00&) \ 2 ^ 8
-            ret(2) = (arg And &HFF0000) \ 2 ^ 16
-            ret(3) = (arg And &HFF000000) \ 2 ^ 24 And &HFF&
+            ret(1) = (arg And &HFF00&) \ 2 ^ (8 * 1)
+            ret(2) = (arg And &HFF0000) \ 2 ^ (8 * 2)
+            ret(3) = (arg And &HFF000000) \ 2 ^ (8 * 3) And &HFF&
 
             If reverse Then
                 temp = ret(0)
@@ -36,6 +36,36 @@ Public Function GetBytes(ByVal arg As Variant, Optional ByVal reverse As Boolean
                 ret(1) = ret(2)
                 ret(2) = temp
             End If
+#If Win64 Then
+        Case VbVarType.vbLongLong
+            ReDim ret(7)
+            ret(0) = arg And &HFF&
+            ret(1) = (arg And &HFF00&) \ 2 ^ (8 * 1)
+            ret(2) = (arg And &HFF0000) \ 2 ^ (8 * 2)
+            ret(3) = (arg And &HFF000000^) \ 2 ^ (8 * 3)
+            ret(4) = (arg And &HFF00000000^) \ 2 ^ (8 * 4)
+            ret(5) = (arg And &HFF0000000000^) \ 2 ^ (8 * 5)
+            ret(6) = (arg And &HFF000000000000^) \ 2 ^ (8 * 6)
+            ret(7) = (arg And &HFF00000000000000^) \ 2 ^ (8 * 7) And &HFF&
+
+            If reverse Then
+                temp = ret(0)
+                ret(0) = ret(7)
+                ret(7) = temp
+
+                temp = ret(1)
+                ret(1) = ret(6)
+                ret(6) = temp
+
+                temp = ret(2)
+                ret(2) = ret(5)
+                ret(5) = temp
+
+                temp = ret(3)
+                ret(3) = ret(4)
+                ret(4) = temp
+            End If
+#End If
         Case Else
             Call Err.Raise(5)
     End Select

src/QRCodeLib/ByteSequence.cls

@@ -0,0 +1,76 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "ByteSequence"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+Option Explicit
+
+Private Const adTypeBinary As Long = 1
+Private Const adModeReadWrite As Long = 3
+
+Private m_buf As Object
+
+Private Sub Class_Initialize()
+    Call Init
+End Sub
+
+Public Sub Init()
+    Set m_buf = CreateObject("ADODB.Stream")
+    m_buf.Mode = adModeReadWrite
+    m_buf.Type = adTypeBinary
+    Call m_buf.Open
+End Sub
+
+Public Sub Append(ByRef arg As Variant, Optional ByVal reverse As Boolean = False)
+    Dim t As VbVarType
+    t = VarType(arg)
+
+    Dim i As Long
+    Dim j As Long
+    Dim bytes() As Byte
+
+    If (t And VbVarType.vbArray) = VbVarType.vbArray Then
+        Select Case t - VbVarType.vbArray
+            Case VbVarType.vbByte
+                Call m_buf.Write(arg)
+            Case VbVarType.vbInteger, VbVarType.vbLong
+                For i = 0 To UBound(arg)
+                    bytes = BitConverter.GetBytes(arg(i), reverse)
+                    Call m_buf.Write(bytes)
+                Next
+#If Win64 Then
+            Case VbVarType.vbLongLong
+                For i = 0 To UBound(arg)
+                    bytes = BitConverter.GetBytes(arg(i), reverse)
+                    Call m_buf.Write(bytes)
+                Next
+#End If
+            Case Else
+                Call Err.Raise(5)
+        End Select
+    Else
+        Select Case VarType(arg)
+            Case VbVarType.vbByte, VbVarType.vbInteger, VbVarType.vbLong
+                bytes = BitConverter.GetBytes(arg, reverse)
+                Call m_buf.Write(bytes)
+#If Win64 Then
+            Case VbVarType.vbLongLong
+                bytes = BitConverter.GetBytes(arg, reverse)
+                Call m_buf.Write(bytes)
+#End If
+            Case Else
+                Call Err.Raise(5)
+        End Select
+    End If
+End Sub
+
+Public Function Flush() As Byte()
+    m_buf.Position = 0
+    Flush = m_buf.Read()
+    Call m_buf.Close
+    Call Init
+End Function

src/QRCodeLib/ClipboardUtil.bas

@@ -29,7 +29,7 @@ Private Const GHND          As Long = GMEM_MOVEABLE Or GMEM_ZEROINIT
 Private Const CF_DIB         As Long = 8
 Private Const CF_ENHMETAFILE As Long = 14
 
-Public Sub SetDIB(ByRef dibData() As Byte)
+Public Sub SetDib(ByRef dibData() As Byte)
     Dim sz As Long
     sz = UBound(dibData) - 14 + 1
 
@@ -61,9 +61,9 @@ Public Sub SetDIB(ByRef dibData() As Byte)
 End Sub
 
 #If VBA7 Then
-Public Sub SetEMF(ByVal hEmf As LongPtr)
+Public Sub SetEmf(ByVal hEmf As LongPtr)
 #Else
-Public Sub SetEMF(ByVal hEmf As Long)
+Public Sub SetEmf(ByVal hEmf As Long)
 #End If
     Call OpenClipboard(0)
     Call EmptyClipboard

src/QRCodeLib/CRC32.bas → src/QRCodeLib/Crc32.bas

@@ -1,4 +1,4 @@
-Attribute VB_Name = "CRC32"
+Attribute VB_Name = "Crc32"
 Option Private Module
 Option Explicit
 

src/QRCodeLib/DIB.bas → src/QRCodeLib/Dib.bas

@@ -1,4 +1,4 @@
-Attribute VB_Name = "DIB"
+Attribute VB_Name = "Dib"
 Option Private Module
 Option Explicit
 
@@ -34,7 +34,7 @@ Private Type RgbQuad
     rgbReserved As Byte
 End Type
 
-Public Function GetDIB(ByRef bitmapData() As Byte, _
+Public Function GetDib(ByRef bitmapData() As Byte, _
                        ByVal pictWidth As Long, _
                        ByVal pictHeight As Long, _
                        ByVal foreColorRgb As Long, _
@@ -97,63 +97,42 @@ Public Function GetDIB(ByRef bitmapData() As Byte, _
         .biClrImportant = 0
     End With
 
-    Dim ret() As Byte
-    ReDim ret(bfOffBits + UBound(bitmapData))
-
-    Dim idx As Long
-    idx = 0
+    Dim bs As New ByteSequence
 
     With bfh
-        bytes = BitConverter.GetBytes(.bfType)
-        idx = ArrayUtil.CopyAll(ret, idx, bytes)
-        bytes = BitConverter.GetBytes(.bfSize)
-        idx = ArrayUtil.CopyAll(ret, idx, bytes)
-        bytes = BitConverter.GetBytes(.bfReserved1)
-        idx = ArrayUtil.CopyAll(ret, idx, bytes)
-        bytes = BitConverter.GetBytes(.bfReserved2)
-        idx = ArrayUtil.CopyAll(ret, idx, bytes)
-        bytes = BitConverter.GetBytes(.bfOffBits)
-        idx = ArrayUtil.CopyAll(ret, idx, bytes)
+        Call bs.Append(.bfType)
+        Call bs.Append(.bfSize)
+        Call bs.Append(.bfReserved1)
+        Call bs.Append(.bfReserved2)
+        Call bs.Append(.bfOffBits)
     End With
 
     With bih
-        bytes = BitConverter.GetBytes(.biSize)
-        idx = ArrayUtil.CopyAll(ret, idx, bytes)
-        bytes = BitConverter.GetBytes(.biWidth)
-        idx = ArrayUtil.CopyAll(ret, idx, bytes)
-        bytes = BitConverter.GetBytes(.biHeight)
-        idx = ArrayUtil.CopyAll(ret, idx, bytes)
-        bytes = BitConverter.GetBytes(.biPlanes)
-        idx = ArrayUtil.CopyAll(ret, idx, bytes)
-        bytes = BitConverter.GetBytes(.biBitCount)
-        idx = ArrayUtil.CopyAll(ret, idx, bytes)
-        bytes = BitConverter.GetBytes(.biCompression)
-        idx = ArrayUtil.CopyAll(ret, idx, bytes)
-        bytes = BitConverter.GetBytes(.biSizeImage)
-        idx = ArrayUtil.CopyAll(ret, idx, bytes)
-        bytes = BitConverter.GetBytes(.biXPelsPerMeter)
-        idx = ArrayUtil.CopyAll(ret, idx, bytes)
-        bytes = BitConverter.GetBytes(.biYPelsPerMeter)
-        idx = ArrayUtil.CopyAll(ret, idx, bytes)
-        bytes = BitConverter.GetBytes(.biClrUsed)
-        idx = ArrayUtil.CopyAll(ret, idx, bytes)
-        bytes = BitConverter.GetBytes(.biClrImportant)
-        idx = ArrayUtil.CopyAll(ret, idx, bytes)
+        Call bs.Append(.biSize)
+        Call bs.Append(.biWidth)
+        Call bs.Append(.biHeight)
+        Call bs.Append(.biPlanes)
+        Call bs.Append(.biBitCount)
+        Call bs.Append(.biCompression)
+        Call bs.Append(.biSizeImage)
+        Call bs.Append(.biXPelsPerMeter)
+        Call bs.Append(.biYPelsPerMeter)
+        Call bs.Append(.biClrUsed)
+        Call bs.Append(.biClrImportant)
     End With
 
     Dim i As Long
 
     If monochrome Then
         For i = 0 To UBound(palette)
-            ret(idx + 0) = palette(i).rgbBlue
-            ret(idx + 1) = palette(i).rgbGreen
-            ret(idx + 2) = palette(i).rgbRed
-            ret(idx + 3) = palette(i).rgbReserved
-            idx = idx + 4
+            Call bs.Append(palette(i).rgbBlue)
+            Call bs.Append(palette(i).rgbGreen)
+            Call bs.Append(palette(i).rgbRed)
+            Call bs.Append(palette(i).rgbReserved)
         Next
     End If
 
-    Call ArrayUtil.CopyAll(ret, idx, bitmapData)
+    Call bs.Append(bitmapData)
 
-    GetDIB = ret
+    GetDib = bs.Flush()
 End Function

src/QRCodeLib/EMF.bas → src/QRCodeLib/Emf.bas

@@ -1,4 +1,4 @@
-Attribute VB_Name = "EMF"
+Attribute VB_Name = "Emf"
 Option Private Module
 Option Explicit
 
@@ -78,12 +78,12 @@ Private Const HORZRES  As Long = 8
 Private Const VERTRES  As Long = 10
 
 #If VBA7 Then
-Public Function GetEMF(ByRef data() As Variant, _
+Public Function GetEmf(ByRef data() As Variant, _
                        ByVal pictWidth As Long, _
                        ByVal pictHeight As Long, _
                        ByVal foreColorRgb As Long) As LongPtr
 #Else
-Public Function GetEMF(ByRef data() As Variant, _
+Public Function GetEmf(ByRef data() As Variant, _
                        ByVal pictWidth As Long, _
                        ByVal pictHeight As Long, _
                        ByVal foreColorRgb As Long) As Long
@@ -113,7 +113,7 @@ Public Function GetEMF(ByRef data() As Variant, _
 
     Call DrawAndFillPath(foreColorRgb, foreColorRgb, hDC)
 
-    GetEMF = CloseEnhMetaFile(hDC)
+    GetEmf = CloseEnhMetaFile(hDC)
 End Function
 
 Private Function GetPixelSize() As Size

src/QRCodeLib/Enums.cls

@@ -17,12 +17,12 @@ Public Enum ErrorCorrectionLevel
 End Enum
 
 Public Enum ImageFormat
-    fmtBMP = &H10
-    fmtPNG = &H20
-    fmtSVG = &H30
-    fmtEMF = &H40
-    fmtTIFF = &H50
-    fmtGIF = &H60
+    fmtBmp = &H10
+    fmtPng = &H20
+    fmtSvg = &H30
+    fmtEmf = &H40
+    fmtTiff = &H50
+    fmtGif = &H60
     fmtMonochrome = 0
     fmtTrueColor = 1
     fmtBilevel = 2