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


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 = "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


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 = "Sheet4"
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 = "Module1"
'**********************************************************************************
'                       修正履歴
'           クロスループダウンロードパスの変更　20080923 kon
'           印刷時固まるため        20090908 kon
'           outlookがインストールされていれば設定で回避できるため修正   20101021 kon
'           ファイル名を変更すると全銀協ファイルの内部に持っているファイル名を変更できない    20110208 kon
'           20110208のエラーの修正間違え、ファイルがないとエラー　20110318 kon
'           取込先と取込元が同じの場合にチェックするようにした　YBNO9980 20110930 kon
'           #25623 遠隔サポートボタンを消したので、コードもけした　20140723
'           #28484 ツールからのバージョンアップの方法をexeからzipに変更 20150819 hara
'           #27764 ファイル名変更のフォームの保存データ、前年のチェックボックスを非表示しました。
'           #35617 GUIDを消して新たに振りなおす　20161208fuku
'**********************************************************************************
Option Explicit
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Declare Function ShellExecute Lib "shell32.dll" _
    Alias "ShellExecuteA" ( _
    ByVal hwnd As Long, _
    ByVal lpOperation As String, _
    ByVal lpFile As String, _
    ByVal lpParameters As String, _
    ByVal lpDirectory As String, _
    ByVal nShowCmd As Long) As Long
Private Declare Function SHFileOperation Lib "shell32.dll" _
    (lpFileOp As SHFILEOP) As Long

'SHFileOperation関数に渡すユーザー定義型
Type SHFILEOP
    hwnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Long
    hNameMappings As Long
    lpszProgressTitle As String
End Type
Public Const FO_MOVE = &H1
Public Const FO_COPY = &H2
Public Const FO_DELETE = &H3
Public Const FOF_SILENT = &H4               '進行状況ダイアログを表示しない
Public Const FOF_ALLOWUNDO = &H40           'ごみ箱に送る
Public Const FOF_NOCONFIRMATION = &H10      '上書き・削除の確認ダイアログを表示しない
Public Const SW_SHOWNORMAL As Long = 1
Dim i As Long
Sub lstUp(fName As Object)
    Dim ファイル名 As String
    
    fName.ListBox2.Clear
    ファイル名 = Dir(ActiveWorkbook.path & "\*kk.xls")
    Do While ファイル名 <> ""
        fName.ListBox2.AddItem Left(ファイル名, Len(ファイル名) - 6)
        ファイル名 = Dir()
    Loop
End Sub
Public Sub FileDelEx(lngHWnd As Long, strFromPath As String, _
                     Optional blnUseTrash As Boolean = True)
'SHFileOperation関数を呼び出し、ファイル・フォルダをごみ箱に送るか削除する
'＜引数＞
'  lngHWnd     : フォームのウィンドウハンドル
'  strFromPath : 削除ファイル・フォルダのフルパス名
'  blnUseTrash : ごみ箱を使うかどうか（省略可能、初期値は「使用する」）

    Dim ShellOp As SHFILEOP
    Dim lngRet As Long
    Dim flg As Long

    'オプションスイッチの設定
    If blnUseTrash Then flg = FOF_ALLOWUNDO
    flg = flg + FOF_SILENT + FOF_NOCONFIRMATION

    With ShellOp
        .hwnd = lngHWnd
        .wFunc = FO_DELETE
        .pFrom = strFromPath
        .fFlags = flg
    End With

    lngRet = SHFileOperation(ShellOp)

End Sub
Sub 削除へ()
    frmDel.Show
End Sub
Sub 送信へ()
    frmSend.Show
End Sub
Sub バックアップへ()
    frmBk.Show
End Sub
Sub 台帳パスへ()
    frmDaityo.Show
End Sub

Sub バックアップへ戻る()
    ThisWorkbook.Worksheets("MENU").Select
End Sub
Sub 印刷()
    '20090908 kon
    DoEvents
    ThisWorkbook.Worksheets("説明書").PrintOut
    '20090908 kon
    DoEvents

End Sub
Sub インストールへ()
    frm戻す.Show
End Sub
Sub 変更へ()
    frmCng.Show
End Sub
Sub ファイル集計へ()
    frmKei.Show
End Sub
Sub バックアップからメニュー()
    Workbooks("Cells給与.xls").Worksheets("MENU").ListBoxes("FList").RemoveAllItems
    Dim ファイル名 As String
    ファイル名 = Dir(ActiveWorkbook.path & "\*kk.xls")
    Do While ファイル名 <> ""
        With Workbooks("Cells給与.xls").Worksheets("MENU").ListBoxes("FList")
            .AddItem Left(ファイル名, Len(ファイル名) - 6)
            ファイル名 = Dir()
        End With
    Loop
    Application.Run "CellsKyuyoTool.xla!閉じる"
End Sub
Sub ファイル列挙()
    Dim ファイル名 As String
    Dim n As Integer

    n = 17
    Range("C17:C200").ClearContents
    
    ファイル名 = Dir(ActiveWorkbook.path & "\*")
    Do While ファイル名 <> ""
        If ファイル名 Like "*kk*" Or ファイル名 Like "前年*" Or ファイル名 Like "*保存データ*" Then
        Else
            Cells(n, 3).Value = ファイル名
            n = n + 1
        End If
        ファイル名 = Dir()
    Loop
    Cells(n, 3).Value = "保存データ.xls"
    Cells(n + 1, 3).Value = "前年保存データ.xls"
    Cells(n + 2, 3).Value = "新賞与保存データ.xls"

End Sub
Sub Auto_Open()
    Application.ScreenUpdating = False
    Call シート限定("戻す")
End Sub
Private Sub シート限定(シート As String)
    Dim S As Worksheet
      Application.ScreenUpdating = False
      For Each S In Worksheets
        With S
          .Activate
          .EnableSelection = xlUnlockedCells
          .Protect UserInterfaceOnly:=True
           ActiveWindow.DisplayHeadings = False
        End With
      Next
    Worksheets(シート).Select
    ActiveWindow.DisplayWorkbookTabs = False
    Application.ScreenUpdating = True
End Sub
Sub 初期処理()
    Call シート限定("MENU")
End Sub
Sub end_rtn()
    Dim Fcnt        As Integer
    Dim wb          As Workbook
        
    Application.DisplayAlerts = False
    
    '開いているブック数
    Fcnt = Workbooks.Count
    'PERSONAL.XLSを探して、見つかったら数に入れない
    For Each wb In Workbooks
        If StrConv(wb.Name, vbUpperCase) = "PERSONAL.XLS" Then
            Fcnt = Fcnt - 1
        End If
    Next wb
    Application.DisplayAlerts = False
    If Fcnt = 1 Then
        Application.Quit
        Exit Sub
    Else
        Workbooks("ツール.xls").Close False
        Exit Sub
    End If

End Sub
Sub コンバートへ()
    Workbooks.Open ThisWorkbook.path & "\VersionUp.xla"
    Application.Run "VersionUp.xla！コンバート"
    DoEvents
    Workbooks("VersionUp.xla").Close '20130302 titti
End Sub
Sub バージョンアップへ()
    Workbooks.Open ThisWorkbook.path & "\VersionUp.xla"
    Application.Run "VersionUp.xla！バージョンアップ"
    Workbooks("VersionUp.xla").Close '20130302 titti
End Sub
Sub test()
    Workbooks.Open "G:\Book1.xla"
    Application.Run "Book1.xla！a"
    DoEvents
    Workbooks("Book1.xla").Close '20130302 titti
End Sub
Sub 罫線支給控除()
    Range("C47:Q104").Borders.LineStyle = xlNone
    With Range(Cells(47, 3), Cells(104, 14))
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).Weight = xlHairline
        .Borders(xlInsideHorizontal).Weight = xlHairline
    End With
    Range("N47:N104").Borders(xlEdgeRight).Weight = xlThin
    Range("C48:N48,C74:N74,C101:N101").Borders(xlEdgeBottom).Weight = xlThin
End Sub
Sub 罫線勤怠()
    Range("C10:Q28").Borders.LineStyle = xlNone
    With Range(Cells(10, 3), Cells(28, 14))
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeTop).Weight = xlThin
        .Borders(xlEdgeBottom).Weight = xlThin
        .Borders(xlEdgeRight).Weight = xlThin
        .Borders(xlInsideVertical).Weight = xlHairline
        .Borders(xlInsideHorizontal).Weight = xlHairline
    End With

    Range("N10:N28").Borders(xlEdgeRight).Weight = xlThin
    Range("C13:N28").Borders(xlEdgeBottom).Weight = xlThin
End Sub
Sub 設定()
    Dim ret As Long
    Dim Ret2 As Long
    Dim fPath As String
    Dim dPath   As String

    fPath = "http://www.team-cells.jp/dl/Dnsetup.exe"
    dPath = ThisWorkbook.path & "\Dnsetup.exe"
     '書庫ファイルダウンロード
    On Error Resume Next
    ret = URLDownloadToFile(0, fPath, dPath, 0, 0)

    On Error GoTo 0
    If ret <> 0 Then
       MsgBox "ダウンロードに失敗しました。", vbInformation, "インストール失敗"
       Exit Sub
    End If

    'キャッシュ削除
    Ret2 = DeleteUrlCacheEntry(fPath)
    If Ret2 = 0 Then
       Exit Sub
    End If

    '解凍する
    Dim ReturnValue
    ReturnValue = shell(dPath, 1)
    Application.DisplayAlerts = (False)        'メッセージ非表示

End Sub
Sub 顧問先Cells給与へ()
    Dim myPath          As String
    Dim myFSO           As Object

    If GetFolder("メモリースティックなどの移動のできる媒体を選択してください。", myPath) = True Then
        Set myFSO = CreateObject("scripting.filesystemobject")
        myFSO.Copyfolder ThisWorkbook.path & "\顧問先ツール\*", myPath
        myFSO.CopyFile ThisWorkbook.path & "\顧問先ツール\*", myPath
        Set myFSO = Nothing
    
    Else
        MsgBox "保存先を設定してください。", vbInformation, "顧問先ファイルツール"
        Exit Sub
    End If
    MsgBox "保存しました。", vbInformation, "顧問先ファイルツール"
    
End Sub

Sub HELPへ()
    Worksheets("HELP").Select
End Sub
Sub MENUへ()
    Worksheets("MENU").Select
End Sub
Sub ファイル計へ()
    '20140523 TITTI
    MsgBox "申し訳ありません。「ファイル集計」は2014年のバージョンアップで「事業所ファイル」のメニュー画面の「ツール」の「ファイル集計」に移動しました。", 16, "ファイル集計"
'    Dim i As Integer
'
'    Application.ScreenUpdating = False
'    Workbooks.Open FileName:=ThisWorkbook.Path & "\ファイル計.xls"
'    Application.Run "ファイル計.xls!Auto_Open"
'
End Sub
Public Sub DataBoxSetting()

    If CanDataBox() Then
        frmDataBox.Show vbModal
    Else
        MsgBox "この機能は現在、開発中です。", vbInformation + vbOKOnly, "DataBox"
    End If

End Sub
Public Sub DataBox()

    Dim dbs As New DataBoxSetting

    dbs.GetData (PathCombine(ThisWorkbook.path, DATA_BOX_DATA_FILE_NAME))

    If CanDataBox() And dbs.UseFlg Then
        frmDataBoxList.Show vbModal
    ElseIf Not dbs.UseFlg Then
        MsgBox "データボックスを設定してください。", vbInformation + vbOKOnly, "DataBox"
    Else
        MsgBox "この機能は現在、開発中です。", vbInformation + vbOKOnly, "DataBox"
    End If

End Sub
Public Sub LiveUpdateForm()

    frmLiveUp.Show vbModal

End Sub
Public Function PathCombine(ByVal path1 As String, ByVal path2 As String) As String

    If Right(path1, 1) = "\" Then
        PathCombine = path1 & path2
    Else
        PathCombine = path1 & "\" & path2
    End If

End Function
Public Sub NewGUID(kk As String) 'YB35617 fuku 20161209
    Dim FuyoRow As Long
    Dim FuyoColumn As Long
    Dim GuidNo As String
    
    Workbooks(kk & "kk.xls").Worksheets("個人情報").Unprotect
    Workbooks(kk & "kk.xls").Worksheets("扶養データ").Unprotect
    
    With Workbooks(kk & "kk.xls").Worksheets("個人情報")
        For i = 6 To .Cells(10000, 2).End(xlUp).Row
            FuyoRow = Application.Run("Cells給与.xls!扶行", i, kk & "kk.xls") '扶養の行番を取得する。i=個人情報の行番・kkの名前
            GuidNo = Mid(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
            .Cells(i, 200).Value = GuidNo
            .Cells(i, 199).Value = "" '台帳GUID消す
            If FuyoRow > 0 Then
                Workbooks(kk & "kk.xls").Worksheets("扶養データ").Cells(FuyoRow, 1).Value = GuidNo
                For FuyoColumn = 3 To 201 Step 22
                    If Workbooks(kk & "kk.xls").Worksheets("扶養データ").Cells(FuyoRow, FuyoColumn).Value <> "" Then
                        Workbooks(kk & "kk.xls").Worksheets("扶養データ").Cells(FuyoRow, FuyoColumn).Value = Mid(CreateObject("Scriptlet.TypeLib").GUID, 2, 36)
                        Workbooks(kk & "kk.xls").Worksheets("扶養データ").Cells(FuyoRow, FuyoColumn + 21).Value = "" '台帳GUIDを消す
                    End If
                Next
            End If
        Next
    End With
End Sub

Attribute VB_Name = "Module2"
Option Explicit

Type BROWSEINFO
        hWndOwner As Long
        pidlRoot As Long
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As Long
        lParam As String
        iImage As Long
End Type

Declare Function SHBrowseForFolder Lib "SHELL32" (lpbi As BROWSEINFO) As Long
Declare Function SHGetPathFromIDList Lib "SHELL32" (ByVal pidl As Long, ByVal pszPath As String) As Long

Public Const CSIDL_DESKTOP = &H0              'デスクトップ
Public Const BIF_BROWSEINCLUDEFILES = &H4000
Public Const BIF_RETURNONLYFSDIRS = &H1            'フォルダのみ選択可能
Private Type MAPIMessage
    Reserved    As Long
    Subject     As String   ' 件名
    NoteText    As String   ' 本文
    MessageType As String
    DateReceived As String
    ConversationID As String
    Flags       As Long
    RecipCount  As Long     ' 宛先の数
    FileCount   As Long     ' 添付ファイルの数
End Type
Private Type MapiRecip
    Reserved    As Long
    RecipClass  As Long     ' 宛先のタイプ
    Name        As String   ' 名前
    Address     As String   ' アドレス
    EIDSize     As Long
    EntryID     As String
End Type
Private Type MapiFile
    Reserved As Long
    Flags As Long
    Position As Long        ' 添付位置
    PathName As String      ' 添付ファイルのパス
    fileName As String      ' 添付後のファイル名
    FileType As String
End Type
Const MAPI_TO = 1
'Const MAPI_CC = 2
'Const MAPI_BCC = 3

Private Declare Function BMAPISendMail _
        Lib "C:\Program Files\Outlook Express\MSOE.DLL" _
        (ByVal Session As Long, ByVal UIParam As Long, _
        Message As MAPIMessage, Recipient() As MapiRecip, _
        File() As MapiFile, ByVal Flags As Long, _
        ByVal Reserved As Long) As Long
Const MAPI_LOGON_UI = &H1
Const MAPI_DIALOG = &H8
Public Sub OESendMail(ByVal Address As String, _
                      ByVal Subject As String, _
                      Optional ByVal Body As String, _
                      Optional ByVal FilePath As String, _
                      Optional ByVal fDisplay As Boolean = True)

    Dim udtMsg As MAPIMessage
    Dim udtRecips(0 To 0) As MapiRecip
    Dim udtFiles() As MapiFile
    Dim strFiles() As String
    Dim lngFileCount As Long
    Dim lngResult As Long
    Dim i As Long

    With udtRecips(0)
        .RecipClass = MAPI_TO   ' 宛先タイプ
        .Name = Address         ' 宛先
    End With

    strFiles = Split(FilePath, ";")
    lngFileCount = UBound(strFiles) + 1
    ' 添付ファイル無しの時も要素は1つ必要
    ReDim udtFiles(0 To lngFileCount + (lngFileCount > 0))
    For i = 0 To lngFileCount - 1
        With udtFiles(i)
            .PathName = Trim$(strFiles(i))  ' 添付ファイル名
            .Position = -1                  ' 位置(変更不要)
        End With
    Next
    Erase strFiles

    With udtMsg
        .Subject = Subject      ' 件名
        .NoteText = Body        ' 本文
        If Len(Address) Then .RecipCount = 1
        .FileCount = lngFileCount
    End With

    ' 送信
    lngResult = BMAPISendMail(0, 0, udtMsg, udtRecips, udtFiles, _
                        MAPI_DIALOG And fDisplay Or MAPI_LOGON_UI, 0)
    If lngResult = 1 Then
        'メールが起動してからキャンセルした時
    ElseIf lngResult <> 0 Then
        Err.Raise vbObjectError + 513, , _
                    "メール送信エラー。" & vbCrLf & _
                    "MAPIエラーコード： " & lngResult
    End If

End Sub
Public Function GetFolder(strComent As String, strPath As String) As Boolean
    Dim bif     As BROWSEINFO
    Dim pidl    As Long
    Dim hwnd    As Long
    
    On Error GoTo ErrGetFolder

    With bif
        .hWndOwner = hwnd
        .pidlRoot = CSIDL_DESKTOP
        .ulFlags = BIF_RETURNONLYFSDIRS
        .lpszTitle = strComent
    End With

    pidl = SHBrowseForFolder(bif)

    If pidl <> 0 Then
        strPath = String$(256, vbNullChar)
        SHGetPathFromIDList pidl, strPath
        strPath = Left(strPath, InStr(strPath, vbNullChar) - 1)
        GetFolder = True
    Else
        GetFolder = False
    End If
     
    Exit Function
     
ErrGetFolder:
    GetFolder = False

End Function
Public Function IsFileExist(ByVal fileName As String) As Boolean

    Dim ret As Boolean

    Dim Obj As Object
    
    Set Obj = CreateObject("Scripting.FileSystemObject")
    
    ret = Obj.FileExists(fileName)

    Set Obj = Nothing

    IsFileExist = ret

End Function
Public Sub CopyToTemp(ByVal TargetFile As String)

    Dim fileName As String
    Dim Obj As Object

    Set Obj = CreateObject("Scripting.FileSystemObject")
    
    fileName = Obj.GetFileName(TargetFile)
    
    fileName = Format(Now, "YYYYMMDDhhmmss") & fileName
    
    If Not IsFolderExist(ThisWorkbook.path & "\Temp") Then
        Obj.CreateFolder ThisWorkbook.path & "\Temp"
    End If
    
    Obj.CopyFile TargetFile, ThisWorkbook.path & "\Temp\" & fileName

    Set Obj = Nothing

End Sub
Public Function IsFolderExist(ByVal folderName As String) As Boolean

    Dim ret As Boolean

    Dim Obj As Object
    
    Set Obj = CreateObject("Scripting.FileSystemObject")
    
    ret = Obj.FolderExists(folderName)

    Set Obj = Nothing

    IsFolderExist = ret

End Function

Attribute VB_Name = "frmDel"
Attribute VB_Base = "0{FF6F3260-1007-4BD8-9CC5-CA55DCC00528}{10B88009-1BE3-4BAD-A592-99B83405D70A}"
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 Declare Function GetWindow _
    Lib "user32" _
    (ByVal hwnd As Long, ByVal wCmd As Long) _
    As Long
Private Const GW_HWNDFIRST As Long = 0  '最前面のウィンドウを検索する

Private Sub CommandButton4_Click()
    Dim ファイル名 As String
    
    ListBox2.Clear
    ファイル名 = Dir(ActiveWorkbook.path & "\*kk.xls")
    Do While ファイル名 <> ""
        If ファイル名 Like "*" & TextBox2.Value & "*" Then
            ListBox2.AddItem Left(ファイル名, Len(ファイル名) - 6)
        End If
        ファイル名 = Dir()
    Loop
    If ListBox2.ListCount = 0 Then
        MsgBox "見つかりません。", vbInformation, "検索"
        ファイル名 = Dir(ActiveWorkbook.path & "\*kk.xls") '事業所ファイル
        Do While ファイル名 <> ""
            ListBox2.AddItem Left(ファイル名, Len(ファイル名) - 6)
            ファイル名 = Dir()
        Loop
    End If
End Sub

Private Sub CommandButton5_Click()
    Dim myHwnd As Long
    
    Dim strFiles As String
    
    myHwnd = GetWindow(myHwnd, GW_HWNDFIRST)
    If ListBox2.ListIndex = -1 Then
        MsgBox "リストが選択されていません。", vbInformation, "ファイル削除"
        Exit Sub
    End If
    
    '#35634  ito 20161209　追加　------------------------------------------------------------------------------------------
    'If MsgBox("削除してもいいですか？", vbQuestion + vbYesNo, "ファイル削除") <> vbYes Then Exit Sub
    If MsgBox("選択した事業所を削除します。よろしいですか？" & vbCrLf & vbCrLf & _
        "※　※　※　※　※　※　※　※　※　※　※　※" & vbCrLf & _
        "　マイナンバーをCells給与で登録している場合、" & vbCrLf & _
        "　マイナンバーも同時に削除します。" & vbCrLf & _
        "※　※　※　※　※　※　※　※　※　※　※　※", vbExclamation + vbYesNo, "ファイル削除") <> vbYes Then Exit Sub
    '#35634  ここまで　----------------------------------------------------------------------------------------------------

    '削除するパス
    strFiles = ListBox2.Value
    If Dir(ThisWorkbook.path & "\" & strFiles & "kk.xls", vbNormal) <> "" Then
        Call FileDelEx(myHwnd, ThisWorkbook.path & "\" & strFiles & "kk.xls", True)
    End If
'    If Dir(ThisWorkbook.Path & strFiles & "\" & "保存データ.xls", vbNormal) <> "" Then 20061005 KATO
    If Dir(ThisWorkbook.path & "\" & strFiles & "保存データ.xls", vbNormal) <> "" Then
        Call FileDelEx(myHwnd, ThisWorkbook.path & "\" & strFiles & "保存データ.xls", True)
    End If
'    If Dir(ThisWorkbook.Path & "前年" & "\" & strFiles & ".xls", vbNormal) <> "" Then
    If Dir(ThisWorkbook.path & "\" & "前年" & strFiles & ".xls", vbNormal) <> "" Then
        Call FileDelEx(myHwnd, ThisWorkbook.path & "\" & "前年" & strFiles & ".xls", True)
    End If
       
'    パスワードが設定されている場合
    If Dir(ThisWorkbook.path & "\" & "MyTool\" & strFiles & ".dat", vbNormal) <> "" Then
        Call FileDelEx(myHwnd, ThisWorkbook.path & "\" & "MyTool\" & strFiles & ".dat", True)
    End If

    '#35634  ito 20161209　追加　-----------------------------------------------------
    'MyNumber
    If Dir(ThisWorkbook.path & "\MyNumber\" & strFiles, vbDirectory) <> "" Then
        Call FileDelEx(myHwnd, ThisWorkbook.path & "\MyNumber\" & strFiles, True)
    End If
    '#35634  ここまで　---------------------------------------------------------------
    
ListBox2.RemoveItem ListBox2.ListIndex '20061005 KATO
MsgBox "削除しました。", 64, "削除" '20061005 KATO
End Sub

Private Sub UserForm_Initialize()
    Call lstUp(frmDel)
End Sub

Attribute VB_Name = "frmCng"
Attribute VB_Base = "0{6ABDB554-6CA9-4152-A0E1-A8B35522173A}{B9E70889-72B8-489C-B599-8BA3581EF0C0}"
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 CommandButton6_Click()
 
    If ListBox2.ListIndex = -1 Then
        MsgBox "リストが選択されていません。", 16, "コピー"
        Exit Sub
    End If
    If Trim(TextBox3.Value) = "" Then
        MsgBox "ファイル名を入力してください。", 16, "コピー"
        Exit Sub
    End If

    If CheckBox1.Value = False Or CheckBox2.Value = False Then
        MsgBox "「保存ファイル」または「前年ファイル」がない事業所ファイルはコピーすることができません。", 16, "変更"
        Exit Sub
    End If
    If Dir(ActiveWorkbook.path & "\" & TextBox3.Value & "kk.xls") <> "" Then
        MsgBox "このファイル名は既に存在します。他の名前を指定してください。", 16, "コピー"
        Exit Sub
    End If
'ファイル名をコピーして、そのファイルを開き基本項目のファイル名をかえる
    If MsgBox("ファイル名「" & ListBox2.Value & "」を「" & TextBox3.Value & "」でコピーしますか？", 1 + 32, "ファイルのコピー") <> 1 Then Exit Sub
    Application.ScreenUpdating = False
    
    FileCopy ActiveWorkbook.path & "\" & ListBox2.Value & "kk.xls", ActiveWorkbook.path & "\" & TextBox3.Value & "kk.xls"
    Workbooks.Open fileName:=ActiveWorkbook.path & "\" & TextBox3.Value & "kk.xls"
    Sheets("基本項目").Select
    ActiveSheet.Unprotect
    Cells(12, 3).Value = TextBox3.Value
    Sheets("MENU").Select
    Cells(1, 1).Value = ""
    
    'YB35617 fuku 20161209 扶養データシートがあればkkの名前連れてく-------------------------------------
    Dim ws As Worksheet
    For Each ws In Workbooks(TextBox3.Value & "kk.xls").Worksheets
        If ws.Name = "扶養データ" Then Call NewGUID(TextBox3.Value)
    Next ws
    '----------------------------YB35617 fuku 20161209 扶養データシートがあればkkの名前連れてく
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    FileCopy ActiveWorkbook.path & "\" & ListBox2.Value & "保存データ.xls", ActiveWorkbook.path & "\" & TextBox3.Value & "保存データ.xls"
    FileCopy ActiveWorkbook.path & "\前年" & ListBox2.Value & ".xls", ActiveWorkbook.path & "\前年" & TextBox3.Value & ".xls"
    Call lstUp(frmCng)
    
    MsgBox "コピーしました。", 64, "ファイルコピー"
    Application.ScreenUpdating = True
End Sub

Private Sub CommandButton4_Click()
    Dim ファイル名      As String
    
    ListBox2.Clear
    ファイル名 = Dir(ActiveWorkbook.path & "\*kk.xls")
    Do While ファイル名 <> ""
        If ファイル名 Like "*" & TextBox2.Value & "*" Then
            ListBox2.AddItem Left(ファイル名, Len(ファイル名) - 6)
        End If
        ファイル名 = Dir()
    Loop
    If ListBox2.ListCount = 0 Then
        MsgBox "見つかりません。", vbInformation, "検索"
        ファイル名 = Dir(ActiveWorkbook.path & "\*kk.xls") '事業所ファイル
        Do While ファイル名 <> ""
            ListBox2.AddItem Left(ファイル名, Len(ファイル名) - 6)
            ファイル名 = Dir()
        Loop
    End If

End Sub

Private Sub CommandButton5_Click()
    Dim MyF     As String
    Dim iCnt    As Integer
     
    If ListBox2.ListIndex = -1 Then
        MsgBox "リストが選択されていません。", 16, "変更"
        Exit Sub
    End If
    If Trim(TextBox3.Value) = "" Then
        MsgBox "ファイル名を入力してください。", 16, "変更"
        Exit Sub
    End If

    If CheckBox1.Value = False Or CheckBox2.Value = False Then
        MsgBox "「保存ファイル」または「前年ファイル」がない事業所ファイルは変更することができません。", 16, "変更"
        Exit Sub
    End If
    If Dir(ActiveWorkbook.path & "\" & TextBox3.Value & "kk.xls") <> "" Then
        MsgBox "このファイル名は既に存在します。他の名前を指定してください。", 16, "変更"
        Exit Sub
    End If
'ファイル名を変更して、そのファイルを開き基本項目のファイル名をかえる
    If MsgBox("ファイル名「" & ListBox2.Value & "」を「" & TextBox3.Value & "」に変更しますか？", 1 + 32, "ファイル名の変更") <> 1 Then Exit Sub
    Label14.Visible = True
    Me.Repaint
    Application.ScreenUpdating = False
    Name ActiveWorkbook.path & "\" & ListBox2.Value & "kk.xls" As ActiveWorkbook.path & "\" & TextBox3.Value & "kk.xls"
    Workbooks.Open fileName:=ActiveWorkbook.path & "\" & TextBox3.Value & "kk.xls"
    Sheets("基本項目").Select
    ActiveSheet.Unprotect
    Cells(12, 3).Value = TextBox3.Value
    Sheets("MENU").Select
    Cells(1, 1).Value = ""
    ActiveWorkbook.Save
    ActiveWorkbook.Close
    Name ActiveWorkbook.path & "\" & ListBox2.Value & "保存データ.xls" As ActiveWorkbook.path & "\" & TextBox3.Value & "保存データ.xls"
    Name ActiveWorkbook.path & "\前年" & ListBox2.Value & ".xls" As ActiveWorkbook.path & "\前年" & TextBox3.Value & ".xls"
'パスワードが設定されていたら
    MyF = ThisWorkbook.path & "\MyTool\kkps\" & ListBox2.List(ListBox2.ListIndex, 0) & ".dat"
    If Dir(MyF) <> "" Then
        Name MyF As ThisWorkbook.path & "\MyTool\kkps\" & TextBox3.Value & ".dat"
    End If
'締日調整保存
    MyF = ThisWorkbook.path & "\締日調整保存\" & ListBox2.List(ListBox2.ListIndex, 0) & "*.xls"
    If Dir(MyF) <> "" Then
        MyF = ThisWorkbook.path & "\締日調整保存\" & Dir(MyF)
        iCnt = InStr(1, Dir(MyF), ListBox2.List(ListBox2.ListIndex, 0), vbBinaryCompare)
        Name MyF As ThisWorkbook.path & "\締日調整保存\" & TextBox3.Value & Mid(Dir(MyF), iCnt + Len(ListBox2.List(ListBox2.ListIndex, 0)), Len(Dir(MyF)))
    End If
'地銀保存
    'フォルダ
    MyF = ThisWorkbook.path & "\地銀保存\" & ListBox2.List(ListBox2.ListIndex, 0)
    If Dir(MyF, vbDirectory) <> "" Then
        MyF = ThisWorkbook.path & "\地銀保存\" & Dir(MyF, vbDirectory)
        Name MyF As ThisWorkbook.path & "\地銀保存\" & TextBox3.Value
    End If
    'ファイル
    MyF = ThisWorkbook.path & "\地銀保存\" & ListBox2.List(ListBox2.ListIndex, 0) & "tg.xls"
    If Dir(MyF) <> "" Then
        MyF = ThisWorkbook.path & "\地銀保存\" & Dir(MyF)
        Name MyF As ThisWorkbook.path & "\地銀保存\" & TextBox3.Value & "tg.xls"
    End If
'全銀保存
    MyF = ThisWorkbook.path & "\全銀保存\" & ListBox2.List(ListBox2.ListIndex, 0) & "gn.xls"
    If Dir(MyF) <> "" Then
        MyF = ThisWorkbook.path & "\全銀保存\" & Dir(MyF)
        Name MyF As ThisWorkbook.path & "\全銀保存\" & TextBox3.Value & "gn.xls"
        
    '20110318 kon
    Application.DisplayAlerts = False
    Workbooks.Open ThisWorkbook.path & "\全銀保存\" & TextBox3.Value & "gn.xls"
    Sheets("情報").Cells(7, 3).Value = TextBox3.Value & "kk.xls"
    Workbooks(TextBox3.Value & "gn.xls").Save
    Workbooks(TextBox3.Value & "gn.xls").Close
    Application.DisplayAlerts = True
        
    End If
''20110208 kon
'    Application.DisplayAlerts = False
'    Workbooks.Open ThisWorkbook.Path & "\全銀保存\" & TextBox3.Value & "gn.xls"
'    Sheets("情報").Cells(7, 3).Value = TextBox3.Value & "kk.xls"
'    Workbooks(TextBox3.Value & "gn.xls").Save
'    Workbooks(TextBox3.Value & "gn.xls").Close
'    Application.DisplayAlerts = True
'入力表
    MyF = ThisWorkbook.path & "\入力表\" & ListBox2.List(ListBox2.ListIndex, 0) & "給与入力表.xls"
    If Dir(MyF) <> "" Then
        MyF = ThisWorkbook.path & "\入力表\" & Dir(MyF)
        Name MyF As ThisWorkbook.path & "\入力表\" & TextBox3.Value & "給与入力表.xls"
    End If
    MyF = ThisWorkbook.path & "\入力表\" & ListBox2.List(ListBox2.ListIndex, 0) & "賞与入力表.xls"
    If Dir(MyF) <> "" Then
        MyF = ThisWorkbook.path & "\入力表\" & Dir(MyF)
        Name MyF As ThisWorkbook.path & "\入力表\" & TextBox3.Value & "賞与入力表.xls"
    End If
'扶養保存
    MyF = ThisWorkbook.path & "\扶養保存\*" & ListBox2.List(ListBox2.ListIndex, 0) & "*.xls"
    If Dir(MyF) <> "" Then
        MyF = ThisWorkbook.path & "\扶養保存\" & Dir(MyF)
        iCnt = InStr(1, Dir(MyF), ListBox2.List(ListBox2.ListIndex, 0), vbBinaryCompare)
        Name MyF As ThisWorkbook.path & "\扶養保存\" & Mid(Dir(MyF), 1, iCnt - 1) & TextBox3.Value & Mid(Dir(MyF), iCnt + Len(Dir(MyF)) - 1, Len(Dir(MyF))) & ".xls"
    End If
'住民税異動保存
    MyF = ThisWorkbook.path & "\住民税異動保存\*" & ListBox2.List(ListBox2.ListIndex, 0) & ".xls"
    Do Until Dir(MyF, vbNormal) = ""
        MyF = ThisWorkbook.path & "\住民税異動保存\" & Dir(MyF, vbNormal)
        iCnt = InStrRev(Dir(MyF, vbNormal), ListBox2.List(ListBox2.ListIndex, 0))
        Name MyF As ThisWorkbook.path & "\住民税異動保存\" & Mid(Dir(MyF, vbNormal), 1, iCnt - 1) & TextBox3.Value & ".xls"
        MyF = ThisWorkbook.path & "\住民税異動保存\*" & ListBox2.List(ListBox2.ListIndex, 0) & ".xls"
    Loop
'源泉税保存
    MyF = ThisWorkbook.path & "\源泉税保存\*" & ListBox2.List(ListBox2.ListIndex, 0) & ".xls"
    Do Until Dir(MyF, vbNormal) = ""
        MyF = ThisWorkbook.path & "\源泉税保存\" & Dir(MyF, vbNormal)
        iCnt = InStrRev(Dir(MyF, vbNormal), ListBox2.List(ListBox2.ListIndex, 0))
        Name MyF As ThisWorkbook.path & "\源泉税保存\" & Mid(Dir(MyF), 1, iCnt - 1) & TextBox3.Value & ".xls"
        MyF = ThisWorkbook.path & "\源泉税保存\*" & ListBox2.List(ListBox2.ListIndex, 0) & ".xls"
    Loop
'過不足
    MyF = ThisWorkbook.path & "\過不足\" & ListBox2.List(ListBox2.ListIndex, 0) & "過不足データ.xls"
    If Dir(MyF) <> "" Then
        MyF = ThisWorkbook.path & "\過不足\" & Dir(MyF)
        iCnt = InStr(1, Dir(MyF), ListBox2.List(ListBox2.ListIndex, 0), vbBinaryCompare)
        Name MyF As ThisWorkbook.path & "\過不足\" & TextBox3.Value & "過不足データ.xls"
    End If
'有給表
    MyF = ThisWorkbook.path & "\有給表\" & ListBox2.List(ListBox2.ListIndex, 0) & "有給表.xls"
    If Dir(MyF) <> "" Then
        MyF = ThisWorkbook.path & "\有給表\" & Dir(MyF)
        Name MyF As ThisWorkbook.path & "\有給表\" & TextBox3.Value & "有給表.xls"
    End If
'一覧表保存
    MyF = ThisWorkbook.path & "\一覧表保存\" & ListBox2.List(ListBox2.ListIndex, 0) & "*.xls"
    If Dir(MyF) <> "" Then
        MyF = ThisWorkbook.path & "\一覧表保存\" & Dir(MyF)
        iCnt = InStr(1, Dir(MyF), ListBox2.List(ListBox2.ListIndex, 0), vbBinaryCompare)
        Name MyF As ThisWorkbook.path & "\一覧表保存\" & TextBox3.Value & Mid(Dir(MyF), iCnt + Len(ListBox2.List(ListBox2.ListIndex, 0)), Len(Dir(MyF))) & ".xls"
    End If
'タイムカード保存
    MyF = ThisWorkbook.path & "\タイムカード保存\" & ListBox2.List(ListBox2.ListIndex, 0) & "*.xls"
    Do Until Dir(MyF, vbNormal) = ""
        MyF = ThisWorkbook.path & "\タイムカード保存\" & Dir(MyF)
        iCnt = InStr(1, Dir(MyF), ListBox2.List(ListBox2.ListIndex, 0), vbBinaryCompare)
        Name MyF As ThisWorkbook.path & "\タイムカード保存\" & TextBox3.Value & Mid(Dir(MyF), iCnt + Len(ListBox2.List(ListBox2.ListIndex, 0)) + 1, Len(Dir(MyF))) & ".xls"
        MyF = ThisWorkbook.path & "\タイムカード保存\" & ListBox2.List(ListBox2.ListIndex, 0) & "*.xls"
    Loop
'PDF
    'フォルダ
    MyF = ThisWorkbook.path & "\PDF\" & ListBox2.List(ListBox2.ListIndex, 0)
    If Dir(MyF, vbDirectory) <> "" Then
        MyF = ThisWorkbook.path & "\PDF\" & Dir(MyF, vbDirectory)
        Name MyF As ThisWorkbook.path & "\PDF\" & TextBox3.Value
    End If
'MyTool
    'フォルダ
    MyF = ThisWorkbook.path & "\MyTool\" & ListBox2.List(ListBox2.ListIndex, 0)
    If Dir(MyF, vbDirectory) <> "" Then
        MyF = ThisWorkbook.path & "\MyTool\" & Dir(MyF, vbDirectory)
        Name MyF As ThisWorkbook.path & "\MyTool\" & TextBox3.Value
    End If
'JSoukatu　？
    MyF = ThisWorkbook.path & "\MyTool\JSoukatu" & ListBox2.List(ListBox2.ListIndex, 0) & ".dat"
    If Dir(MyF) <> "" Then
        MyF = ThisWorkbook.path & "\MyTool\" & Dir(MyF)
        Name MyF As ThisWorkbook.path & "\MyTool\JSoukatu" & TextBox3.Value & ".dat"
    End If
'KoteTingin
    MyF = ThisWorkbook.path & "\MyTool\KoteTingin" & ListBox2.List(ListBox2.ListIndex, 0) & "kk.xls.dat"
    If Dir(MyF) <> "" Then
        MyF = ThisWorkbook.path & "\MyTool\" & Dir(MyF)
        Name MyF As ThisWorkbook.path & "\MyTool\KoteTingin" & TextBox3.Value & "kk.xls.dat"
    End If
    
'#35634  ito 20161208　-------------------------------------------------------------------------------------------------
'MyNumber
    'フォルダ
    MyF = ThisWorkbook.path & "\MyNumber\" & ListBox2.List(ListBox2.ListIndex, 0)
    If Dir(MyF, vbDirectory) <> "" Then
        MyF = ThisWorkbook.path & "\MyNumber\" & Dir(MyF, vbDirectory)
        Name MyF As ThisWorkbook.path & "\MyNumber\" & TextBox3.Value
    End If
    'ファイル
    MyF = ThisWorkbook.path & "\MyNumber\" & TextBox3.Value & "\myn" & ListBox2.List(ListBox2.ListIndex, 0) & ".xlsm"
    If Dir(MyF) <> "" Then
        MyF = ThisWorkbook.path & "\MyNumber\" & TextBox3.Value & "\" & Dir(MyF)
        Name MyF As ThisWorkbook.path & "\MyNumber\" & TextBox3.Value & "\myn" & TextBox3.Value & ".xlsm"
    End If
    MyF = ThisWorkbook.path & "\MyNumber\" & TextBox3.Value & "\myn" & ListBox2.List(ListBox2.ListIndex, 0) & ".xlsx"
    If Dir(MyF) <> "" Then
        MyF = ThisWorkbook.path & "\MyNumber\" & TextBox3.Value & "\" & Dir(MyF)
        Name MyF As ThisWorkbook.path & "\MyNumber\" & TextBox3.Value & "\myn" & TextBox3.Value & ".xlsx"
    End If
'#35634  ここまで　-----------------------------------------------------------------------------------------------------

    Call 過去ファイルの変更(ListBox2.Value, TextBox3.Value)
    ListBox2.List(ListBox2.ListIndex, 0) = TextBox3.Value
    Label14.Visible = False
    Me.Repaint
    MsgBox "変更しました", 64, "変更"
    Application.ScreenUpdating = True
End Sub
Private Sub 過去ファイルの変更(旧 As String, 新 As String)
…