二値画像の回転 : 第2回 オフラインリアルタイムどう書くの参考問題 http://qiita.com/items/9d80de41903775296ca6

Module.vb

Option Explicit

Sub test()
    Debug.Assert RotateBinImg("3:5b8") = "3:de0"
    Debug.Assert RotateBinImg("1:8") = "1:8"
    Debug.Assert RotateBinImg("2:8") = "2:4"
    Debug.Assert RotateBinImg("2:4") = "2:1"
    Debug.Assert RotateBinImg("2:1") = "2:2"
    Debug.Assert RotateBinImg("3:5d0") = "3:5d0"
    Debug.Assert RotateBinImg("4:1234") = "4:0865"
    Debug.Assert RotateBinImg("5:22a2a20") = "5:22a2a20"
    Debug.Assert RotateBinImg("5:1234567") = "5:25b0540"
    Debug.Assert RotateBinImg("6:123456789") = "6:09cc196a6"
    Debug.Assert RotateBinImg("7:123456789abcd") = "7:f1a206734b258"
    Debug.Assert RotateBinImg("7:fffffffffffff") = "7:ffffffffffff8"
    Debug.Assert RotateBinImg("7:fdfbf7efdfbf0") = "7:ffffffffffc00"
    Debug.Assert RotateBinImg("8:123456789abcdef1") = "8:f0ccaaff78665580"
    Debug.Assert RotateBinImg("9:112233445566778899aab") = "9:b23da9011d22daf005d40"
End Sub

Function RotateBinImg(ByVal Data As String) As String
    Dim Temp As Variant
    Dim SideLen As Long
    Dim Bin As String
    Dim BitCount As Long
    Dim BinImg() As Long
    Dim RotatedBinImg() As Long
    Dim u As Long
    Dim i As Long
    Dim Row As Long
    Dim Col As Long
    Dim BitList() As String
    Dim BinList() As String
    Dim Remainder As Long
    
    ' 入力文字列を分割
    Temp = Split(Data, ":")
    SideLen = CLng(Temp(0))
    Bin = Hex2Bin(Temp(1))
    BitCount = SideLen * SideLen

    ' 二値画像を作成
    u = SideLen - 1
    ReDim BinImg(u, u) As Long
    For i = 1 To BitCount
        Row = (i - 1) \ SideLen
        Col = (i - 1) Mod SideLen
        BinImg(Row, Col) = Mid$(Bin, i, 1)
    Next i
    
    ' 二値画像を時計回りに90度回転
    ReDim RotatedBinImg(u, u) As Long
    For Row = 0 To u
        For Col = 0 To u
            RotatedBinImg(Col, u - Row) = BinImg(Row, Col)
        Next Col
    Next Row

    ' 二値画像を1行に変換
    For Row = 0 To u
        Erase BitList
        For Col = 0 To u
            ReDim Preserve BitList(Col) As String
            BitList(Col) = RotatedBinImg(Row, Col)
        Next Col
        
        ReDim Preserve BinList(Row) As String
        BinList(Row) = Join(BitList, "")
    Next Row
    
    ' 2進数を16進数に変換するのに足りない0を補完
    Bin = Join(BinList, "")
    Remainder = Len(Bin) Mod 4
    If Remainder > 0 Then
        Bin = Bin & String(4 - Remainder, "0")
    End If

    ' 2進数を16進数に変換して返す
    RotateBinImg = CStr(SideLen) & ":" & LCase(Bin2Hex(Bin))
End Function

Function Dec2Hex(ByVal Dec As String) As String
    'Dec2Hex = Hex$(Dec)

    Dim Dec_ As Variant
    Dim Remainders() As Long
    Dim HexList() As String
    Dim Hex As String
    Dim q As Variant
    Dim i As Long
    Dim u As Long
    Dim n As Long
    
    Dec_ = CDec(Dec)
    i = -1
    Do
        'q = Dec_ \ 16 ' オーバーフロー
        q = Quotient(Dec_, 16) ' オーバーフロー
        i = i + 1
        ReDim Preserve Remainders(i) As Long
        ' Remainders(i) = Dec_ Mod 16
        Remainders(i) = Modular(Dec_, 16)
        If q = 0 Then
            Exit Do
        Else
            Dec_ = q
        End If
    Loop
    
    u = i
    ReDim HexList(u) As String

    For n = 0 To u
        Select Case Remainders(i)
            Case 0 To 9: Hex = CStr(Remainders(i))
            Case 10: Hex = "A"
            Case 11: Hex = "B"
            Case 12: Hex = "C"
            Case 13: Hex = "D"
            Case 14: Hex = "E"
            Case 15: Hex = "F"
        End Select
        HexList(n) = Hex
        i = i - 1
    Next n
    
    Dec2Hex = Join(HexList, "")
End Function

Function Bin2Dec(ByVal Bin As String) As String
    Dim Bit As Long
    Dim Sum As Variant
    Dim n As Long
    Dim i As Long
    Dim Base As Variant
    
    Sum = 0
    n = Len(Bin)
    For i = 1 To n
        Bit = Mid$(Bin, i, 1)
        
        ' 結果が正しくない
        ' 誤→正
        ' 2251799813685250→2251799813685248
        ' 1125899906842620→1125899906842624
        'Base = CDec(2 ^ (n - i))
        
        Base = Power(2, n - i)
        Sum = CDec(Sum + (Bit * Base))
    Next i
    
    Bin2Dec = CStr(Sum)
End Function

Function Bin2Hex(ByVal Bin As String) As String
    Dim Hex As String
    Dim HexLen As Long
    
    Hex = Dec2Hex(Bin2Dec(Bin))
    HexLen = Quotient(Len(Bin), 4)
    Bin2Hex = Right$(String(HexLen, "0") & Hex, HexLen)
End Function

Function Hex2Dec(ByVal Hex As String) As String
    'Hex2Dec = CStr(CDec("&H" & Hex))

    Dim Hex_ As String
    Dim Dec As Long
    Dim Sum As Variant
    Dim n As Long
    Dim i As Long
    Dim Base As Variant
    
    Sum = 0
    n = Len(Hex)
    For i = 1 To n
        Hex_ = Mid$(Hex, i, 1)
        Select Case StrConv(Hex_, vbUpperCase)
            Case "0" To "9": Dec = CLng(Hex_)
            Case "A": Dec = 10
            Case "B": Dec = 11
            Case "C": Dec = 12
            Case "D": Dec = 13
            Case "E": Dec = 14
            Case "F": Dec = 15
        End Select
        'Base = CDec(16 ^ (n - i))
        Base = Power(16, n - i)
        Sum = CDec(Sum + (Dec * Base))
    Next i
    
    Hex2Dec = CStr(Sum)
End Function

Function Dec2Bin(ByVal Dec As String) As String
    Dim Dec_ As Variant
    Dim Remainders() As Long
    Dim BitList() As String
    Dim q As Variant
    Dim i As Long
    Dim u As Long
    Dim n As Long
    
    Dec_ = CDec(Dec)
    i = -1
    Do
        'q = Dec_ \ 2 ' オーバーフロー
        q = Quotient(Dec_, 2)
        i = i + 1
        ReDim Preserve Remainders(i) As Long
        'Remainders(i) = Dec_ Mod 2 ' オーバーフロー
        Remainders(i) = Modular(Dec_, 2)
        If q = 0 Then
            Exit Do
        Else
            Dec_ = q
        End If
    Loop
    
    u = i
    ReDim BitList(u) As String

    For n = 0 To u
        BitList(n) = CStr(Remainders(i))
        i = i - 1
    Next n
    
    Dec2Bin = Join(BitList, "")
End Function

Function Hex2Bin(ByVal Hex As String) As String
    Dim BinList() As String
    Dim Dec As String
    Dim Bin As String
    Dim n As Long
    Dim i As Long
    
    n = Len(Hex)
    For i = 1 To n
        ReDim Preserve BinList(i - 1) As String
        Dec = Hex2Dec(Mid$(Hex, i, 1))
        Bin = Format$(Dec2Bin(Dec), "0000")
        BinList(i - 1) = Bin
    Next i
    
    Hex2Bin = Join(BinList, "")
End Function

Function Quotient(ByVal Dividend, ByVal Divisor) As Variant
    'Quotient = Dividend \ Divisor
    Quotient = CDec(Fix(Dividend / Divisor))
End Function

Function Modular(ByVal Dividend, ByVal Divisor) As Variant
    'Modular = Dividend Mod Divisor
    Modular = Dividend - Quotient(Dividend, Divisor) * Divisor
End Function

Function Power(ByVal Base As Long, ByVal Exponent As Long)
    If Exponent < 0 Then
        Err.Raise 5
    End If
    Power = Power_(Base, Exponent)
End Function

Private Function Power_(ByVal Base As Long, ByVal Exponent As Long)
    'Power = Base ^ Exponent
    Dim Sum As Variant
    If Exponent = 0 Then
        Sum = 1
    Else
        Sum = Base * CDec(Power_(Base, Exponent - 1))
    End If
    Power_ = Sum
End Function