Malicious Office (OLE) — malware analysis report

Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Option Explicit
#If Win64 Then
''' 64bit Excelの場合
Private Sub Workbook_Open()

    Dim str As String
    
    str = "64bit版 Excelでは、本ソフトはご利用できません。"
    str = str & vbCrLf & "32bit版 Excelをご用意ください。"
    
    MsgBox str, vbExclamation + vbOKOnly, "台帳"
    
    ThisWorkbook.Close

End Sub
#Else
''' 32bit Excelの場合
Private Sub Workbook_Open()

    Application.OnTime Now + TimeValue("00:00:01"), "AppInit"

End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If ThisWorkbook.Worksheets("MENU").Cells(1, 50).Value <> 1 Then
        If ActiveWorkbook.Name = ThisWorkbook.Name Or ActiveWorkbook.Name Like "*da.xls" Then
            MsgBox "「終了」ボタンから終了してください。", vbInformation, "台帳MENU"
            Cancel = True
        Else
            If MsgBox("台帳の関連ファイルの終了は「終了」または「閉じる」ボタンから実行してください。" & Chr(10) & "「終了」等のボタンが無い場合のみ終了します。" & Chr(10) & "終了しますか？", 4 + 32, "終了") = 6 Then
            ActiveWorkbook.Close False
            Else
            Cancel = True
            End If
        End If
    End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    
    Cancel = True
    MsgBox "このファイルは保存することはできません。", 16, "保存"

End Sub
#End If
'YB27761 fuku 20150519
Sub kanryou()
    Dim wb As Object, ブックの数 As Integer
    
    Application.DisplayAlerts = False
    On Error Resume Next
    
    ブックの数 = 0
    
    For Each wb In Application.Workbooks
    '20120908
        'If UCase(wb.Name) Like "PERSONAL*" Or UCase(wb.Name) Like "ADDTIN*" Then
        If UCase(wb.Name) Like "PERSONAL*" Or UCase(wb.Name) Like "ADDTIN*" Or UCase(wb.Name) Like "EAPPCOM*" Then
            Else
            ブックの数 = ブックの数 + 1
        End If
    Next wb
    Cells(1, 50).Value = 1 '終了できる印
    
    If ブックの数 = 1 Then
        Application.Quit
        ThisWorkbook.Close False
    Else
        
        ThisWorkbook.Close False
    End If
    
    DoEvents

End Sub


Attribute VB_Name = "StatupModule"
Option Explicit
#If Win64 Then
#Else
Private Declare Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long

Private Const CHILDID_SELF = 0&
Private Const ROLE_SYSTEM_PAGETABLIST = &H3C
Private Const ROLE_SYSTEM_PAGETAB = &H25
'Public Sub CallMe()
'  '引数はカスタムタブ(tab要素)のlabel属性の値,もしくは"アドイン"
'  Call SelRibbonTAB("セルズサポート")
'End Sub
Public Function IsExistRibbon(ByVal myTabName As String) As Boolean
    
    Dim ret As Boolean
    Dim myAcc As Office.IAccessible
    
    Set myAcc = Application.CommandBars("Ribbon")
    Set myAcc = GetAcc(myAcc, "リボン タブ", ROLE_SYSTEM_PAGETABLIST)
    
    Set myAcc = GetAcc(myAcc, myTabName, ROLE_SYSTEM_PAGETAB)
    
    If myAcc Is Nothing Then
        ret = False
    Else
        ret = True
    End If
    
    Set myAcc = Nothing
    
    IsExistRibbon = ret

End Function
'Public Sub SelRibbonTAB(myTabName As String)
'  Dim myAcc As Office.IAccessible
'  Dim TimeLimit As Date
'
'  TimeLimit = DateAdd("s", 2, Now())  'ループの制限時間:2秒
'  Set myAcc = Application.CommandBars("Ribbon")
'  Set myAcc = GetAcc(myAcc, "リボン タブ", ROLE_SYSTEM_PAGETABLIST)
'
'  On Error Resume Next
'  Do
'    Set myAcc = GetAcc(myAcc, myTabName, ROLE_SYSTEM_PAGETAB)
'    DoEvents
'    If Now() > TimeLimit Then Exit Do  '制限時間を過ぎたらループを抜ける
'  Loop While myAcc Is Nothing
'  On Error GoTo 0
'
'  If Not myAcc Is Nothing Then
'    myAcc.accDoDefaultAction (CHILDID_SELF)
'    Set myAcc = Nothing
'  End If
'End Sub
Private Function GetAcc(myAcc As Office.IAccessible, myAccName As String, myAccRole As Long) As Office.IAccessible
    Dim ReturnAcc As Office.IAccessible
    Dim ChildAcc As Office.IAccessible
    Dim List() As Variant
    Dim count As Long
    Dim i As Long

    If (myAcc.accState(CHILDID_SELF) <> 32769) And _
       (myAcc.accName(CHILDID_SELF) = myAccName) And _
       (myAcc.accRole(CHILDID_SELF) = myAccRole) Then
        Set ReturnAcc = myAcc
    Else
        count = myAcc.accChildCount
     
     If count > 0& Then
       ReDim List(count - 1&)
       If AccessibleChildren(myAcc, 0&, ByVal count, List(0), count) = 0& Then
         For i = LBound(List) To UBound(List)
           If TypeOf List(i) Is Office.IAccessible Then
             Set ChildAcc = List(i)
             Set ReturnAcc = GetAcc(ChildAcc, myAccName, myAccRole)
             If Not ReturnAcc Is Nothing Then Exit For
           End If
         Next
       End If
     End If
     
   End If
   
   Set GetAcc = ReturnAcc
 End Function
#End If

Attribute VB_Name = "Sheet3"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Option Explicit
Private Sub CommandButton1_Click()
    
    Call 終了

End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    
    ''' YBNO2475 グループ化画面と処理を共通化する
    'Call 開く
    Call 開く(ActiveCell.Value)
    ''' END YBNO2475 グループ化画面と処理を共通化する

End Sub

Attribute VB_Name = "Sheet5"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Option Explicit

Attribute VB_Name = "Sheet2"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Option Explicit

Attribute VB_Name = "Sheet6"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Option Explicit

Attribute VB_Name = "終了F"
Attribute VB_Base = "0{2DDD6098-4990-46DF-A32E-4B75261EF477}{8E888F86-3216-4029-85A1-70C820AFE609}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False







Option Explicit
Dim Nenrei As String
Dim Sita As Boolean
Dim 今月 As String
Private Sub Command2_Click()
Application.ScreenUpdating = False
Unload Me
Workbooks.Open ThisWorkbook.path & "\DaProcess\月次管理.xla"
Application.Run "月次管理.xla!初期処理"
Workbooks("月次管理.xla").Close
End Sub

Private Sub CommandButton1_Click()
    Call 月次管理処理
    Call Owari '20100328 重
End Sub
Private Sub CommandButton2_Click()
'    Application.ScreenUpdating = False
'    Workbooks.Open ThisWorkbook.path & "\DaProcess\年齢チェック更新用.xls", ReadOnly:=True
'    Application.Run ActiveWorkbook.Name & "!初期処理"
'    Owari
    年齢処理更新.Show
End Sub
Sub ControlsVisible(flg1 As Boolean, flg2 As Boolean)
    Label12.Visible = flg1
    Label10.Visible = flg1
    ListBox1.Visible = flg1
    ListBox2.Visible = flg1
    Label8.Visible = flg1
    CommandButton2.Visible = flg1
    CommandButton5.Visible = flg1
    Label11.Visible = flg2
    Label13.Visible = flg2
    List1.Visible = flg2
    List2.Visible = flg2
    Lab8.Visible = flg2
    Command2.Visible = flg2
    CommandButton3.Visible = flg2
    CommandButton4.Visible = flg2
End Sub

Private Sub CommandButton3_Click()
    Dim n As Long
    If Command2.Enabled = False Then
        MsgBox "現在、他で処理中のため実行できません。", 16, "月次予定"
        Exit Sub
    End If

    n = List1.ListIndex
    If n = -1 Then
        MsgBox "リストから削除するデータを選択してください。", 16, "削除"
        Exit Sub
    End If
    If MsgBox("このデータを削除（翌年は表示されません。)しますか？", 4 + 48, "削除") <> 6 Then Exit Sub
    '削除する前にバックアップ
    Open ThisWorkbook.path & "\DaProcess\MyTool\月次管理\削除.dat" For Append As #1
          Write #1, Format(Date, "yyyy/m/d"), List1.List(n, 0), List1.List(n, 1), List1.List(n, 2), List1.List(n, 3), List1.List(n, 4), List1.List(n, 5)
    Close #1
    List1.RemoveItem n
    Sita = True
End Sub
Private Sub CommandButton4_Click()
    Dim n As Long
    If Command2.Enabled = False Then
        MsgBox "現在、他で処理中のため実行できません。", 16, "月次予定"
        Exit Sub
    End If

    n = List1.ListIndex
    If n = -1 Then Exit Sub
    If List1.List(n, 1) <> "済" Then
        If MsgBox("このデータを「済処理」としますか？", 4 + 32, "済処理") <> 6 Then Exit Sub
        List1.List(n, 1) = "済"
    Else
        If MsgBox("このデータを「済処理」を取消しますか？", 4 + 32, "済処理の取消") <> 6 Then Exit Sub
        List1.List(n, 1) = ""
    End If
    Sita = True
End Sub

Private Sub CommandButton5_Click()
    Dim n As Long
    Dim i As Long
    Dim wb As Workbook
'20131115 kon 21416
'    If ListBox1.List(0, 0) = "該当者なし" Then '20130131 TITTI
    If ListBox1.List(0, 0) = "該当者なし" And ListBox2.List(0, 0) = "該当者なし" Then '20130131 TITTI
        MsgBox "データがありません。", 16, "作成"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Workbooks.Open ThisWorkbook.path & "\DaProcess\年齢処理.xls", ReadOnly:=True, Notify:=False
    '20130131 kon
    Set wb = Workbooks("年齢処理.xls")
    ThisWorkbook.Activate
    DoEvents
    wb.Activate
    
    Sheets("MENU").Select
    ActiveSheet.Unprotect
    Cells(4, 2).Value = Format(Date, "GGGE年M月該当")
    Cells(5, 2).Value = Date

'20131115 kon 21416
'    If ListBox1.ListCount > 0 Then
    If ListBox1.ListCount > 0 And ListBox1.List(0, 0) <> "該当者なし" Then
        Range(Cells(7, 2), Cells(Cells(10000, 2).End(xlUp).row + 10, 6)).ClearContents
        n = 7
        For i = 0 To ListBox1.ListCount - 1
            Cells(n, 2).Value = ListBox1.List(i, 0)
            Cells(n, 3).Value = ListBox1.List(i, 1)
            Cells(n, 4).Value = DateValue(Replace(ListBox1.List(i, 2), ".", "/"))
            Cells(n, 5).Value = Int((DateSerial(Year(Date), Month(Date) + 1, 1) - Cells(n, 4).Value) / 365.25)
            Cells(n, 6).Value = ListBox1.List(i, 4)
            n = n + 1
        Next
    End If
    Application.Run ActiveWorkbook.Name & "!初期処理"
    Unload Me
End Sub


Private Sub List1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
If List1.ListIndex = -1 Then Exit Sub

月次予定.Show
Sita = True '編集しなくてもtrueとした

End Sub
Private Sub OptionButton1_Click()
    Call ControlsVisible(True, False)
    Frame1.Caption = Nenrei
    Label7.Caption = Format(DateAdd("m", 1, Date), "GGGE年M月") & "該当の被保険者"
End Sub

Private Sub OptionButton2_Click()
    Call ControlsVisible(False, True)
    Frame1.Caption = Format(Date, "ggge年m月の月次予定リスト")
    Label7.Caption = Format(DateAdd("m", 1, Date), "ggge年m月の月次予定リスト")
End Sub

'20110413 YB5416 笹 月データがない場合にフリーズ

Private Sub UserForm_Initialize()
    
    Dim TextFilename As String
    Dim MyData As String
    Dim fh As Integer
        
    TextFilename = ThisWorkbook.path & "\DaProcess\MyTool\予定\更新.dat"
    If Dir(TextFilename) = "" Then
        Label8.Caption = "初めてのリストは台帳MENUの「検索抽出」の「年齢」から作成してください。"
        GoTo 次へ
    End If
        
    'On Error Resume Next
    fh = FreeFile
    Open TextFilename For Input As fh
            Input #fh, MyData
    Close fh
    
    Frame1.Caption = Format(Date, "GGGE年M月") & "該当の被保険者 (" & MyData & "更新による)"
    Label9.Caption = "前回" & MyData
    TextFilename = ThisWorkbook.path & "\DaProcess\MyTool\予定\月" & Month(Date) & ".dat"
    UpdateList TextFilename, ListBox1

    Label7.Caption = Format(DateAdd("m", 1, Date), "GGGE年M月") & "該当"
    TextFilename = ThisWorkbook.path & "\DaProcess\MyTool\予定\月" & Month(DateAdd("m", 1, Date)) & ".dat"
    UpdateList TextFilename, ListBox2
次へ:
    Nenrei = Frame1.Caption
    Sita = False '終了時trueの場合、今月の月次予定を更新する
    Call 月次データ表示
    OptionButton1.Value = True
 End Sub
Private Sub 月次データ表示()
    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim 次月 As String
    Dim 月 As String
    Dim TextFilename As String
    Dim MyData(5) As String
    今月 = "月次" & Month(Date) & ".dat"
    次月 = "月次" & IIf(Month(Date) = 12, 1, Month(Date) + 1) & ".dat"
    For i = 1 To 2
        If i = 1 Then
            月 = 今月
            Else
            月 = 次月
        End If
        n = 0
        TextFilename = ThisWorkbook.path & "\DaProcess\MyTool\月次管理\" & 月 '各月リストをセット

        If Dir(TextFilename) <> "" Then
            Open TextFilename For Input As #1
                Do Until EOF(1)
                    Input #1, MyData(0), MyData(1), MyData(2), MyData(3), MyData(4), MyData(5)
                    Controls("List" & i).AddItem MyData(0)
                    Controls("List" & i).List(n, 1) = MyData(1)
                    Controls("List" & i).List(n, 2) = MyData(2)
                    Controls("List" & i).List(n, 3) = MyData(3)
                    Controls("List" & i).List(n, 4) = MyData(4)
                    Controls("List" & i).List(n, 5) = MyData(5)
                    n = n + 1
                Loop
            Close #1
            TextFilename = ThisWorkbook.path & "\DaProcess\MyTool\月次管理\" & Year(Date) & 月 '例2012月次11.dat
            If Dir(TextFilename) = "" Then '前年のデータで「済」印を削除する
                For j = 0 To Controls("List" & i).ListCount - 1
                Controls("List" & i).List(j, 1) = ""
                Next
                Sita = True
                CreateObject("Scripting.FileSystemObject").createTextFile TextFilename
            End If
        End If
    Next
    n = 0
    If List1.ListCount > 0 Then '今月の未処理の件数をカウントする
        For i = 0 To List1.ListCount - 1
            If List1.List(i, 1) <> "済" Then
                n = n + 1
            End If
        Next
    End If
    If n > 0 Then
        Label12.Caption = "「月次予定データ」に当月「" & n & "」件の未処理データが存在します。"
        Label13.Caption = "未処理データ " & n & " 件"
    End If
    TextFilename = ThisWorkbook.path & "\DaProcess\MyTool\月次管理\Ing.dat" 'これがあれば他で開いてること
    If Dir(TextFilename) = "" Then
    CreateObject("Scripting.FileSystemObject").createTextFile TextFilename '使用中とする
    Else
    Command2.Enabled = False
    CommandButton3.Enabled = False
    End If
    
End Sub
Private Sub UpdateList(ByVal fname As String, ByRef lb As MSForms.ListBox)
     
    Dim i As Long
    Dim j As Long
    Dim fh As Integer
    Dim MyData(0 To 4) As String
    
    lb.Clear
    If IsFileExist(fname) Then
        fh = FreeFile
        Open fname For Input As fh
        Do Until EOF(1)
            Input #fh, MyData(0), MyData(1), MyData(2), MyData(3), MyData(4)
            lb.AddItem MyData(0)
            For j = 1 To 4
                lb.List(i, j) = MyData(j)
            Next
            i = i + 1
        Loop
        Close fh
    End If
    If lb.ListCount = 0 Then lb.AddItem "該当者なし"
End Sub
Private Function IsFileExist(ByVal fname As String) As Boolean

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    IsFileExist = fso.FileExists(fname)

    Set fso = Nothing

End Function
Private Sub 月次管理処理()
    Dim i As Long
    Dim TextFilename As String
    If Sita = True Then
        TextFilename = ThisWorkbook.path & "\DaProcess\MyTool\月次管理\" & 今月 '今月月次管理を更新
        With List1
            Open TextFilename For Output As #1
                For i = 0 To .ListCount - 1
                        Write #1, .List(i, 0), .List(i, 1), .List(i, 2), .List(i, 3), .List(i, 4), .List(i, 5)
                Next
            Close #1
        End With
    End If
    On Error Resume Next
    Kill ThisWorkbook.path & "\DaProcess\MyTool\月次管理\Ing.dat"
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call 月次管理処理
End Sub


Attribute VB_Name = "Check"
Attribute VB_Base = "0{930C6A58-3594-4B23-B395-6FED9D28CB24}{1A8CFADE-0CFC-4E21-880E-F3DC1259B5B7}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit
Private Sub CommandButton1_Click()
    Call チェック("年齢チェック.xls")
End Sub
Private Sub CommandButton2_Click()
    Call チェック("月変チェック.xls")
End Sub
Private Sub CommandButton3_Click()
    Call チェック("取得チェック.xls")
End Sub
Private Sub CommandButton4_Click()
    Call チェック("給与チェック.xls")
End Sub
Private Sub チェック(ファイル As String)
    Application.ScreenUpdating = False
    Unload Me
    Workbooks.Open fileName:=ThisWorkbook.path & "\DaProcess\" & ファイル
    ActiveSheet.EnableSelection = xlUnlockedCells
    ActiveSheet.Protect UserInterfaceOnly:=True
    ActiveWindow.DisplayHeadings = False
    ActiveWindow.DisplayWorkbookTabs = False
    Application.ScreenUpdating = True
    Application.Run ファイル & "!CHECKFへ"
End Sub
Private Sub CommandButton5_Click()
    Call チェック("誕生日チェック.xls")
End Sub
'#38947 ishikawa 20171101
Private Sub CommandButton6_Click()
    Call チェック("残業チェック.xlsm")
End Sub

Attribute VB_Name = "Module2"
Option Explicit
Function ieChk() As Integer
    Dim ieVer As String
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")

    ieVer = fso.GetFileVersion _
    ("C:\Program Files\Internet Explorer\IEXPLORE.EXE ")
    
    ieVer = Left(ieVer, InStr(ieVer, ".") - 1)

    ieChk = ieVer
    
    Set fso = Nothing

End Function
Sub End1()
''' YBNO 2032 Ontimeの設定を反映させる
    'Application.OnTime Now() + TimeValue("00:00:1"), "End2"
    Dim n As Long
    n = GetTextData(1, ThisWorkbook.path & "\DaProcess\MyTool\Ontime.dat")
    Application.OnTime Now + TimeValue("00:00:0" & n), "End2"
End Sub
Sub End2()
ActiveWorkbook.Close False
End Sub
'-----------------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------------
'20100903masa　テキスト読み込み　書き込み　関係
'
'
Public Function GetTextData(ByVal i As Integer, ByVal fileName As String) As String
  
    Dim buffer() As String '文字列受け取り用
    
    GetStringArray buffer, fileName

    GetTextData = buffer(i - 1)

End Function
Public Sub SetTextData(ByVal i As Integer, ByVal str As String, ByVal fileName As String)

    '先に全部読み込む

    Dim buffer() As String '文字列受け取り用
    
    GetStringArray buffer, fileName
    
    '書き換えたい文字列
    buffer(i - 1) = str
    
    Dim FileNumber As Integer 'ファイル番号
    Dim LineCount As Integer '行数

    '初期処理
    FileNumber = FreeFile
    LineCount = 0

    'DOTO FreeFileで番号を得ること
    Open fileName For Output As #FileNumber

    For LineCount = 0 To UBound(buffer)
            'ファイルをバイナリで読み込んで配列に格納
            Print #FileNumber, buffer(LineCount)
    Next
           
    Close #FileNumber
    
End Sub
Public Sub GetStringArray(ByRef str() As String, ByVal fileName As String)

    Dim FileNumber As Integer 'ファイル番号
    Dim LineCount As Integer '行数

    '初期処理
    FileNumber = FreeFile
    LineCount = 0

    'DOTO FreeFileで番号を得ること
    Open fileName For Input As FileNumber

        Do While Not EOF(FileNumber)
            'ファイルの長さで配列をデータを保持しながら初期化
            ReDim Preserve str(LineCount)
    
            'ファイルをバイナリで読み込んで配列に格納
            Line Input #FileNumber, str(LineCount)
            LineCount = LineCount + 1
        Loop
           
    Close #FileNumber

End Sub
Public Function PathCombine(ByVal str1 As String, ByVal str2 As String) As String

    If Right(str1, 1) = "\" Then
        PathCombine = str1 & str2
    Else
        PathCombine = str1 & "\" & str2
    End If
'
'
'
'20100903masa　テキスト読み込み　書き込み　関係ここまで
'-----------------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------------
End Function
''' YBNO 2032 Ontimeの設定を反映させる
Public Function IsFileExist(ByVal fname As String) As Boolean

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    IsFileExist = fso.FileExists(fname)

    Set fso = Nothing

End Function
Public Function IsOpen(ByVal BookName As String) As Boolean

    Dim ret As Boolean
    Dim wb As Excel.Workbook

    ret = False

    For Each wb In Workbooks
        If wb.Name = BookName Then
            ret = True
            Exit For
        End If
    Next

    IsOpen = ret

End Function
Public Function CanRNote() As Boolean

    If IsFileExist(PathCombine(ThisWorkbook.path, "労務ノートツール.xls")) Then
        CanRNote = True
    Else
        CanRNote = False
    End If
        
End Function
Public Sub AppInit()
    
    Dim VerNo As String
    Dim YMString As String
    Dim strId As String
    Dim bFlgUpdate As String
    Dim MSG As String
    Dim buf As String

    'バージョン番号、保守番号等取得
    GetText "ver.txt", VerNo, YMString
    ThisWorkbook.Worksheets("MENU").Shapes("テキスト ボックス 2").TextFrame.Characters.Text = "Ver." & VerNo
    ThisWorkbook.Worksheets("MENU").Shapes("Rectangle 4").TextFrame.Characters.Text = YMString

    GetText "DaProcess\保守契約番号.txt", strId, bFlgUpdate
    
    If Len(Trim(strId)) = 0 Then
        bFlgUpdate = "#FALSE#"
    End If
    
    '   taka 20150915 hosyu
    'アクセスキー取得
    Dim Abuf As String
    Dim AcesKye As String
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If Dir(ThisWorkbook.path & "\DaProcess\drivePath.txt") = "drivePath.txt" Then
       With fso.GetFile(ThisWorkbook.path & "\DaProcess\drivePath.txt").OpenAsTextStream
            Abuf = .ReadAll
            Set fso = Nothing
        End With
        AcesKye = Mid(Abuf, InStr(Abuf, vbCrLf) + 3, InStr(InStr(Abuf, vbCrLf) + 1, Abuf, vbCrLf) - (InStr(Abuf, vbCrLf) + 4)) 'テキストファイルからキーを抽出
    End If

    '20160108 Cellsドライブ用
    If IsFileExist(ThisWorkbook.path & "\cellsdrive.xlam") Then
        Workbooks.Open ThisWorkbook.path & "\cellsdrive.xlam"
    End If
    'End 20140117
    
    Workbooks.Open ThisWorkbook.path & "\DaAddin.xla"
    Workbooks.Open ThisWorkbook.path & "\DaProcess\eGov\EAppCom.xla" '20120927 電子申請用
    
    '20140117 業務日誌用
    If IsFolderExist(ThisWorkbook.path & "\業務日誌") Then
        Workbooks.Open ThisWorkbook.path & "\業務日誌\業務日誌.xlam"
    End If
    'End 20140117

    '20140624 労務ノート用
    If IsFileExist(ThisWorkbook.path & "\労務ノートツール.xlam") Then
        Workbooks.Open ThisWorkbook.path & "\労務ノートツール.xlam"
    End If
    'End 20140117

    'プログラムをダウンロードするか否かを確認
    Dim IsLiveUpdate As Boolean
    IsLiveUpdate = False
        
    If bFlgUpdate = "#TRUE#" And ThisWorkbook.ReadOnly = False Then
        'LiveUpdateする
        Application.ScreenUpdating = False          '画面を更新しない
        
        If Len(strId) <> 11 Or InStr(1, strId, "-") > 0 Then
            IsLiveUpdate = OldIDToNewID(strId)
            If Not IsLiveUpdate Then
                MsgBox "新IDに変更できませんでした。パスワードでバージョンアップするか、弊社までご連絡ください。", vbInformation + vbOKOnly, "Live Update"
            Else
                '新IDを書き込む
                WriteNumber strId
            End If
        End If
        If Len(strId) = 11 And InStr(1, strId, "-") = 0 Then
            IsLiveUpdate = LiveUpdate(strId, VerNo)
        End If
        Application.ScreenUpdating = True           '画面を更新する
    End If
    
    Init IsLiveUpdate, strId, VerNo, AcesKye
    
    Application.ScreenUpdating = False
    If Dir(ThisWorkbook.path & "\賃金管理\Addtin.xls") <> "" Then
        Workbooks.Open ThisWorkbook.path & "\賃金管理\Addtin.xls", ReadOnly:=True
        Workbooks("Addtin.xls").Worksheets("MENU").Shapes("SOGO").Visible = False
        Application.Windows("Addtin.xls").Visible = False
    End If
    
    'バージョン確認して、セルズサポートリボンを加える
    If Not Left(Application.Version, 2) < 12 Then
        On Error Resume Next
        If Not IsExistRibbon("セルズサポート") Then
            Workbooks.Open(fileName:= _
            ThisWorkbook.path & "\CellsSupport.xlam").RunAutoMacros Which:=xlAutoOpen
        End If
        On Error GoTo 0
    End If

    '業務日誌のdbを操作
    If Dir(ThisWorkbook.path & "\業務日誌\Gver.txt") <> "" Then
        Open ThisWorkbook.path & "\業務日誌\Gver.txt" For Input As #1
            Line Input #1, buf
            If buf = "1.01" Then Call ProcedureMaster '#27491 20151009 ishikawa
            If buf = "1.02" Then Call Create_Table '#25379 20160615 ishikawa
            If buf = "1.03" Then Call 列追加 '#38725 ishikawa 20170808
        Close #1
        
        If buf = "1.01" Or buf = "1.02" Or buf = "1.03" Then
            Open ThisWorkbook.path & "\業務日誌\Gver.txt" For Output As #1
            If buf = "1.01" Then
                Print #1, "1.02"
            ElseIf buf = "1.02" Then
                Print #1, "1.03"
            ElseIf buf = "1.03" Then
                Print #1, "1.04"
            End If
            Close #1
        End If
    End If
    
    If F_BookExists("バージョンアップ.xls") Then
        Workbooks("バージョンアップ.xls").Activate
    End If
    
    '#29962
    If Application.Run("cellsdrive.xlam!IsInstalled") Then
        If Application.Run("cellsdrive.xlam!IsNewVersion") Then
        'CellsDrive件数
            Application.Run "cellsdrive.xlam!NewDataComing"
        Else
            CellsDriveInstall
        End If
    ElseIf Application.Run("cellsdrive.xlam!IsOldInstalled") Then
        CellsDriveInstall
    End If

End Sub
'20101228 メニューのバージョン番号と更新年月を表示するための取得メソッド
Private Sub GetText(ByVal fileName As String, ByRef value1 As String, ByRef value2 As String)

    Dim TextFilename As String
    Dim F As Integer
    
    TextFilename = PathCombine(ThisWorkbook.path, fileName)
    
    F = FreeFile()
    
    Open TextFilename For Input As #F
        Input #F, value1
        Input #F, value2
    Close #F

End Sub
Private Function IsFolderExist(ByVal folderName As String, Optional ByVal Sw As Boolean = False) As Boolean

    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If fso.FolderExists(folderName) Then
        IsFolderExist = True
    Else
        If Sw Then
            fso.CreateFolder folderName
            IsFolderExist = True
        Else
        IsFolderExist = False
        End If
    End If
    
    Set fso = Nothing

End Function
Private Sub WriteNumber(ByVal str As String)

    Dim fn As Long

    fn = FreeFile()
    
    Open ThisWorkbook.path & "\DaProcess\保守契約番号.txt" For Output As #fn
        Write #fn, str
        Write #fn, True
    Close #fn

End Sub
Private Sub CellsDriveInstall()
    
    If MsgBox("台帳およびExcelを閉じて、インストールします。よろしいですか。", vbInformation + vbOKCancel, "Cellsドライブ") = vbCancel Then Exit Sub

    Application.Run ("cellsdrive.xlam!CellsDriveOldToolUnInstall")

    Call ShellExecute(0, "open", Workbooks("DaMenu.xls").path & "\MNRelevance\DISK1\setup.exe", vbNullString, vbNullString, 1)
    
    Workbooks("DaMenu.xls").Worksheets("MENU").Cells(1, 50).Value = 1  '終了できる印
    Application.Run "DaMenu.xls!Owari"
    
    Application.Quit
    
    On Error Resume Next
    Workbooks("DaMenu.xls").Close False
    On Error GoTo 0

End Sub


Attribute VB_Name = "frmUser"
Attribute VB_Base = "0{004CCC4B-6611-411A-BA52-762D184C3318}{9E5E4486-E0BD-4B90-B698-E447B11751AF}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False







Option Explicit

Private Sub cmdYomikomi_Click()
        Call yomikomiRtn
End Sub
Private Sub UserForm_Initialize()
    Dim ファイル名  As String
    
    ListBox1.Clear
    ファイル名 = Dir(ThisWorkbook.path & "\DaProcess\Da保存\ユーザーフォルダ\", vbDirectory)
    
    ' 現在のフォルダと親フォルダは無視します。
    With ListBox1
 
        Do While ファイル名 <> ""
            If ファイル名 <> "." And ファイル名 <> ".." Then
                .AddItem ファイル名
            End If
            ファイル名 = Dir()
        Loop
    End With

End Sub
Sub yomikomiRtn()
    
    Dim iCnt        As Integer
    
    For iCnt = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(iCnt) = True Then
            Workbooks.Open fileName:=ThisWorkbook.path & "\DaProcess\Da保存\ユーザーフォルダ\" & ListBox1.List(iCnt)
            On Error Resume Next
            Application.Run ListBox1.List(iCnt) & "!Auto_Open"
            Application.Run ListBox1.List(iCnt) & "!初期処理"
            On Error GoTo 0
            Exit For
        End If
    Next iCnt
    Unload Me
End Sub

Attribute VB_Name = "セル確認"
Attribute VB_Base = "0{98A20198-5A89-4266-ADAC-4E8E59EEFCB0}{8759137C-A488-485F-A9D0-2666BBFC9D43}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False





Option Explicit
Private Sub CommandButton1_Click()
    On Error GoTo check
    With Worksheets(ComboBox1.Value)
        .EnableSelection = xlUnlockedCells
        .Protect UserInterfaceOnly:=True
…