Skip to content

Commit

Permalink
パフォーマンス改善
Browse files Browse the repository at this point in the history 
Wordで使用した場合に、MoveMemory API関数のレスポンスが悪いため、当該関数を極力使用しないように変更した。
  • Loading branch information
@yas78
yas78 committed Jan 9, 2022
1 parent c4d8095 commit 1766afe
Show file tree
Hide file tree
Showing 11 changed files with 215 additions and 132 deletions.
Binary file modified bin/QRCodeLib.xlam
View file
Binary file not shown.
Binary file modified bin/QRCodeLibDemo.xlsm
View file
Binary file not shown.
Binary file modified bin/WorksheetFunctionSample.xlsm
View file
Binary file not shown.
11 changes: 11 additions & 0 deletions src/QRCodeLib/ArrayUtil.bas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,17 @@ Attribute VB_Name = "ArrayUtil"
Option Private Module
Option Explicit

Public Sub Copy(ByRef dest() As Byte, ByVal destIdx As Long, ByRef src() As Byte, ByVal srcIdx As Long, sz As Long)
Dim idx As Long
idx = destIdx

Dim i As Long
For i = 0 To sz - 1
dest(idx) = src(srcIdx + i)
idx = idx + 1
Next
End Sub

Public Function Rotate90(ByRef array2D() As Variant) As Variant()
Dim ret() As Variant
ReDim ret(UBound(array2D(0)))
Expand Down
73 changes: 59 additions & 14 deletions src/QRCodeLib/DIB.bas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,12 +2,6 @@ Attribute VB_Name = "DIB"
Option Private Module
Option Explicit

#If VBA7 Then
Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal pDest As LongPtr, ByVal pSrc As LongPtr, ByVal sz As Long)
#Else
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal pDest As Long, ByVal pSrc As Long, ByVal sz As Long)
#End If

Private Const BF_SIZE As Long = 14
Private Const BI_SIZE As Long = 40

Expand Down Expand Up @@ -101,26 +95,77 @@ Public Function GetDIB(ByRef bitmapData() As Byte, _
Dim ret() As Byte
ReDim ret(bfOffBits + UBound(bitmapData))

Dim bytes() As Byte
Dim idx As Long
idx = 0

With bfh
Call MoveMemory(VarPtr(ret(0)), VarPtr(.bfType), 2)
Call MoveMemory(VarPtr(ret(2)), VarPtr(.bfSize), 4)
Call MoveMemory(VarPtr(ret(6)), VarPtr(.bfReserved1), 8)
bytes = BitConverter.GetBytes(.bfType)
Call ArrayUtil.Copy(ret, idx, bytes, 0, 2)
idx = idx + 2
bytes = BitConverter.GetBytes(.bfSize)
Call ArrayUtil.Copy(ret, idx, bytes, 0, 4)
idx = idx + 4
bytes = BitConverter.GetBytes(.bfReserved1)
Call ArrayUtil.Copy(ret, idx, bytes, 0, 2)
idx = idx + 2
bytes = BitConverter.GetBytes(.bfReserved2)
Call ArrayUtil.Copy(ret, idx, bytes, 0, 2)
idx = idx + 2
bytes = BitConverter.GetBytes(.bfOffBits)
Call ArrayUtil.Copy(ret, idx, bytes, 0, 4)
idx = idx + 4
End With

Call MoveMemory(VarPtr(ret(14)), VarPtr(bih.biSize), 40)
With bih
bytes = BitConverter.GetBytes(.biSize)
Call ArrayUtil.Copy(ret, idx, bytes, 0, 4)
idx = idx + 4
bytes = BitConverter.GetBytes(.biWidth)
Call ArrayUtil.Copy(ret, idx, bytes, 0, 4)
idx = idx + 4
bytes = BitConverter.GetBytes(.biHeight)
Call ArrayUtil.Copy(ret, idx, bytes, 0, 4)
idx = idx + 4
bytes = BitConverter.GetBytes(.biPlanes)
Call ArrayUtil.Copy(ret, idx, bytes, 0, 2)
idx = idx + 2
bytes = BitConverter.GetBytes(.biBitCount)
Call ArrayUtil.Copy(ret, idx, bytes, 0, 2)
idx = idx + 2
bytes = BitConverter.GetBytes(.biCompression)
Call ArrayUtil.Copy(ret, idx, bytes, 0, 4)
idx = idx + 4
bytes = BitConverter.GetBytes(.biSizeImage)
Call ArrayUtil.Copy(ret, idx, bytes, 0, 4)
idx = idx + 4
bytes = BitConverter.GetBytes(.biXPelsPerMeter)
Call ArrayUtil.Copy(ret, idx, bytes, 0, 4)
idx = idx + 4
bytes = BitConverter.GetBytes(.biYPelsPerMeter)
Call ArrayUtil.Copy(ret, idx, bytes, 0, 4)
idx = idx + 4
bytes = BitConverter.GetBytes(.biClrUsed)
Call ArrayUtil.Copy(ret, idx, bytes, 0, 4)
idx = idx + 4
bytes = BitConverter.GetBytes(.biClrImportant)
Call ArrayUtil.Copy(ret, idx, bytes, 0, 4)
idx = idx + 4
End With

Dim idx As Long
idx = BF_SIZE + BI_SIZE
Dim i As Long

If monochrome Then
For i = 0 To UBound(palette)
Call MoveMemory(VarPtr(ret(idx)), VarPtr(palette(i)), 4)
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
Next
End If

Call MoveMemory(VarPtr(ret(idx)), VarPtr(bitmapData(0)), UBound(bitmapData) + 1)
Call ArrayUtil.Copy(ret, idx, bitmapData, 0, UBound(bitmapData) + 1)

GetDIB = ret
End Function
22 changes: 2 additions & 20 deletions src/QRCodeLib/Deflate.bas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,12 +2,6 @@ Attribute VB_Name = "Deflate"
Option Private Module
Option Explicit

#If VBA7 Then
Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal pDest As LongPtr, ByVal pSrc As LongPtr, ByVal sz As Long)
#Else
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal pDest As Long, ByVal pSrc As Long, ByVal sz As Long)
#End If

Public Enum DeflateBType
NoCompression = 0
CompressedWithFixedHuffmanCodes = 1
Expand Down Expand Up @@ -36,14 +30,6 @@ Public Sub Compress(ByRef data() As Byte, ByVal btype As DeflateBType, ByRef buf

ReDim buffer(bufferSize - 1)

#If VBA7 Then
Dim srcPtr As LongPtr
Dim dstPtr As LongPtr
#Else
Dim srcPtr As Long
Dim dstPtr As Long
#End If

Dim bfinal As Long
Dim dLen As Long
Dim dNLen As Long
Expand Down Expand Up @@ -71,9 +57,7 @@ Public Sub Compress(ByRef data() As Byte, ByVal btype As DeflateBType, ByRef buf
buffer(idx + 1) = temp(1)
idx = idx + 2

srcPtr = VarPtr(data(&HFFFF& * i))
dstPtr = VarPtr(buffer(idx))
Call MoveMemory(dstPtr, srcPtr, &HFFFF&)
Call ArrayUtil.Copy(buffer, idx, data, &HFFFF& * i, &HFFFF&)
idx = idx + &HFFFF&
Next

Expand All @@ -94,9 +78,7 @@ Public Sub Compress(ByRef data() As Byte, ByVal btype As DeflateBType, ByRef buf
buffer(idx + 1) = temp(1)
idx = idx + 2

srcPtr = VarPtr(data(&HFFFF& * quotient))
dstPtr = VarPtr(buffer(idx))
Call MoveMemory(dstPtr, srcPtr, remainder)
Call ArrayUtil.Copy(buffer, idx, data, &HFFFF& * quotient, remainder)
idx = idx + remainder
End If
End Sub
78 changes: 53 additions & 25 deletions src/QRCodeLib/GIF.bas
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,12 +2,6 @@ Attribute VB_Name = "GIF"
Option Private Module
Option Explicit

#If VBA7 Then
Private Declare PtrSafe Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal pDest As LongPtr, ByVal pSrc As LongPtr, ByVal sz As Long)
#Else
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal pDest As Long, ByVal pSrc As Long, ByVal sz As Long)
#End If

Private Type GifHeader
ExtensionIntroducer() As Byte
Version() As Byte
Expand Down Expand Up @@ -213,15 +207,15 @@ Private Sub MakeImageBlocks( _
With imgBlocks(i)
.Size = &HFE&
ReDim .BlockData(&HFE& - 1)
Call MoveMemory(VarPtr(.BlockData(0)), VarPtr(compressedData(&HFE& * i)), &HFE&)
Call ArrayUtil.Copy(.BlockData, 0, compressedData, &HFE& * i, &HFE&)
End With
Next

If remainder > 0 Then
With imgBlocks(quotient)
.Size = remainder
ReDim .BlockData(remainder - 1)
Call MoveMemory(VarPtr(.BlockData(0)), VarPtr(compressedData(&HFE& * quotient)), remainder)
Call ArrayUtil.Copy(.BlockData, 0, compressedData, &HFE& * quotient, remainder)
End With
End If

Expand Down Expand Up @@ -392,50 +386,84 @@ Private Sub ToBytes( _
idx = 0

With hdr
Call MoveMemory(VarPtr(buffer(idx)), VarPtr(.ExtensionIntroducer(0)), 3)
Call ArrayUtil.Copy(buffer, idx, .ExtensionIntroducer, 0, 3)
idx = idx + 3
Call MoveMemory(VarPtr(buffer(idx)), VarPtr(.Version(0)), 3)
Call ArrayUtil.Copy(buffer, idx, .Version, 0, 3)
idx = idx + 3
End With

Call MoveMemory(VarPtr(buffer(idx)), VarPtr(lsDesc), lsDescSize)
idx = idx + lsDescSize
Dim bytes() As Byte

With lsDesc
bytes = BitConverter.GetBytes(.LogicalScreenWidth)
Call ArrayUtil.Copy(buffer, idx, bytes, 0, 2)
idx = idx + 2
bytes = BitConverter.GetBytes(.LogicalScreenHeight)
Call ArrayUtil.Copy(buffer, idx, bytes, 0, 2)
idx = idx + 2
buffer(idx) = .PackedFields
idx = idx + 1
buffer(idx) = .BackgroundColorIndex
idx = idx + 1
buffer(idx) = .PixelAspectRatio
idx = idx + 1
End With

Call MoveMemory(VarPtr(buffer(idx)), VarPtr(gcTable(0)), gcTableSize)
Call ArrayUtil.Copy(buffer, idx, gcTable, 0, gcTableSize)
idx = idx + gcTableSize

If (gcExt.PackedFields And 1) > 0 Then
Call MoveMemory(VarPtr(buffer(idx)), VarPtr(gcExt.ExtensionIntroducer), gcExtSize)
idx = idx + gcExtSize
With gcExt
buffer(idx) = .ExtensionIntroducer
idx = idx + 1
buffer(idx) = .GraphicControlLabel
idx = idx + 1
buffer(idx) = .BlockSize
idx = idx + 1
buffer(idx) = .PackedFields
idx = idx + 1
bytes = BitConverter.GetBytes(.DelayTime)
Call ArrayUtil.Copy(buffer, idx, bytes, 0, 2)
idx = idx + 2
buffer(idx) = .TransparentColorIndex
idx = idx + 1
buffer(idx) = .BlockTerminator
idx = idx + 1
End With
End If

With imgDesc
Call MoveMemory(VarPtr(buffer(idx)), VarPtr(.ImageSeparator), 1)
buffer(idx) = .ImageSeparator
idx = idx + 1
Call MoveMemory(VarPtr(buffer(idx)), VarPtr(.ImageLeftPosition), 2)
bytes = BitConverter.GetBytes(.ImageLeftPosition)
Call ArrayUtil.Copy(buffer, idx, bytes, 0, 2)
idx = idx + 2
Call MoveMemory(VarPtr(buffer(idx)), VarPtr(.ImageTopPosition), 2)
bytes = BitConverter.GetBytes(.ImageTopPosition)
Call ArrayUtil.Copy(buffer, idx, bytes, 0, 2)
idx = idx + 2
Call MoveMemory(VarPtr(buffer(idx)), VarPtr(.ImageWidth), 2)
bytes = BitConverter.GetBytes(.ImageWidth)
Call ArrayUtil.Copy(buffer, idx, bytes, 0, 2)
idx = idx + 2
Call MoveMemory(VarPtr(buffer(idx)), VarPtr(.ImageHeight), 2)
bytes = BitConverter.GetBytes(.ImageHeight)
Call ArrayUtil.Copy(buffer, idx, bytes, 0, 2)
idx = idx + 2
Call MoveMemory(VarPtr(buffer(idx)), VarPtr(.PackedFields), 1)
buffer(idx) = .PackedFields
idx = idx + 1
Call MoveMemory(VarPtr(buffer(idx)), VarPtr(.LZWMinimumCodeSize), 1)
buffer(idx) = .LZWMinimumCodeSize
idx = idx + 1
End With

For i = 0 To UBound(imgBlocks)
With imgBlocks(i)
Call MoveMemory(VarPtr(buffer(idx)), VarPtr(.Size), 1)
buffer(idx) = .Size
idx = idx + 1

If .Size > 0 Then
Call MoveMemory(VarPtr(buffer(idx)), VarPtr(.BlockData(0)), UBound(.BlockData) + 1)
Call ArrayUtil.Copy(buffer, idx, .BlockData, 0, UBound(.BlockData) + 1)
idx = idx + UBound(.BlockData) + 1
End If
End With
Next

Call MoveMemory(VarPtr(buffer(idx)), VarPtr(trailer), trSize)
buffer(idx) = trailer
End Sub
Loading

0 comments on commit 1766afe

Please sign in to comment.