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

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Cancel = True
    MsgBox "このファイルは保存することはできません。", 16, "保存"
End Sub

'YBNO 29544  ito 20151125　追加
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ThisWorkbook.Saved = True
End Sub


Attribute VB_Name = "FILECopyModule"
Option Explicit

' *
' * ファイル操作
' *
Private Declare Function SHFileOperation Lib "shell32.dll" ( _
      pShfileopstruct As Shfileopstruct _
) As Long

' *
' * ファイル操作内容定数
' *
Private Const FO_MOVE = &H1&                ' ファイル移動
Private Const FO_COPY = &H2&                ' ファイルコピー
Private Const FO_DELETE = &H3&              ' ファイル削除
Private Const FO_RENAME = &H4&              ' ファイル名称変更

' *
' * 動作内容定数
' *
Private Const FOF_MULTIDESTFILES = &H1&     ' 操作対象ファイル複数指定
Private Const FOF_CONFIRMMOUSE = &H2&       ' (使用できない)
Private Const FOF_SILENT = &H4&             ' プログレスバー非表示
Private Const FOF_RENAMEONCOLLISION = &H8&  ' 操作結果ファイルの重複名回避
Private Const FOF_NOCONFIRMATION = &H10&    ' 確認ダイアログ ALL OK
Private Const FOF_WANTMAPPINGHANDLE = &H20& ' hNameMappingsにマッピング情報を格納
Private Const FOF_ALLOWUNDO = &H40&         ' ごみ箱指定
Private Const FOF_FILESONLY = &H80&         ' ワイルドカード指定のみの操作
Private Const FOF_SIMPLEPROGRESS = &H100&   ' プログレスバー中にファイル名非表示
Private Const FOF_NOCONFIRMMKDIR = &H200&   ' フォルダ作成確認無し
Private Const FOF_NOERRORUI = &H400&        ' エラーが発生時のダイアログ無し
Private Const FOF_NORECURSION = &H800&      ' サブフォルダ再帰的処理無し

' *
' * ファイル操作に関しての情報をまとめる構造体
' *
Private Type Shfileopstruct
    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
Private Enum FILE_SYSTEM_TYPE
    None = 0
    File = 1
    Folder = 2
End Enum
Private Declare Function SHCreateDirectoryEx Lib _
    "SHELL32" Alias "SHCreateDirectoryExA" ( _
    ByVal hwnd As Long, _
    ByVal pszPath As String, _
    ByVal psa As Long) As Long
'20140731 kon
Public FFPTH As String
    
    
Public Function SHFileOperationCopy(ByVal FromFolder As String, ByVal ToFolder As String) As Boolean

    Dim wShfileopstruct As Shfileopstruct
    Dim ret As Long
    
    With wShfileopstruct
        
        .hwnd = 0

        ' 操作内容を決める。ここでは「コピー」とする。
        .wFunc = &H2&

        ' コピー元ファイルを指定する。
        Select Case IsPathWhichFileOrFolder(FromFolder)
            Case FILE_SYSTEM_TYPE.Folder
                .pFrom = PathCombine(FromFolder, "*.*")
            Case FILE_SYSTEM_TYPE.File
                .pFrom = FromFolder
            Case Else
                SHFileOperationCopy = False
                Exit Function
        End Select
        
        ' コピー先ファイルを指定する。
        
        '20140409 kon 24880
'        ToFolder = PathCombine(ToFolder, "BackUp")
'        ToFolder = PathCombine(ToFolder, "BackUp" & Format(Now(), "yyyymmddhhmmss"))
'20141027 kon 26109
'20140731 kon
'        ToFolder = PathCombine(ToFolder, "BackUp" & Format(Now(), FFPTH))
        ToFolder = PathCombine(ToFolder, "BackUp" & FFPTH)
        
        ret = SHCreateDirectoryEx(0&, ToFolder, 0&)
        
        If ret <> 0 And ret <> 80 And ret <> 183 Then
            SHFileOperationCopy = False
            Exit Function
        End If
        
        .pTo = ToFolder
        
        .fFlags = FOF_RENAMEONCOLLISION + FOF_NOCONFIRMMKDIR

    End With
    
   'ファイル処理を実行する。
    
    ret = SHFileOperation(wShfileopstruct)
    
    If ret <> 0 Or wShfileopstruct.fAnyOperationsAborted <> 0 Then
        SHFileOperationCopy = False
    Else
        SHFileOperationCopy = True
    End If

End Function
Private Function IsPathWhichFileOrFolder(ByVal Path As String) As FILE_SYSTEM_TYPE

    Dim FSO As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If FSO.FolderExists(Path) Then
        IsPathWhichFileOrFolder = Folder
    ElseIf FSO.FileExists(Path) Then
        IsPathWhichFileOrFolder = File
    Else
        IsPathWhichFileOrFolder = None
    End If
    
    Set FSO = Nothing

End Function
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

End Function
Public Sub MoveNumericFile(ByVal str As String)

    Dim FSO As Object
    Dim Folder As Object
    Dim FileObj As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(str)
    
    For Each FileObj In Folder.Files
        If IsNumeric(FSO.GetBaseName(FileObj.Path)) And _
            LCase(FSO.GetExtensionName(FileObj.Path)) = "exe" Then
            Debug.Print FileObj.Name
            On Error GoTo ERR_ROUTIN
            FSO.MoveFile FileObj.Path, Environ("TEMP")
            On Error GoTo 0
'            FSO.CopyFile FileObj.Path, Environ("TEMP"), True
'            FSO.DeleteFile FileObj.Path
        End If
    Next
    
    Set FSO = Nothing

    Exit Sub
ERR_ROUTIN:
    Select Case Err.Number
        Case 58 '同名ファイルがある
            FSO.DeleteFile FileObj.Path
        Case Else
    End Select
    Resume Next
End Sub

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 = "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 = "Module1"
'******************************************************************************************************************
'           修整履歴
'           リモートコントロールにハイパーリンクが係っていたためExcel2000 Ie7 の人がエラーになるのを回避　20070509 kon
'           メールアドレスや保存先の前回のものを表示                                                        20070510 kon
'           同じ場所にバックアップを取ることを禁止　20091026 kon
'           バージョンアップの方法をexeファイルの実行からzipファイルに変更  20150721 hara
'******************************************************************************************************************
Option Explicit
Option Base 1

'ファイルダウンロードのためのもの
Declare Function URLDownloadToFile Lib "urlmon" _
    Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
    ByVal szFileName As String, ByVal dwReserved As Long, _
    ByVal lpfnCB As Long) As Long

'キャッシュを取得して削除するためのもの
Declare Function DeleteUrlCacheEntry Lib "wininet" _
    Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long

Declare Function FormatMessage Lib "kernel32" _
    Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, _
    ByVal dwMessageId As Long, ByVal dwLanguageId As Long, _
    ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long


Public fAdd        As String
Public Fg       As Integer
Public パス     As String
Public folNam    As String
Public fPath    As String                           '移動パス

Public frmCnt As Integer        'ファイル整理抽出フォーム

Private Const SEE_MASK_INVOKEIDLIST = &HC       'lpIDListメンバ使用
Private Const SEE_MASK_NOCLOSEPROCESS = &H40    'プロセスハンドルを取得する
Private Const SEE_MASK_FLAG_NO_UI = &H400       'エラーの時メッセージを表示しない

Public Declare Function GetActiveWindow Lib "user32" () As Long 'この文だけは標準モジュールに設定する
'構造体
Private Type SHELLEXECUTEINFO
    cbSize        As Long       'SHELLEXECUTEINFO構造体のサイズ
    fMask         As Long       '処理制御フラグ（定数参照）
    hwnd          As Long       'オーナーウインドウハンドル
    lpVerb        As String     '処理制御文字列(open,propertiesなど)
    lpFile        As String     '対象ファイル名
    lpParameters  As String     'プロパティ表示時未使用
    lpDirectory   As String     'プロパティ表示時未使用
    nShow         As Long       '表示モード
    hInstApp      As Long       'インスタンスハンドル
    lpIDList      As Long       'オプション
    lpClass       As String     'オプション
    hkeyClass     As Long       'オプション
    dwHotKey      As Long       'オプション
    hIcon         As Long       'オプション
    hProcess      As Long       'オプション
End Type

Public Declare Function ShellExecuteEX Lib "shell32.dll" _
                Alias "ShellExecuteEx" (lpExecInfo As SHELLEXECUTEINFO) As Long

Public 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 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
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            'フォルダのみ選択可能
Public Const BIF_NEWDIALOGSTYLE = &H40
Private Declare Function WNetGetConnection Lib "MPR.dll" _
    Alias "WNetGetConnectionA" _
    (ByVal lpszLocalName As String, _
     ByVal lpszRemoteName As String, _
     cbRemoteName As Long) As Long
Public Const MAX_PATH = 260

Private Const INFINITE = &HFFFF ' Infinite timeout

Public Const SW_SHOWNORMAL As Long = 1
' キーボードレイアウトのハンドルを取得する関数の宣言
Public Declare Function GetKeyboardLayout Lib "user32.dll" (ByVal dwLayout As Long) As Long
' IMEプロパティダイアログの種類を示す定数の宣言
Public Const IME_CONFIG_SELECTDICTIONARY = 3
' IMEプロパティダイアログを表示する関数の宣言
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 iCnt                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 iCnt = 0 To lngFileCount - 1
        With udtFiles(iCnt)
            .PathName = Trim$(strFiles(iCnt))  ' 添付ファイル名
            .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)
    '20050822 kon add
    If lngResult = 1 Then
        'メールが起動してからキャンセルした時
    ElseIf lngResult <> 0 Then
        Err.Raise vbObjectError + 513, , _
                    "メール送信エラー。" & vbCrLf & _
                    "MAPIエラーコード： " & lngResult
    End If

End Sub
Sub バックアップからメニュー()
    ThisWorkbook.Saved = True
    Application.Run "DaAddin.xla!閉じる"

End Sub
Sub Auto_Open()
    
    Application.ScreenUpdating = True

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 + BIF_NEWDIALOGSTYLE
        .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

'プロパティを表示するサブ
'hwnd           :オーナーウインドウハンドル
'strFileName    :対象ファイルパス
'戻り値         :インスタンスハンドル
 Function ShowPropertiesDialog(hwnd As Long, strFileName As String) As Long
    Dim SEI As SHELLEXECUTEINFO
    Dim ret As Long

    With SEI
        .cbSize = Len(SEI)
        .fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
        .hwnd = hwnd
        .lpVerb = "properties"
        .lpFile = strFileName
        .lpParameters = vbNullChar
        .lpDirectory = vbNullChar
        .nShow = 0
        .hInstApp = 0
        .lpIDList = 0
    End With

    ret = ShellExecuteEX(SEI)

    ShowPropertiesDialog = SEI.hInstApp
End Function
Sub LstUp(lstNam As String, obLst As Object, fType As String)
    Dim ファイル名  As String
    
    obLst.Clear
    ファイル名 = Dir(lstNam & "\*.*")
    
    ' 現在のフォルダと親フォルダは無視します。
    With obLst
 
        Do While ファイル名 <> ""
            If ファイル名 <> "." And ファイル名 <> ".." Then
                If ファイル名 = ThisWorkbook.Name Or ファイル名 Like "DaMenu*" Then
                Else
                    If fType <> "" Then
                        If ファイル名 Like fType Then
                            .AddItem ファイル名
                        End If
                    Else
                        .AddItem ファイル名
                    End If
                End If
            End If
            ファイル名 = Dir()
        Loop
    End With
End Sub
Sub 労災雇用保険率表切替()

    If Dir(Workbooks("DaMenu.xls").Path & "\昨年度率表.xls", vbNormal) = "" Then
        MsgBox "率表が見つかりません。", vbInformation, "率表切替"
        Exit Sub
    End If
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Workbooks.Open Workbooks("DaMenu.xls").Path & "\昨年度率表.xls"
    
    Sheets("率表").Select
    Windows("昨年度率表.xls").Activate
    Cells.Select
    Selection.Copy
    Windows("DaMenu.xls").Activate
    Sheets("率表").Select
    Cells.Select
    ActiveSheet.Paste
    Windows("昨年度率表.xls").Close
    
    '#27797 SHIHO 20180106==================================
    Windows("DaMenu.xls").Activate
    '#40553  ito 20180403　3行コメントに
    'Sheets("処理選択").Select
    'Cells(96, 5).Value = "一括有期(前年)"
    'Cells(106, 5).Value = "事務組合一括有期(前年)"
    Sheets("MENU").Select
    '=======================================================
    
    ThisWorkbook.Activate
    MsgBox "率表を切替えました。台帳を終了すると元に戻ります。", vbInformation, "率表切替"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub
Public Sub CellsDriveInstall()

    If IsOpenDaFile Then
        MsgBox "事業所ファイルが開いています。閉じてからインストールしてください。", vbInformation + vbOKOnly, "Cellsドライブ"
        Exit Sub
    End If
    
    If MsgBox("台帳およびExcelを閉じて、インストールします。よろしいですか。", vbInformation + vbOKCancel, "Cellsドライブ") = vbCancel Then Exit Sub

    '旧バージョンをサイレントアンインストール
    UninstallProc "EF0C18A4-AA3A-4FDA-8C99-9D15A6930D14" '1.1.0.0
    UninstallProc "EEC4F680-67EB-4EE6-8112-90D64F2967C5" '1.2.0.0
       
    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"
    
    'YBNO 29544  ito 20151125　追加
    On Error Resume Next
    Workbooks("DaMenu.xls").Close False
    On Error GoTo 0
    
    Application.Quit
   
End Sub
Private Function IsOpenDaFile() As Boolean

    Dim item As Variant

    For Each item In Workbooks
        If Right(item.Name, 6) = "da.xls" Then
            IsOpenDaFile = True
            Exit Function
        End If
    Next

    IsOpenDaFile = False

End Function
Private Sub UninstallProc(ByVal strPram As String)

    Dim ret     As Long
    Dim sdtSEXI As SHELLEXECUTEINFO

    With sdtSEXI
        .cbSize = Len(sdtSEXI)
        .fMask = SEE_MASK_NOCLOSEPROCESS
        .hwnd = Application.hwnd
        .lpVerb = "runas"
        .lpFile = Interaction.Environ("SYSTEMROOT") & "\System32\msiexec.exe"
        .lpParameters = "/qn /x {" & strPram & "}"
        .lpDirectory = vbNullChar
        .nShow = SW_SHOWNORMAL
        .hInstApp = 0
        .lpIDList = 0
    End With

    ret = ShellExecuteEX(sdtSEXI)
    ret = WaitForSingleObject(sdtSEXI.hProcess, INFINITE)

End Sub

'#35874  ito 20170907　Cells給与パス
Sub CKyuyoPath()
    CKyuyoP.Show
End Sub

Attribute VB_Name = "CKyuyoP"
Attribute VB_Base = "0{62D3DCC3-70D1-4F35-8693-4AAE9D7F38FB}{E7FC0F10-43F1-466A-B95F-3E6E54850A90}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False

'#35874  ito 20170907　Cells給与パス追加
Option Explicit

Private Sub cmdB_Click()
    Dim Path As String
    Me.Enabled = False
    If GetFolder("「Cells給与」のフォルダを指定してください。", Path) = True Then
        If Len(Path) = 3 Then
            TextBox1.Value = Left(Path, 2)
        Else
            TextBox1.Value = Path
        End If
    End If
    Me.Enabled = True
End Sub

Private Sub CommandButton1_Click()
    Dim MyF As String
    If Right(TextBox1.Value, 7) <> "Cells給与" Then
        If MsgBox("フォルダ名が「Cells給与」ではありませんが、よろしいですか？", 4 + 32, "Cells給与パス") <> 6 Then Exit Sub
    End If
    MyF = ThisWorkbook.Path & "\MyTool\CKyuyoP.dat"
    Open MyF For Output As #1
        Write #1, TextBox1.Value
    Close #1
    Workbooks("DaMenu.xls").Worksheets("処理選択").Cells(301, 15).Value = TextBox1.Value
    MsgBox "登録しました。", 64, "Cells給与パス"
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    Dim MyStr, TextFilename As String
    TextFilename = ThisWorkbook.Path & "\MyTool\CKyuyoP.dat"
    If "CKyuyoP.dat" = Dir(TextFilename) Then
        Open TextFilename For Input As #1
            Input #1, MyStr
            TextBox1.Value = MyStr
        Close #1
    End If
End Sub


Attribute VB_Name = "frmFile"
Attribute VB_Base = "0{FE251153-CC6B-4582-8FF1-86C0BE4D8DF7}{1F9FF10E-05DF-419D-B0DE-1917361BDA17}"
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 myPath  As String

Private Sub cmdSansyo_Click()
    Dim myMsg   As String
    
    myMsg = "ユーザーファイルを指定してください。"
    If GetFolder(myMsg, myPath) = True Then
        Call LstUp(myPath)
    End If
 End Sub
Sub LstUp(lstNam As String)
    Dim ファイル名  As String
    
    ListBox1.Clear
    ファイル名 = Dir(lstNam & "\", vbDirectory)
    ' 現在のフォルダと親フォルダは無視します。
    With ListBox1
        Do While ファイル名 <> ""
            If ファイル名 <> "." And ファイル名 <> ".." Then
                If ファイル名 Like "*.xls" Or ファイル名 Like "*.doc" Then
                    .AddItem ファイル名
                End If
            End If
            ファイル名 = Dir()
        Loop
    End With
End Sub

Private Sub cmdUp_Click()
    Dim iCnt        As Integer
    Dim lFlg        As Boolean
    Dim strPathName As String
    Dim myFSO       As Object
    
    lFlg = False
    strPathName = Dir(ThisWorkbook.Path & "\Da保存", 16)
    If strPathName = "" Then
        MkDir ThisWorkbook.Path & "\Da保存"
    End If
    strPathName = Dir(ThisWorkbook.Path & "\Da保存\ユーザーフォルダ", 16)
    If strPathName = "" Then
        MkDir ThisWorkbook.Path & "\Da保存\ユーザーフォルダ"
    End If
    
    With ListBox1
        For iCnt = 0 To .ListCount - 1
            If .Selected(iCnt) = True Then
                Set myFSO = CreateObject("scripting.filesystemobject")
                myFSO.CopyFile myPath & "\" & ListBox1.List(iCnt), ThisWorkbook.Path & "\Da保存\ユーザーフォルダ\"
                
                Set myFSO = Nothing
                lFlg = True
            End If
        Next iCnt
    End With
    If lFlg = False Then
        MsgBox "ファイルを選択してください。", vbInformation, "ユーザーファイルの取込"
        Exit Sub
    End If
    Unload Me
End Sub


Attribute VB_Name = "up"
Attribute VB_Base = "0{C0BCC6A5-4697-487A-83E6-29D01E06E451}{59B7FBDA-CE17-4780-9405-E0ED0AED27C4}"
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 Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const URL_STRING As String = "http://www.team-cells.jp/dl/daityo/"
Private Sub UserForm_Initialize()
    
    Application.ScreenUpdating = True

End Sub
''' 21064 20130214
Private Sub CommandButton1_Click()

    Dim ret As Long
    
    Dim FromFileString As String
    Dim ToFileString As String
   
    Dim downloadPath As String
    Dim folderName As String
    Dim fileName As String
    
    If MsgBox("ファイルを取り込みますか？", 1 + 32, Ltitle) <> 1 Then Exit Sub

'テキストボックスにいれたパスワードのフォルダがダウンロード先のフォルダにあるか調べる
    
    downloadPath = PathCombine(Environ("TEMP"), TextBox1.Value)
    folderName = Dir(downloadPath, vbDirectory)
    If folderName <> "" Then
        'フォルダをリネーム
        Randomize
        Name downloadPath As downloadPath & Minute(Time) & Second(Time) & Int(Rnd * 10000)
    End If
    
    'フォルダを作成
    MkDir downloadPath
        
    up.Caption = "ダウンロード中…"
'28186 hara 20150721 start
'zipファイルに変更によりコメントアウト
'    FromFileString = URL_STRING & TextBox1.Value & ".exe" 'URL
'    ToFileString = PathCombine(Environ("TEMP"), TextBox1.Value & ".exe") '書庫ファイルのダウンロード先

    FromFileString = URL_STRING & TextBox1.Value & ".zip" 'URL
    ToFileString = PathCombine(downloadPath, TextBox1.Value & ".zip") '書庫ファイルのダウンロード先
    
    On Error Resume Next
    ret = URLDownloadToFile(0, FromFileString, ToFileString, 0, 0)
    On Error GoTo 0
    
    If ret <> 0 Then
       MsgBox "エラー：パスワードが一致していません。又はインターネット接続に失敗しました。", 64, Ltitle
       up.Caption = "台帳ファイル取込"
       Exit Sub
    End If

    ret = DeleteUrlCacheEntry(FromFileString) 'キャッシュ削除
    
    If ret = 0 Then
        If sGetErrMsg <> 2 Then
            MsgBox "キャッシュ削除でエラーが発生しました。", vbInformation + vbOKOnly, "ダウンロード"
            Exit Sub
        End If
    End If
'zipファイルに変更によりコメントアウト
    '解凍する
'    ret = ShellExecute(0, "Open", ToFileString & vbNullString, _
'             vbNullString, vbNullString, SW_SHOWNORMAL)
    'zipファイルの解凍
    Dim objFile As Object
    Dim objDestination As Object
    Dim objShell As Object
    Dim zipFile As Variant      'zipファイルのフルパス(string型だとエラーが出る)
    Dim unzipFolder As Variant  '解凍先のフォルダ(string型だとエラーが出る)
    
    zipFile = ToFileString
    unzipFolder = downloadPath
    
    Set objShell = CreateObject("Shell.Application")
    Set objFile = objShell.Namespace(zipFile)
    Set objDestination = objShell.Namespace(unzipFolder)
    
    objDestination.CopyHere objFile.Items
    
    '入替の場合
    fileName = Dir(downloadPath & "\Update.xls")
    If fileName <> "" Then
        Workbooks.Open (downloadPath & "\Update.xls")
    End If
    
    'バージョンアップの場合
    fileName = Dir(downloadPath & "\バージョンアップ.xls")
    If fileName <> "" Then
        Workbooks.Open (downloadPath & "\バージョンアップ.xls")
    End If
'28186 hara end
    Application.DisplayAlerts = (False)        'メッセージ非表示
    Unload Me

End Sub
''' END 21064
Function sGetErrMsg() As Long

   Dim lngResult As Long, ErrorCode As Long, ErrBuffer As String

   ErrBuffer = String$(256, vbNullChar)
   ErrorCode = Err.LastDllError
   lngResult = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, _
   ByVal 0&, ErrorCode, 0&, ErrBuffer, Len(ErrBuffer), 0&)
   ErrBuffer = Left$(ErrBuffer, InStr(ErrBuffer, vbNullChar) - 1)
   
'   MsgBox "エラーコード： " & ErrorCode & vbLf & ErrBuffer, _
   vbInformation, "GetLastError"
'   Cells(13, 6).Value = ErrorCode
'    th.Cells(8, 10).Value = ErrorCode
    sGetErrMsg = ErrorCode
    
End Function

Attribute VB_Name = "ファイルリスト"
Attribute VB_Base = "0{FA7626AB-EF65-46DD-85BF-A939E0BBCA89}{4582287A-5A14-4231-9315-310C32B50B2B}"
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 myBar As Variant


Private Sub CommandButton5_Click()
If ListBox1.ListIndex = -1 Then Exit Sub
ListBox1.RemoveItem ListBox1.ListIndex
End Sub

Private Sub CommandButton6_Click()
    Dim Fnum         As Integer
    Dim iCnt         As Integer
    Dim C            As Range
    Dim MyBuf        As String
    Dim MyF          As String
    
    If ComboBox1.ListIndex = -1 Then Exit Sub
    MyF = ThisWorkbook.Path & "\MyTool\FileList" & ComboBox1.Value & ".dat"
    Open MyF For Output As #1
    For iCnt = 0 To ListBox1.ListCount - 1
        Write #1, ListBox1.List(iCnt, 0)
    Next
    Close #1
    MsgBox "リストパターン" & ComboBox1.Value & "で登録しました。", 64, Ltitle
End Sub

Private Sub CommandButton8_Click()
    Dim iCnt    As Integer
    If ListBox2.ListIndex = -1 Then
        MsgBox "移動する台帳ファイルを選択してください。", 16, Ltitle
        Exit Sub
    End If
    For iCnt = 0 To ListBox1.ListCount - 1
        If ListBox2.Value = ListBox1.List(iCnt, 0) Then
            MsgBox "このファイルはすでに登録されています。", 16, Ltitle
            Exit Sub
        End If
    Next
    ListBox1.AddItem ListBox2.Value
End Sub
Private Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    CommandButton8_Click
End Sub

Private Sub UserForm_Activate()
    Dim ファイル名  As String
    Dim iCnt        As Integer
    
    ファイル名 = Dir(Workbooks("DaMenu.xls").Path & "\*da.xls") '台帳ファイル
    Do While ファイル名 <> "" 'ファイルなくなるまで
        ListBox2.AddItem Left(ファイル名, Len(ファイル名) - 6)
        ファイル名 = Dir()
    Loop
    For iCnt = 1 To 5
        ComboBox1.AddItem iCnt
    Next
    ComboBox1.Value = 1
End Sub
Private Sub ComboBox1_Change()
    Dim TextFilename As String
    Dim MyData(1) As String
    
    ListBox1.Clear
    TextFilename = ThisWorkbook.Path & "\MyTool\FileList" & ComboBox1.Value & ".dat"
    Open TextFilename For Input As #1
    Do Until EOF(1)
    Input #1, MyData(1)
    ListBox1.AddItem MyData(1)
    Loop
    Close #1
End Sub

Private Sub CommandButton1_Click()
    On Error Resume Next
    Dim MyData As String
    Dim n As Long
    With ファイルリスト.ListBox1
        n = .ListIndex
        If n <= 0 Then Exit Sub
        If .ListCount < 2 Then Exit Sub
        MyData = .Value
        .RemoveItem .ListIndex
        .AddItem MyData, 0
        .ListIndex = 0
    End With
End Sub
Private Sub CommandButton2_Click()

    On Error Resume Next
    Dim MyData As String
    Dim n As Long
    With ファイルリスト.ListBox1
        n = .ListIndex
        If n <= 0 Then Exit Sub
        If .ListCount < 2 Then Exit Sub
        MyData = .Value
        .RemoveItem .ListIndex
        .AddItem MyData, n - 1
        .ListIndex = n - 1
    End With
End Sub
Private Sub CommandButton3_Click()
    On Error Resume Next
    Dim MyData As String
    Dim n As Long
    With ファイルリスト.ListBox1
        n = .ListIndex
        If n = -1 Then Exit Sub
        If n = .ListCount - 1 Then Exit Sub
        If .ListCount < 2 Then Exit Sub
        MyData = .Value
        .RemoveItem .ListIndex
        .AddItem MyData, n + 1
        .ListIndex = n + 1
    End With
End Sub
Private Sub CommandButton4_Click()
    On Error Resume Next
    Dim MyData As String
…