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


Attribute VB_Name = "frm送信"
Attribute VB_Base = "0{0351559F-6D56-4582-8627-414382533670}{20B985E2-813E-48D3-AD77-C2E81174DE73}"
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 CommandButton10_Click()
'20070510 kon
    Dim MyF As String
    
    If ListBox2.ListIndex = -1 Then
        MsgBox "リストが選択されていません。", 16, "メール送信"
        Exit Sub
    End If
    If Trim(TextBox4.Value) = "" Then
        MsgBox "送信先のアドレスを入力して下さい。", 16, "メール送信"
        Exit Sub
    End If
    If MsgBox("送信しますか？", 1 + 32, "メール送信") <> 1 Then Exit Sub
    Application.ScreenUpdating = False
    
'20070510 kon
    MyF = ThisWorkbook.Path & "\MyTool\Address.dat"
    Open MyF For Output As #1
    Write #1, TextBox4.Value
    Close #1
    
'
'    ThisWorkbook.Worksheets("ツール").Cells(6, 24).Value = TextBox4.Value
'    ThisWorkbook.Save
    
    '2007の時別の方法で
    If Application.Version = "12.0" Then
        Application.DisplayAlerts = False
        Workbooks.Open Workbooks("DaMenu.xls").Path & "\" & ListBox2.Value & "da.xls"
'        Application.Dialogs(xlDialogSendMail).Show
        ActiveWorkbook.SendMail Recipients:=TextBox4.Value
        Workbooks(ListBox2.Value & "da.xls").Close
        Application.DisplayAlerts = True
  
    Else
        OESendMail TextBox4.Value, "台帳 " & ListBox2.Value & "の送信", , Workbooks("DaMenu.xls").Path & "\" & ListBox2.Value & "da.xls"
    End If
    
    Application.ScreenUpdating = True

End Sub

Private Sub CommandButton11_Click()
    If ListBox2.ListIndex = -1 Then
        MsgBox "リストが選択されていません。", 16, "メール送信"
        Exit Sub
    End If
    
    If MsgBox("送信しますか？", 1 + 32, "メール送信") <> 1 Then Exit Sub
    Application.ScreenUpdating = False
        '2007の時別の方法で
    If Application.Version = "12.0" Then
        Application.DisplayAlerts = False
        Workbooks.Open Workbooks("DaMenu.xls").Path & "\" & ListBox2.Value & "da.xls"
        ActiveWorkbook.SendMail Recipients:="info@cells.co.jp"
        Workbooks(ListBox2.Value & "da.xls").Close
        Application.DisplayAlerts = True
  
    Else
        OESendMail "info@cells.co.jp", "台帳 " & ListBox2.Value & "の送信", , Workbooks("DaMenu.xls").Path & "\" & ListBox2.Value & "da.xls"
    End If
    
    Application.ScreenUpdating = True

End Sub

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

End Sub

Private Sub UserForm_Initialize()
    Dim fName       As String
    Dim ファイル名  As String
    '200705010 kon
    Dim TextFilename As String
    Dim MyStr As String
    
    Application.ScreenUpdating = False
    
    ファイル名 = Dir(Workbooks("DaMenu.xls").Path & "\*da.xls")
    ListBox2.Clear
    Do While ファイル名 <> ""
        With ListBox2
            .AddItem Left(ファイル名, Len(ファイル名) - 6)
            ファイル名 = Dir()
        End With
    Loop

    '200705010 kon
    TextFilename = ThisWorkbook.Path & "\MyTool\Address.dat"
    If Dir(TextFilename, vbNormal) <> "" Then
        Open TextFilename For Input As #1
            Input #1, MyStr
            TextBox4.Value = MyStr
        Close #1
    End If
'    TextBox4.Text = Worksheets("ツール").Cells(6, 24).Value

    Application.ScreenUpdating = True
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
'******************************************************************************************************************
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" _
                (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            'フォルダのみ選択可能
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

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
        .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
    
    Windows("DaMenu.xls").Activate
    Sheets("MENU").Select
    
    ThisWorkbook.Activate
    MsgBox "率表を切替えました。台帳を終了すると元に戻ります。", vbInformation, "率表切替"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

Attribute VB_Name = "fJyoho"
Attribute VB_Base = "0{64CF690E-A40B-4B85-BABB-2694D7E2B36B}{81AB9321-2F0E-49F7-9E59-E896AEB9CA40}"
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 Commandキャンセル_Click()
    Unload Me
End Sub

Private Sub Command読込_Click()
    Dim Ret     As Long
    Dim fPath   As String
    Dim iCnt    As Long
    Dim hwnd    As Long
    Dim wk      As Workbook
    Dim sCnt    As Integer
    
    lblCnt.Caption = ""
    If optF1.Value = True Then
        fPath = Workbooks("DaMenu.xls").Path
    ElseIf optF2.Value = True Then
        fPath = ThisWorkbook.Path
    Else
        MsgBox "確認するファイルの種類を選択してください。", vbInformation, "ファイルの情報"
    End If
    
    For iCnt = 0 To ListBox1.ListCount
        If ListBox1.Selected(iCnt) = True Then
            fPath = fPath & "\" & ListBox1.List(iCnt)
    
            Exit For
        End If
    Next iCnt
    
    If Dir(fPath, vbNormal) = "" Then
        MsgBox "ファイルを選択してください。", vbInformation, "指定ファイル情報"
        Exit Sub
    End If
    
    hwnd = GetActiveWindow() 'ウインドウハンドル取得

    Ret = ShowPropertiesDialog(hwnd, fPath)
    
    Application.ScreenUpdating = False
    Set wk = Workbooks.Open(fPath, False, True)
    sCnt = wk.Worksheets.Count
    wk.Close False
    Application.ScreenUpdating = True
    lblCnt.Caption = ListBox1.List(iCnt) & "の　シート数は　" & sCnt & "　です。"
    If Ret <= 32 Then
        MsgBox "プロパティが表示できませんでした。", vbInformation, "指定ファイル情報"
    End If

End Sub

Private Sub optF1_Click()
    Call LstUp(Workbooks("DaMenu.xls").Path)
End Sub

Private Sub optF2_Click()
    Call LstUp(ThisWorkbook.Path)
End Sub

Sub LstUp(lstNam As String)
    Dim ファイル名  As String
    
    ListBox1.Clear
    ファイル名 = Dir(lstNam & "\", vbDirectory)
    
    ' 現在のフォルダと親フォルダは無視します。
    With ListBox1
 
        Do While ファイル名 <> ""
            If ファイル名 <> "." And ファイル名 <> ".." Then
                If ファイル名 = ThisWorkbook.Name Or ファイル名 Like "DaMenu*" Then
                Else
                    If optF1.Value = True Then
                        If ファイル名 Like "*da.xls" Then
                            .AddItem ファイル名
                        End If
                    Else
                        If ファイル名 Like "*.xls" Or ファイル名 Like "*.doc" Or ファイル名 Like "*.csv" Or ファイル名 Like "*.ccf" Or ファイル名 Like "*.xla" Then
                            .AddItem ファイル名
                        End If
                    End If
                End If
            End If
            ファイル名 = Dir()
        Loop
    End With
End Sub

Attribute VB_Name = "frmFile"
Attribute VB_Base = "0{054DC897-AEDD-43C1-872D-5E992C962D0D}{8EAB166A-F4AB-42B3-820C-E2F7E62B9743}"
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{79D53F1B-FB0E-4A61-A615-FB25AE35C1DD}{161563FC-A02E-4E3A-9F12-C2E40FB66F3C}"
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
   
    If MsgBox("ファイルを取り込みますか？", 1 + 32, Ltitle) <> 1 Then Exit Sub
    
    up.Caption = "ダウンロード中…"

    FromFileString = URL_STRING & TextBox1.Value & ".exe" 'URL
    ToFileString = PathCombine(Environ("TEMP"), TextBox1.Value & ".exe") '書庫ファイルのダウンロード先
    
    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
    
    '解凍する
    Ret = ShellExecute(0, "Open", ToFileString & vbNullString, _
             vbNullString, vbNullString, SW_SHOWNORMAL)
    
    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{7751568A-3ECC-4F1F-AE52-684E88E0E73F}{92FAFDFE-9DD3-47E5-8CE2-C3E3C0B4EAB6}"
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
    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
        .ListIndex = .ListCount - 1
    End With
End Sub


Attribute VB_Name = "Module3"
Option Explicit
Public Const Ltitle As String = "台帳ツール"

Public maxCnt          As Long
Public i               As Long
'　インストーラーを起動
Public Declare Function ImmConfigureIME Lib "imm32.dll" _
    Alias "ImmConfigureIMEA" _
    (ByVal hKL As Long, _
    ByVal hwnd As Long, _
    ByVal dwMode As Long, _
    lpdata As Any) As Long

Private frJ              As Integer
Private tsiz            As Integer

Private Const SE_ERR_NOASSOC As Long = 31
Private Const ERROR_FILE_NOT_FOUND As Long = 2
Public Sub 作成ファイルの取込()
    
    frmFile.Show
    
End Sub
Public Sub コンバート()
    
    Workbooks.Open PathCombine(Workbooks("DaMenu.xls").Path, "VerUp.xla")
    Application.Run "VerUp.xla!コンバート"
    
End Sub
Public Sub バージョンアップ()
    
    Workbooks.Open PathCombine(Workbooks("DaMenu.xls").Path, "VerUp.xla")
    Application.Run "VerUp.xla!バージョンアップ"

End Sub
Public Sub ファイルの情報()
    
    fJyoho.Show

End Sub
Public Sub ファイル送信()

    frm送信.Show

End Sub
Public Sub ユーザーファイル取込()
    
    frmFile.Show

End Sub
Public Sub バックアップ()
    
    frmバックアップ.Show

End Sub
Public Sub ファイル取込()
    
    frm取込.Show

End Sub
Public Sub 初期処理()  '20070509 kon
    
    ActiveSheet.Unprotect
    ActiveSheet.Shapes("CTL").Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:= _
        "http://www.team-cells.jp/dl/crossloopsetup.exe"
    Range("A1").Select
    ActiveSheet.Protect

End Sub
Public Sub ダウンロード()
    
    up.Show

End Sub
Public Sub リスト表示()
    
    ファイルリスト.Show

End Sub
Public Sub セルズフォント()

    Dim Ret     As Long
    
    If MsgBox("Cellsフォントをインストールしますか？", vbYesNo, "Cellsフォントのインストール") = vbYes Then
        If Dir(PathCombine(Workbooks("DaMenu.xls").Path, "CellsFontSetup.exe")) = "" Then
            MsgBox "フォントのインストールファイルが見つかりません。", vbInformation, "フォントのインストール"
        Else
        '台帳MENU・ツール・DaAddin.xlaを閉じる
            Ret = shell(PathCombine(Workbooks("DaMenu.xls").Path, "CellsFontSetup.exe"))
        End If
    End If


End Sub
Public Sub IME表示()

    Dim lngKeyboardLayoutHandle As Long
    Dim lngDisplayDialogboxType As Long
    Dim lngWin32apiResultCode   As Long
    Dim hwnd As Long
    
    ' カレントスレッドのキーボードレイアウトの
    ' ハンドルを取得
    hwnd = GetActiveWindow() 'ウインドウハンドル取得
    lngKeyboardLayoutHandle = GetKeyboardLayout(0)
    
    ' 表示するIMEプロパティダイアログのタイプを設定
    lngDisplayDialogboxType = IME_CONFIG_SELECTDICTIONARY
…