Sub Pattern_Copy()
   Dim row As Integer
   Dim col As Integer
    Dim md As Integer
    md = Worksheets("16dot").Range("AI28").Value
   For row = 0 To 15
     For col = 0 To 15
       If Cells(5 + row, 10 + col) = " " Then
            Select Case md
                Case 0, 2
                    Cells(5 + row, 35 + col) = ""
            End Select
       Else
            Select Case md
                Case 0, 1
                    Cells(5 + row, 35 + col) = "●"
                Case 3
                    If Cells(5 + row, 35 + col) = "" Then
                         Cells(5 + row, 35 + col) = "●"
                    Else
                         Cells(5 + row, 35 + col) = ""
                    End If
            End Select
       End If
     Next col
    Next row
End Sub
Sub BDF_Copy()
    Dim row As Integer
    For row = 0 To 15
        Cells(5 + row, 2) = Cells(5 + row, 51)
    Next
End Sub
Sub findPtn()
    Dim ws As Worksheet
    Set ws = Worksheets(Worksheets.Count)
    Dim code As Variant
    code = Worksheets("16dot").Range("B23").Value
    RowSize = Worksheets("16dot").Range("E2")
    CorSize = Worksheets("16dot").Range("C2")
    Dim i As Integer
    Dim j As Integer
    Dim m As Integer
    Dim b As Integer
    Dim r As Range
    Dim c As Variant
    Dim h As Variant
    Dim rOfs As Integer
    Dim rStr As Variant
    If CorSize = 16 Then        ' 16dot
        rStr = "AH:AH"
        rOfs = -33
    ElseIf CorSize = 8 Then
        rStr = "R:R"
        rOfs = -18
    Else
        rStr = "A:A"
        rOfs = 0
    End If
    With ws.Range(rStr)
        Worksheets("16dot").Range("C1").Value = ws.Name
        Set r = .Find(what:=code, LookAt:=xlWhole)
        Do
            If r Is Nothing Then
                MsgBox (code & "該当無し")
                Exit Do
            Else
              For j = 0 To 1
                For i = 0 To 15
                  h = r.Offset(0, rOfs + i + j * 16)
                  c = Val(Replace(h, "0x", "&H"))
                  For b = 0 To 7
                    m = 2 ^ b
                     If c And m Then
                        Worksheets("16dot").Range("AI5").Offset(b + j * 8, i) = "●"
                     Else
                        Worksheets("16dot").Range("AI5").Offset(b + j * 8, i) = ""
                     End If
                  Next
                Next
              Next
              Exit Sub
            End If
        Loop While Not r Is Nothing
    End With
End Sub
Sub PlotSRdat()
    Dim i, j, b, c, m, ofs, col, row, dot As Integer
    Dim arr() As String     ' 格納する文字列配列
    col = 28        ' Range("AB10")
    row = Worksheets("16dot").Range("AL39") + 7
    If Worksheets("16dot").Range("C2") = 8 Then
        dot = 7
        ofs = 8
    Else
        dot = 15
        ofs = 0
    End If
    For j = 0 To 1
      arr = Split(Cells(row, col), " ")
      For i = 0 To 15
        c = Val("&H" + arr(i))
        For b = 0 To 7
          m = 2 ^ b
          If c And m Then
            Worksheets("16dot").Range("AI5").Offset(b + j * 8, i + ofs) = "●"
          Else
            Worksheets("16dot").Range("AI5").Offset(b + j * 8, i + ofs) = ""
          End If
        Next
      Next i
      row = row + 1
    Next j
End Sub
Sub PatternClear()
    Dim rtn As Integer
    rtn = MsgBox("パターンを消去して良いですか?", vbYesNo + vbQuestion, "確認")
    If rtn = vbYes Then
        Range("Ai5:AX20").Clear
    End If
End Sub
Sub MoveLeft()
    Dim i, j As Integer
    For j = 0 To 15
        For i = 0 To 14
            Range("AI5").Offset(j, i) = Range("AI5").Offset(j, i + 1)
        Next
    Next
    Range("AX5:AX20").Clear
End Sub
Sub MoveRight()
    Dim i, j As Integer
    For j = 0 To 15
        For i = 15 To 1 Step -1
            Range("AI5").Offset(j, i) = Range("AI5").Offset(j, i - 1)
        Next
    Next
    Range("AI5:AI20").Clear
End Sub
Sub MoveUp()
    Dim i, j As Integer
    For j = 0 To 14
        For i = 0 To 15
            Range("AI5").Offset(j, i) = Range("AI5").Offset(j + 1, i)
        Next
    Next
    Range("AI20:AX20").Clear
End Sub
Sub MoveDown()
    Dim i, j As Integer
    For j = 15 To 1 Step -1
        For i = 0 To 15
            Range("AI5").Offset(j, i) = Range("AI5").Offset(j - 1, i)
        Next
    Next
    Range("AI5:AX5").Clear
End Sub
Sub SaveMemory()
    Dim i As Integer
    For i = 0 To 15
        Bdf(i) = Val("&H" + Range("AY5").Offset(i, 0))
    Next
End Sub
Sub RecallMemory()
    Dim i, b As Integer
    Dim m As Long
    Dim rtn As Integer
    rtn = MsgBox("パターンを置き換えて良いですか?", vbYesNo + vbQuestion, "確認")
    If rtn = vbYes Then
        For i = 0 To 15
            For b = 0 To 15
                m = 2 ^ b
                If Bdf(i) And m Then
                    Worksheets("16dot").Range("AI5").Offset(i, 15 - b) = "●"
                Else
                    Worksheets("16dot").Range("AI5").Offset(i, 15 - b) = ""
                End If
            Next
        Next
    End If
End Sub
Sub RevPattern()
    Dim i, j As Integer
    For j = 0 To 15
        For i = 0 To 15
            If Worksheets("16dot").Range("AI5").Offset(i, j) = "" Then
                Worksheets("16dot").Range("AI5").Offset(i, j) = "●"
            Else
                Worksheets("16dot").Range("AI5").Offset(i, j) = ""
            End If
        Next
    Next
End Sub
Sub saveBDF()
    Dim fso         As Object
    Dim tso         As Object
    Dim hData(24)   As String
    Dim i           As Integer
    Dim c As Integer
    Dim rtn As Integer
    rtn = MsgBox(Range("c1") & "に追加して良いですか?", vbYesNo + vbQuestion, "確認")
    If rtn = vbNo Then
        Exit Sub
    End If
    Set fso = CreateObject("Scripting.FileSystemObject")
    strPath = Worksheets("16dot").Range("C1") & ".bdf"
    Set tso = fso.OpenTextFile(strPath, 8, True)
    RowSize = Worksheets("16dot").Range("E2")
    CorSize = Worksheets("16dot").Range("C2")
    c = WorksheetFunction.Hex2Dec(Range("B23"))
    hData(0) = "STARTCHAR " & Range("B23")
    hData(1) = "ENCODING" & Str(c)
    hData(2) = "SWIDTH" & Str(CorSize * 60) & " 0"
    hData(3) = "DWIDTH" & Str(CorSize) & " 0"
    hData(4) = "BBX" & Str(CorSize) & " 16 0 -2"
    hData(5) = "BITMAP"
    For i = 0 To 15
        hData(6 + i) = Range("AY5").Offset(i, 0)
    Next
    hData(22) = "ENDCHAR"
    hData(23) = "ENDFONT"
    With tso
        .WriteLine Text:=Join(hData, vbLf)
        .Close  'ファイルのクローズ
    End With
    Set fso = Nothing
    Set tso = Nothing
    MsgBox CurDir() & "\" & strPath & " にデータを追加しました"
End Sub
Sub HorShurink()
    Dim col, row As Integer
    For row = 0 To 15
        For col = 0 To 7
            If Range("AX5").Offset(row, -col * 2) = "" And Range("AX5").Offset(row, -col * 2 - 1) = "" Then
                Range("AX5").Offset(row, -col) = ""
            Else
                Range("AX5").Offset(row, -col) = "●"
            End If
        Next
    Next
    For row = 0 To 15
        For col = 0 To 7
            Range("AI5").Offset(row, col) = ""
        Next
    Next
End Sub
 
 |