Option Compare Database   '文字列の比較にデータベースで決められた形式を使用します。
Option Explicit

Function EBCDIC(ByVal cc As String) As Byte
    Select Case cc
    Case "0" To "9"
        EBCDIC = &HF0 + CLng(cc)
    Case "A" To "I"
        EBCDIC = &HC1 + (Asc(cc) - Asc("A"))
    Case "J" To "R"
        EBCDIC = &HD1 + (Asc(cc) - Asc("J"))
    Case "S" To "Z"
        EBCDIC = &HE2 + (Asc(cc) - Asc("S"))
    Case "+"
        EBCDIC = &H4E
    Case "-"
        EBCDIC = &H60
    Case Else
        EBCDIC = &H40
    End Select
End Function

Function EBCDIC変換(ByVal dtin As String) As String
    EBCDIC変換 = dtin
End Function

Function EBCDIC変換old(dtin)
    Static math(9) As String
    Static alph(25) As String
    Static fugo(1) As String
    Dim i, fil
    Dim lng
    Dim DT, wk  As String
    Dim din
    
    fil = Chr(&H40)
    fugo(0) = Chr(&H4E)                '+
    fugo(1) = Chr(&H60)                '-
    For i = 0 To 9                     'EBCDIC 数字
        math(i) = Chr(&HF0 + i)
    Next
    For i = 0 To 25                     'EBCDIC 英字
        If i >= 0 And i <= 8 Then       'Ａ−Ｉ
            alph(i) = Chr(&HC1 + i)
        End If
        If i >= 9 And i <= 17 Then      'Ｊ−Ｒ
            alph(i) = Chr(&HD1 + i - 9)
        End If
        If i >= 18 And i <= 25 Then     'Ｓ−Ｚ
            alph(i) = Chr(&HE2 + i - 18)
        End If
    Next

    din = dtin
    lng = Len(din)
    For i = 1 To lng
        DT = CStr(Mid(dtin, i, 1))
        If DT = "+" Then
            wk = fugo(0)
        ElseIf DT = "-" Then
            wk = fugo(1)
        ElseIf DT >= "0" And DT <= "9" Then
            wk = math(DT)
        ElseIf DT >= "A" And DT <= "Z" Then
            wk = alph(Asc(DT) - Asc("A"))
        ElseIf DT >= "a" And DT <= "z" Then
            wk = alph(Asc(DT) - Asc("a"))
        Else
            wk = fil
        End If
        Mid(din, i, 1) = wk
    Next
    EBCDIC変換old = din
    
End Function

Function 給与作成AL(file_name)
    DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "QD_給与ALtoEXCEL", file_name
    給与作成AL = DCount("*", "QD_給与ALtoEXCEL")
End Function

Function 給与作成(file_name) As Variant
    Dim i, fil, wk, ii As Variant
    Dim rec As String
    Dim Wrec As String
    Dim mdb As Database
    Dim Mds As New ADODB.Recordset
    Dim Mqd As QueryDef
    Dim frm As Form
    Dim Bbuf(79) As Byte
    Dim WSSS As String
    
    On Error GoTo ErrorHandler:

    
    'Set mdb = CurrentDb()
    'Set Mqd = mdb.QueryDefs("QD_給与２")
    'Mqd.Parameters("1") = DateValue(Forms![D_給与月度]![月度])
    'Mqd.Parameters("2") = CStr(Forms![D_給与月度]![区分])
    'Mqd.Parameters("3") = 0
    
    'Set Mds = Mqd.OpenRecordset()
    
    WSSS = "UPDATE DISTINCTROW D_天引 " & _
           "SET " & _
           "D_天引.[ｶｰﾄﾞNO] = StrConv([ｶｰﾄﾞNO],1), " & _
           "D_天引.社員NO = StrConv([社員NO],1), " & _
           "D_天引.調整金cd = StrConv([調整金cd],1) " & _
           "WHERE (((D_天引.月度) = #" & DateValue([Forms]![D_給与月度]![月度]) & "#) " & _
           " And   ((D_天引.flg) = '" & CStr([Forms]![D_給与月度]![区分]) & "') " & _
           " AND   ((D_天引.天引flg)= 0 ));"
    
    DoCmd.RunSQL WSSS

    WSSS = "SELECT DISTINCTROW D_天引.* " & _
           "FROM D_天引 INNER JOIN (M_会員 INNER JOIN M_所属 ON M_会員.所属cd = M_所属.所属cd) ON D_天引.社員NO = M_会員.会員cd " & _
           "WHERE (((D_天引.月度) = #" & DateValue([Forms]![D_給与月度]![月度]) & "#) " & _
           " And   ((D_天引.flg) = '" & CStr([Forms]![D_給与月度]![区分]) & "') " & _
           " And   ((D_天引.天引flg) = 0)) " & _
           " ORDER BY D_天引.月度 DESC , D_天引.flg, D_天引.社員NO;"


    
    
    Mds.Open WSSS, CurrentProject.Connection, adOpenDynamic, adLockOptimistic

    Kill file_name
    'Open file_name For Binary Access Write As #1
    Open file_name For Output Access Write As #1
    
    fil = Chr(&H30)     'Chr(&H40)

'ヘッダレコード ***************************************************************
    rec = "L0"
    Wrec = EBCDIC変換(rec) & String(78, fil)
    
    'Bbuf(0) = &H4C           '&HD3      'L
    'Bbuf(1) = &H30           '&HF0      '0
    'For i = 2 To 79
    '    Bbuf(i) = &H30       '&H40
    'Next i
    'Put #1, , Bbuf
    'Put #1, , wrec
    Print #1, Wrec

'データレコード ***************************************************************
    Dim fld1, fld2, fld3, fld4, fld5
    i = 0
    
    If DCount("*", "QD_給与３") <> 0 Then
    
        DoCmd.OpenForm "C010_処理中"
        Forms!C010_処理中!PrgBar.Min = 0
        Forms!C010_処理中!PrgBar.max = DCount("*", "QD_給与３") + 1
        Forms!C010_処理中!PrgBar.value = 0
        
        Mds.MoveFirst
        Do Until Mds.EOF
            
            Forms!C010_処理中!PrgBar.value = Forms!C010_処理中!PrgBar.value + 1
            DoCmd.RepaintObject acForm, "C010_処理中"
            
            For ii = 0 To 79         'バッファの初期化
                Bbuf(ii) = &H30          '&H40
            Next ii
            
            rec = Mds![ｶｰﾄﾞNO] & Right(Mds![社員NO], 5) & String(49, " ") & Mds![調整金cd] & Mds![符号] & Format(Mds![金額], "0000000;0000000")
            Wrec = EBCDIC変換(rec) & String(14, fil)
            'For ii = 1 To LenB(rec) / 2
            '    Bbuf(ii - 1) = EBCDIC(Mid(rec, ii, 1))
            'Next ii
            
            'Put #1, , Bbuf
            'Put #1, , wrec
            Print #1, Wrec
            i = i + 1
            Debug.Print i
            Mds.MoveNext
        Loop
    End If

' トレイラレコード ************************************************************
    rec = "L9" & Format(i, "00000")
    Wrec = EBCDIC変換(rec) & String(73, fil)
    
    'wrec = Format(i, "00000")
    'Bbuf(0) = &H4C           '&HD3      'L
    'Bbuf(1) = &H39           '&HF9      '9
    'For ii = 1 To LenB(wrec) / 2        'データ件数
    '    Bbuf(2 + ii - 1) = EBCDIC(Mid(wrec, ii, 1))
    'Next ii
        
    'For ii = 7 To 79
    '    Bbuf(ii) = "0"          '&H40
    'Next ii
    
    'Put #1, , Bbuf
    'Put #1, , wrec
    Print #1, Wrec
    
    Close #1
    Mds.Close
    
    給与作成 = i
    
    DoCmd.Close acForm, "C010_処理中"
    
    Exit Function
ErrorHandler:
    Resume Next

End Function
Function 賞与作成(file_name) As Variant
    Dim i, fil, ii As Variant
    Dim rec As String
    Dim Wrec As String
    Dim mdb As Database
    Dim Mds As New ADODB.Recordset
    Dim Mqd As QueryDef
    Dim Bbuf(79) As Byte
    Dim WSSS As String
    
    On Error GoTo Error2:

    'Set mdb = CurrentDb()
    'Set Mqd = mdb.QueryDefs("QD_給与２")
    'Mqd.Parameters("1") = DateValue(Forms![D_給与月度]![月度])
    'Mqd.Parameters("2") = CStr(Forms![D_給与月度]![区分])
    'Mqd.Parameters("3") = 0
    
    'Set Mds = Mqd.OpenRecordset()


    WSSS = "SELECT DISTINCTROW D_天引.* " & _
           "FROM D_天引 INNER JOIN (M_会員 INNER JOIN M_所属 ON M_会員.所属cd = M_所属.所属cd) ON D_天引.社員NO = M_会員.会員cd " & _
           "WHERE (((D_天引.月度) = #" & DateValue([Forms]![D_給与月度]![月度]) & "#) " & _
           " And   ((D_天引.flg) = '" & CStr([Forms]![D_給与月度]![区分]) & "') " & _
           " And   ((D_天引.天引flg) = 0)) " & _
           " ORDER BY D_天引.月度 DESC , D_天引.flg, D_天引.社員NO;"

    Mds.Open WSSS, CurrentProject.Connection, adOpenDynamic, adLockOptimistic

    Kill file_name
    'Open file_name For Binary Access Write As #1
    Open file_name For Output Access Write As #1
    
    fil = Chr(&H30)     'Chr(&H40)

'ヘッダレコード ***************************************************************
    rec = "0000000"
    Wrec = EBCDIC変換(rec) & String(73, fil)
    Print #1, Wrec

    'For i = 0 To 6
    '    Bbuf(i) = &HF0
    'Next i
    'For i = 7 To 79
    '    Bbuf(i) = &H40
    'Next i
    'Put #1, , Bbuf
    
'データレコード ***************************************************************
    i = 0
    If DCount("*", "QD_給与３") <> 0 Then
    
        DoCmd.OpenForm "C010_処理中"
        Forms!C010_処理中!PrgBar.Min = 0
        Forms!C010_処理中!PrgBar.max = DCount("*", "QD_給与３") + 1
        Forms!C010_処理中!PrgBar.value = 0
        
        Mds.MoveFirst
        Do Until Mds.EOF
            
            Forms!C010_処理中!PrgBar.value = Forms!C010_処理中!PrgBar.value + 1
            DoCmd.RepaintObject acForm, "C010_処理中"
            
            For ii = 0 To 79     'バッファの初期化
                Bbuf(ii) = &H30         '&H40
            Next ii
            
            '------- 2000/11/28 まででこのコードはコメントにします ---------------------------------------
            'rec = Right(Mds![社員NO], 5) & Mds![調整金cd] & Format(Mds![金額], "000000000;000000000")
            '
            'wrec = EBCDIC変換(rec) & String(64, fil)
            'If Mds![符号] = "-" Then
            '    wk = Mid(wrec, 16, 1)
            '    'MsgBox "ﾏｲﾅｽ" & wk & Chr(&HD0 + Asc(wk) - &HF0)
            '    Mid(wrec, 16, 1) = Chr(&HD0 + Asc(wk) - &HF0)
            'End If
            '-------------------------------------------------------------------------------------------
            
            'Put #1, , wrec
            
            '--- 2000/11/29 から次のコードに変更します。
            If Mds![符号] = "-" Then
                rec = Right(Mds![社員NO], 5) & Mds![調整金cd] & Format(Mds![金額], "000000000;000000000") & Mds![符号] & String(63, " ")
            Else
                rec = Right(Mds![社員NO], 5) & Mds![調整金cd] & Format(Mds![金額], "000000000;000000000") & String(64, " ")
            End If
            '---------------------------------------
            Wrec = EBCDIC変換(rec)
            Print #1, Wrec
            
            'For ii = 1 To LenB(rec) / 2
            '    Bbuf(ii - 1) = EBCDIC(Mid(rec, ii, 1))
            'Next ii
            'Put #1, , Bbuf
            
            i = i + 1
            Mds.MoveNext
        Loop
    End If

' トレイラレコード ************************************************************
    rec = Format(i, "00000") & "99"
    Wrec = EBCDIC変換(rec) & String(73, fil)
    Print #1, Wrec
    
    'For ii = 1 To LenB(rec) / 2        'データ件数 + "99"
    '    Bbuf(ii - 1) = EBCDIC(Mid(rec, ii, 1))
    'Next ii
    
    'For i = 7 To 79
    '    Bbuf(i) = &H40
    'Next i
    'Put #1, , Bbuf
        
    Close #1
    Mds.Close
    
    賞与作成 = i
    
    DoCmd.Close acForm, "C010_処理中"
    
    Exit Function
Error2:
    Resume Next
End Function