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 = "Sheet1"
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 = "添付"
Attribute VB_Base = "0{76F3190D-B773-45FE-BFF6-D4A052A38186}{2CCD5A81-005B-4A4B-BA21-05B89425710E}"
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 mHokenKbn As KB_HOKEN
Private mSinseiKbn As KEISIKI_SINSEI
Public mwb As Workbook
Private Cmd(0 To 9) As CAttachControl
Public Property Get SinseiKbn() As KEISIKI_SINSEI
    
    SinseiKbn = mSinseiKbn

End Property
Public Property Let SinseiKbn(ByVal vNewValue As KEISIKI_SINSEI)
    
    mSinseiKbn = vNewValue
    
End Property
Public Property Let HokenKbn(ByVal vNewValue As KB_HOKEN)
    
    mHokenKbn = vNewValue
    
End Property
Public Property Get HokenKbn() As KB_HOKEN
    
    HokenKbn = mHokenKbn

End Property
Private Sub UserForm_Initialize()

    Dim i As Long

    For i = 0 To 9
        Set Cmd(i) = New CAttachControl
        Cmd(i).PreviewButton = Me.Controls("cmdPre" & (i + 1))
        Cmd(i).TextObj = Me.Controls("Text" & (i + 1))
    Next i

End Sub
Private Sub UserForm_Activate()

        Dim i As Long
        With mwb.Worksheets("DATA")
            For i = 0 To 9
                If mSinseiKbn = KOBETU Then
                    Controls("Text" & i + 1).Value = .Cells(122 + i * 3, 2).Value
                ElseIf mSinseiKbn = HYOJYUN Then
                    Controls("Text" & i + 1).Value = .Cells(62 + i, 4).Value
                End If
            Next
        End With

End Sub
Private Sub CommandButton1_Click()

        Call ファイル開く(1)

End Sub
Private Sub CommandButton2_Click()

        Call ファイル開く(2)

End Sub
Private Sub CommandButton3_Click()

         Call ファイル開く(3)

End Sub
Private Sub CommandButton4_Click()

         Call ファイル開く(4)

End Sub
Private Sub CommandButton5_Click()

         Call ファイル開く(5)

End Sub
Private Sub CommandButton6_Click()

        Call ファイル開く(6)

End Sub
Private Sub CommandButton7_Click()

        Call ファイル開く(7)

End Sub
Private Sub CommandButton8_Click()

        Call ファイル開く(8)

End Sub
Private Sub CommandButton9_Click()

        Call ファイル開く(9)

End Sub
Private Sub CommandButton10_Click()

        Call ファイル開く(10)

End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

        Dim i As Long
        
        Application.Calculation = xlManual

        With mwb.Worksheets("DATA")
            If mSinseiKbn = KOBETU Then
                For i = 0 To 9
                    If Controls("Text" & i + 1).Value <> "" Then
                    .Cells(120 + i * 3, 2).Value = Dir(Controls("Text" & i + 1).Value)
                    .Cells(122 + i * 3, 2).Value = Controls("Text" & i + 1).Value
                    Else
                    .Cells(120 + i * 3, 2).ClearContents
                    .Cells(122 + i * 3, 2).ClearContents
                    End If
                Next
            ElseIf mSinseiKbn = HYOJYUN Then
                For i = 0 To 9
                    If Controls("Text" & i + 1).Value <> "" Then
                    .Cells(62 + i, 2).Value = Dir(Controls("Text" & i + 1).Value)
                    .Cells(62 + i, 4).Value = Controls("Text" & i + 1).Value
                    Else
                    .Cells(62 + i, 2).ClearContents
                    .Cells(62 + i, 4).ClearContents
                    End If
                Next
            End If
        End With
        
       Application.Calculation = xlAutomatic

End Sub
Private Sub ファイル開く(ByVal Box As String)

    Dim strFName As String

    strFName = Application.GetOpenFilename("(*.*),*.*")
    
    If strFName = "False" Then
        Exit Sub
    End If
    
    '拡張子検査
    Select Case mHokenKbn
        Case KB_HOKEN.SYAKAI
            If LCase(FileExtensionName(strFName)) <> "jpg" Then
                MsgBox "指定したファイルの拡張子はjpgではありません。", vbInformation + vbOKOnly, Me.caption
                Exit Sub
            End If
        Case KB_HOKEN.KOYO
'            If LCase(FileExtensionName(strFName)) <> "pdf" And LCase(FileExtensionName(strFName)) <> "doc" Then
'                MsgBox "指定したファイルの拡張子はpdfまたはdocではありません。", vbInformation + vbOKOnly, Me.Caption
'                Exit Sub
'            End If
        Case KB_HOKEN.Roudo
            If LCase(FileExtensionName(strFName)) <> "pdf" Then
                MsgBox "指定したファイルの拡張子はpdfではありません。", vbInformation + vbOKOnly, Me.caption
                Exit Sub
            End If
        Case Else
            Exit Sub
    End Select
    
    Controls("Text" & Box).Value = strFName
    同名ファイルチェック Dir(Controls("Text" & Box).Value), Box
    
End Sub
Private Sub 同名ファイルチェック(ByVal FileName As String, ByVal no As String)

    Dim i As Long
    Dim MsgStr As String
    
    '初期化
    MsgStr = vbNullString
    
    For i = 1 To 10
        If i <> no Then '同じテキストボックスだったら何もしない
                
            ''' 20101021 YB 2313 型が一致しませんエラー
            If Controls("Text" & i).Value <> "" Then
                If Dir(Controls("Text" & i).Value) = FileName Then
                    MsgStr = "同じファイル名の添付ファイルが存在しているため指定できません。"
                    Exit For
                End If
            End If
            
            If Worksheets("DATA").Cells(3, 2).Value <> "" Then
                If Dir(Worksheets("DATA").Cells(3, 2).Value) = FileName Then
                    MsgStr = "提出代行証明書と同じファイル名のため指定できません。"
                    Exit For
                End If
            End If
            
            ''' 20101021 YB 2313 型が一致しませんエラー
            If mwb.Worksheets("DATA").Cells(4, 2).Value <> "" Then
                If Dir(Worksheets("DATA").Cells(4, 2).Value) = FileName Then
                    MsgStr = "提出代行証明書と同じファイル名のため指定できません。"
                    Exit For
                End If
            End If
            
            If mwb.Worksheets("DATA").Cells(5, 2).Value <> "" Then
                If Dir(Worksheets("DATA").Cells(5, 2).Value) = FileName Then
                    MsgStr = "提出代行証明書と同じファイル名のため指定できません。"
                    Exit For
                End If
            End If
                
        End If
    Next
                 
    If MsgStr <> vbNullString Then
        MsgBox MsgStr, vbInformation + vbOKOnly, Me.caption
        Controls("Text" & no).Value = ""
    End If
                 
End Sub

Attribute VB_Name = "CommonModule"
Option Explicit
Private Declare Function SHCreateDirectoryEx Lib _
    "SHELL32" Alias "SHCreateDirectoryExA" ( _
    ByVal hwnd As Long, _
    ByVal pszPath As String, _
    ByVal psa As Long) As Long
Private Declare Function ShellExecute Lib _
    "SHELL32" Alias "ShellExecuteA" ( _
    ByVal hwnd&, _
    ByVal lpOperation$, _
    ByVal lpFile$, _
    ByVal lpParameters$, _
    ByVal lpDirectory$, _
    ByVal nShowCmd&) As Long
Private Const SW_NORMAL = 1
'''
' IsExistFolder
' フォルダの有無を返す
' Flgを設定すると無い場合作る
'
'''
Public Function IsExistFolder(ByVal PathString As String) As Boolean

    Dim ret As Long

    ret = SHCreateDirectoryEx(0&, PathString, 0&)
    
    If ret = 0 Or ret = 80 Or ret = 183 Then
        IsExistFolder = True
    Else
        IsExistFolder = False
    End If

End Function
'''
' 関連付けられたアプリケーションでファイルを開く
'
'''
Public Function ShellExec(ByVal FileName As String) As Boolean

    Dim ret As Boolean

    ret = ShellExecute(0, "open", FileName, vbNullString, Environ("windir"), SW_NORMAL)

    ShellExec = ret > 32

End Function
'''
'
'パスの連結
'
'''
Public Function PathCombine(ByVal str1 As String, ByVal str2 As String) As String

    If VBA.Strings.Right(str1, 1) = "\" Then
        PathCombine = str1 & str2
    Else
        PathCombine = str1 & "\" & str2
    End If

End Function
'''
'
' ファイルの存在確認
'
'''
Public Function IsFileExist(ByVal FileName As String) As Boolean

    Dim FilePath As String
    Dim fso As Object

    Set fso = CreateObject("Scripting.FileSystemObject")

    IsFileExist = fso.fileExists(FileName)
    
    Set fso = Nothing

End Function
'''
'
' ファイルの拡張子を調べる
'
'''
Public Function FileExtensionName(ByVal FileName As String) As String

    Dim fso As Object

    Set fso = CreateObject("Scripting.FileSystemObject")

    FileExtensionName = fso.GetExtensionName(FileName)
    
    Set fso = Nothing

End Function
'''
'
' UNCパスかどうか調べる
'
'''
Public Function IsUNC(ByVal PathName As String) As Boolean

    Dim ret As Boolean

    ret = False

    If Left(PathName, 2) = "\\" Or Left(PathName, 7) = "file://" Then
        ret = True
    End If

    IsUNC = ret

End Function
'''
'
' フォルダをコピーする
'
'''
Public Sub FolderCopy(ByVal FromFolder As String, ByVal ToFolder As String)
    
    Dim fso As Object

    Set fso = CreateObject("Scripting.FileSystemObject")

    fso.CopyFolder FromFolder, ToFolder
    
    Set fso = Nothing

End Sub
'''
'
' フォルダを削除する
'
'''
Public Sub FolderDelete(ByVal FolderName As String)

    Dim fso As Object

    Set fso = CreateObject("Scripting.FileSystemObject")

    fso.DeleteFolder FolderName
    
    Set fso = Nothing

End Sub
'''
'
' テキストデータを読み出す
'
'''
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
Private 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

Attribute VB_Name = "ApplyModule"
Option Explicit
Public Enum KB_HOKEN
    SYAKAI = 1
    KOYO = 2
    Roudo = 3
End Enum
Public Enum KEISIKI_SINSEI
    HYOJYUN = 1
    KOBETU = 2
End Enum
'''
''' 添付ファイル設定画面を表示する
'''
Public Function DisplayAttach(ByVal HokenKbn As KB_HOKEN, ByVal skb As KEISIKI_SINSEI, ByRef wb As Workbook) As Variant()

    Dim frm As New 添付

    frm.HokenKbn = HokenKbn
    frm.SinseiKbn = skb
    Set frm.mwb = wb

    frm.Show

End Function
'''
''' 指定した添付ファイルをプレビューする
'''
Public Function DispayAttachFile(ByVal FileName As String) As Boolean
   
    Dim ret As Boolean
   
    'ファイルがあるか？
    ret = IsFileExist(FileName)
    
    If ret Then
        'ファイルを開く
        ShellExec FileName
    End If
    
    DispayAttachFile = ret

End Function
'''
''' 添付ファイルデータのクリア
'''
Public Sub ClearAttachFile(ByRef ws As Worksheet)

    Dim Num As Long
    
    Num = 10 '添付ファイル画面の数

    ws.Range(ws.Cells(120, 2), ws.Cells(120 + 3 * (Num - 1) + 2, 2)).ClearContents

End Sub
'''
''' 会社情報のファイルがあるかどうか返す
'''
Public Function IsCompanyInfoFileExist(ByVal CompanyName As String) As String

    Dim FilePath As String

    FilePath = PathCombine(Workbooks("DaMenu.xls").Path, "DaProcess\MyTool\提出代行")
    FilePath = PathCombine(FilePath, CompanyName & ".txt")
    
    If IsFileExist(FilePath) Then
        IsCompanyInfoFileExist = FilePath
    Else
        IsCompanyInfoFileExist = vbNullString
    End If

End Function
'''
''' 申請者情報のファイルがあるかどうか返す
'''
Public Function IsApplicantInfoFileExist(ByVal DaFileName As String) As String

    Dim lAppInfoNo As Long
    Dim FilePath As String
    
    lAppInfoNo = Workbooks(DaFileName).Worksheets("会社情報").Cells(86, 2).Value
    
    If lAppInfoNo = 0 Then lAppInfoNo = 1
    
    FilePath = PathCombine(Workbooks("DaMenu.xls").Path, "DaProcess\Da保存\電子申請申請者\申請者情報" & lAppInfoNo & ".txt")

    If IsFileExist(FilePath) Then
        IsApplicantInfoFileExist = FilePath
    Else
        IsApplicantInfoFileExist = vbNullString
    End If

End Function
'''
''' 提出先コードがあるかどうか返す
'''
Public Function SubmittedCodeCheck(ByRef wb As Workbook, ByVal target As String) As String

    Dim i As Long
    Dim ret As String

    Application.Calculation = xlCalculationManual
    
    Workbooks.Open PathCombine(wb.Path, "提出先一覧.xls")
    
    For i = 1 To Cells(1005, 7).End(xlUp).Row
        If target = Cells(i, 7).Value Then
            ret = Cells(i, 6).Value
            Exit For
        End If
    Next
    
    Workbooks("提出先一覧.xls").Close False
    
    Application.Calculation = xlCalculationAutomatic

    SubmittedCodeCheck = ret

End Function
'''
''' CSV形式のマスター画面の入力項目をチェックする
'''
Public Function CSVMasterCheck(ByRef frm As MSForms.UserForm) As Boolean

    Dim ret As Boolean
    
    ret = False

    With frm

         '作成年月日
        If .Text1.Text = vbNullString Then
            MsgBox "作成年月日が不正です。", vbInformation + vbOKOnly, .caption
            CSVMasterCheck = ret
            Exit Function
        End If
        
        'FD通番
        If frm.Text2.Text = vbNullString Then
            MsgBox "FD通番が未入力です。", vbInformation + vbOKOnly, .caption
            CSVMasterCheck = ret
            Exit Function
        ElseIf Not IsNumeric(.Text2.Text) Then
            MsgBox "FD通番が不正です。", vbInformation + vbOKOnly, .caption
            CSVMasterCheck = ret
            Exit Function
        ElseIf CLng(.Text2.Text) < 1 Or CLng(.Text2.Text) > 999 Then
            MsgBox "FD通番は、1以上999以下です。", vbInformation + vbOKOnly, .caption
            CSVMasterCheck = ret
            Exit Function
        End If
        
        '提出先 TextBox1
        '提出先コード TextBox6
        If .TextBox1.Text = vbNullString Or .TextBox6 = vbNullString Then
            MsgBox "提出先または提出先コードが未設定です。", vbInformation + vbOKOnly, .caption
            CSVMasterCheck = ret
            Exit Function
        End If
        
        '会社データ TextBox2
        If .TextBox2.Text = vbNullString Then
            MsgBox "会社データが未設定です。", vbInformation + vbOKOnly, .caption
            CSVMasterCheck = ret
            Exit Function
        End If
    
        '申請者 TextBox3
        If .TextBox3.Text = vbNullString Then
            MsgBox "申請者が未設定です。", vbInformation + vbOKOnly, .caption
            CSVMasterCheck = ret
            Exit Function
        End If
    
        '社労士コード
        If .TextBox4.Text = vbNullString And Not .CheckBox1.Value Then
            MsgBox "社労士コードが未設定です。", vbInformation + vbOKOnly, .caption
            CSVMasterCheck = ret
            Exit Function
        End If
        
        '提出代行
        If .TextBox5.Text = vbNullString And Not .CheckBox1.Value Then
            MsgBox "提出代行が未設定です。", vbInformation + vbOKOnly, .caption
            CSVMasterCheck = ret
            Exit Function
        ElseIf Not IsFileExist(.TextBox5.Text) And Not .CheckBox1.Value Then
            MsgBox "提出代行ファイルが見つかりません。", vbInformation + vbOKOnly, .caption
            CSVMasterCheck = ret
            Exit Function
        End If
    
    End With

    ret = True
    
    CSVMasterCheck = ret

End Function
'''
''' 社会保険仕様チェックプログラムを起動する
'''
Public Sub SICheckProc(ByVal CSVFolder As String, ByVal flg As Boolean, ByRef wb As Workbook)
    
    Dim TempFolder As String

    TempFolder = PathCombine(Environ("TEMP"), "Cells")

    '必要なフォルダを用意する
    IsExistFolder TempFolder

    FolderCopy CSVFolder, TempFolder & "\"
    
    CheckProguramProc PathCombine(TempFolder, wb.Worksheets("DATA").Cells(26, 2).Value), flg, wb.Worksheets("DATA").Cells(2, 2).Value
    
    CopyText PathCombine(TempFolder, wb.Worksheets("DATA").Cells(26, 2).Value)
    
End Sub
'''
''' CSVファイルを作る
'''
Public Function CreateCSVFile(ByRef wb As Workbook) As String

    Dim SHFDFolder As String
    
    SHFDFolder = PathCombine(PathCombine(wb.Path, "SHFD0006"), wb.Worksheets("DATA").Cells(26, 2).Value)
    IsExistFolder SHFDFolder
    
    SHFD0006作成 PathCombine(SHFDFolder, "SHFD0006.csv"), wb
    
    wb.Worksheets("社ＣＳＶ").Select
    wb.Worksheets("DATA").Cells(15, 2).Value = "作成済"
    
    CreateCSVFile = SHFDFolder

End Function
'''
''' CSVファイルを消す
'''
Public Sub DeleteCSVFile(ByRef wb As Workbook)

    Dim SHFDFolder As String
    
    SHFDFolder = PathCombine(PathCombine(wb.Path, "SHFD0006"), wb.Worksheets("DATA").Cells(26, 2).Value)
    IsExistFolder SHFDFolder
    
    If IsFileExist(PathCombine(SHFDFolder, "SHFD0006.csv")) Then
        Kill PathCombine(SHFDFolder, "SHFD0006.csv")
    End If
    
    Dim TempFolder As String

    TempFolder = PathCombine(PathCombine(Environ("TEMP"), "Cells"), wb.Worksheets("DATA").Cells(26, 2).Value)
    
    If IsExistFolder(TempFolder) Then
        FolderDelete TempFolder
    End If
    
End Sub
'''
''' CSVを作る
'''
Private Sub SHFD0006作成(ByVal FileName As String, ByRef wb As Workbook)

    Dim MyBuf() As String
    Dim Ro As Long
    Dim k As Long
    Dim EndR As Long
    Dim C As Range
    Dim Fnum As Integer
    Dim n As Long
        
    If FileName = vbNullString Then Exit Sub
    
    'wb.Sheets("SHFD0006").Select
    
    EndR = wb.Sheets("SHFD0006").Cells(65536, 1).End(xlUp).Row

    n = 1
    For Ro = 1 To EndR
        ReDim Preserve MyBuf(n)
        
        For Each C In Range(wb.Sheets("SHFD0006").Cells(Ro, 1), wb.Sheets("SHFD0006").Cells(Ro, 256).End(xlToLeft))
            If C.Column = 1 Then
                MyBuf(n) = C.Value
            ElseIf C.Value = "Q" Then
            Else
                If n = 3 Then
                    '事業所数は強制的に1件とする
                    MyBuf(n) = MyBuf(n) & "," & "001"
                Else
                    MyBuf(n) = MyBuf(n) & "," & C.Value
                End If
            End If
        Next C
        n = n + 1
    Next Ro

    If n <= 6 Then
    Else
        Fnum = FreeFile()
        Open FileName For Output As #Fnum
            For k = LBound(MyBuf) To UBound(MyBuf)
                If k = 0 Then
                Else
                    Print #Fnum, MyBuf(k)
                End If
            Next k
        Close #Fnum

    End If

    Erase MyBuf

End Sub



Attribute VB_Name = "CAttachControl"
Attribute VB_Base = "0{FCFB3D2A-A0FA-1068-A738-08002B3371B5}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit
Private Const MSG_FILE_NOT_FOUND As String = "ファイルが見つかりません。"
Private Const ME_CAPTION As String = "添付ファイル"

Private WithEvents mPreviewButton As MSForms.CommandButton
Attribute mPreviewButton.VB_VarHelpID = -1
Private WithEvents mTextBox As MSForms.TextBox
Attribute mTextBox.VB_VarHelpID = -1
Private mName As String
Public Property Let PreviewButton(ByRef CmdObject As MSForms.CommandButton)

    Set mPreviewButton = CmdObject

End Property
Public Property Let TextObj(ByRef TextObject As MSForms.TextBox)

    Set mTextBox = TextObject

End Property
Private Sub mPreviewButton_Click()
        
    If Not DispayAttachFile(mTextBox.Text) Then
        MsgBox MSG_FILE_NOT_FOUND, vbInformation + vbOKOnly, ME_CAPTION
    End If

End Sub


Attribute VB_Name = "eGov"
Attribute VB_Base = "0{8C7B9183-1683-4560-BEE4-B09E0B13CAD3}{06862BE1-9DF7-4062-8D16-8AC1B03C7142}"
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
Public Enum InsuranceCategoryData
    Syaki = 1
    Koyou = 2
    Roudo = 3
End Enum
Private meGovTargetFile As String ''' 対象となるeGovフォルダ内のファイル名
Private meGovOldTargetFile As String ''' 旧申請用
Private mDaFileName As String ''' Daファイルの名前
Private mIC As InsuranceCategoryData
Public Property Get InsuranceCategory() As InsuranceCategoryData
        
    InsuranceCategory = mIC
        
End Property
Public Property Let InsuranceCategory(ByVal Value As InsuranceCategoryData)
        
    mIC = Value

End Property
Public Property Get eGovTargetFile() As String
        
    eGovTargetFile = meGovTargetFile
        
End Property
Public Property Let eGovTargetFile(ByVal Value As String)
        
    meGovTargetFile = Value

End Property
Public Property Get eGovOldTargetFile() As String

    eGovOldTargetFile = meGovOldTargetFile

End Property
Public Property Let eGovOldTargetFile(ByVal Value As String)

    meGovOldTargetFile = Value

End Property
Public Property Get DaFileName() As String
        
    DaFileName = mDaFileName
        
End Property
Public Property Let DaFileName(ByVal Value As String)
        
    mDaFileName = Value

End Property
Private Sub cmdNewApply_Click()

    Dim wb As Workbook
        
    '既に開いているかどうか調べる
    For Each wb In Workbooks
        If wb.Name = meGovTargetFile Then
            '開いていたので終わる
            DoEvents
            wb.Activate
            Exit Sub
        End If
    Next wb
        
    Application.Run "DaAddin.xla!OpenWorkbookActive", ThisWorkbook.Path & "\" & meGovTargetFile
        
'    Workbooks.Open ThisWorkbook.Path & "\" & meGovTargetFile
'
'    Set wb = Workbooks(meGovTargetFile)
'
'    ThisWorkbook.Activate
'    DoEvents
'    wb.Activate
    
    Worksheets("DATA").Cells(1, 1).Value = mDaFileName
    
    Application.Run ActiveWorkbook.Name & "!初期処理"
    
    Unload Me

End Sub
Private Sub cmdOldApply_Click()

    Dim strPath As String
    Dim strDaProcessPath As String
    
    strDaProcessPath = PathCombine(Workbooks("DaMenu.xls").Path, "DaProcess")
    
    Select Case mIC
        Case InsuranceCategoryData.Syaki
            strPath = PathCombine(PathCombine(strDaProcessPath, "社会保険電子申請ツール"), meGovOldTargetFile)
        Case InsuranceCategoryData.Koyou
            strPath = PathCombine(PathCombine(strDaProcessPath, "雇用保険電子申請ツール"), meGovOldTargetFile)
        Case InsuranceCategoryData.Roudo
            MsgBox "TODO:これから作る"
            Exit Sub
        Case Else
            MsgBox "これがでるケースはエラー"
            Exit Sub
    End Select
    
    Application.Run "DaAddin.xla!OpenWorkbookActive", strPath
    
'    Workbooks.Open strPath
    Workbooks(meGovOldTargetFile).Worksheets("DATA").Cells(1, 1).Value = mDaFileName
    Workbooks(meGovOldTargetFile).Worksheets("DATA").Cells(8, 2).Value = strDaProcessPath
    
    Application.Run meGovOldTargetFile & "!初期処理"
    Unload Me
    
    
    
'    ThisWorkbook.Activate

End Sub

Attribute VB_Name = "eGovModule"
Option Explicit
Public Sub eGovFormShow(ByVal ic As InsuranceCategoryData, ByVal eGovTargetFile As String, ByVal eGovOldTargetFile As String, ByVal DaFileName As String)

    Dim frm As New eGov
    
    frm.InsuranceCategory = ic
    frm.eGovTargetFile = eGovTargetFile
    frm.eGovOldTargetFile = eGovOldTargetFile
    frm.DaFileName = DaFileName

    frm.Show vbModeless

End Sub

Attribute VB_Name = "InstallModule"
Option Explicit
'ShellExecuteEXで使用する構造体
Private Type SHELLEXECUTEINFO
    cbSize As Long
    fMask As Long
    hwnd As Long
    lpVerb As String
    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
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function ShellExecuteEX Lib "shell32.dll" Alias "ShellExecuteEx" (SEI As SHELLEXECUTEINFO) As Long
Private Const SEE_MASK_NOCLOSEPROCESS = &H40
Private Const SW_SHOWNORMAL = 1
Private Const INFINITE = &HFFFF ' Infinite timeout
Private Const SE_ERR_NOASSOC = 31
Private Const ERROR_FILE_NOT_FOUND = 2
Private Const SIGN_EXE_PATH As String = "cells\台帳電子申請ツール\egov.dll"
Public Sub InstallEgovTool()

    Dim ret     As Long
    Dim str     As String
       
    'インストール
    
    str = PathCombine(VBA.Strings.Trim(Workbooks("DaMenu.xls").Path), "setup.exe")
    
    ret = InstallProc(str)   'インストール

    Select Case ret
        Case SE_ERR_NOASSOC
            MsgBox "一括申請ツールのインストールに失敗しました。", vbInformation, "一括申請ツール"
        Case ERROR_FILE_NOT_FOUND
            MsgBox "一括申請ツールのインストールが見つかりません。", vbInformation, "一括申請ツール"
    End Select

End Sub
Public Sub UninstallEgovTool()

    If Not IsToolsDate Then
        'アンインストール
        UninstallProc "7A6A1A67-9EFB-4185-8BA2-2734A5A29691"
        UninstallProc "6AA34833-9FA5-499B-8D61-E139D7084EBF" '1.90.38のアンインストール
        UninstallProc "ACA9BBC5-872A-48EB-90BE-6ACE7DD095C0" '2.00.03のアンインストール
        UninstallProc "611F478F-F48B-447B-9B92-C5669C0C1AEB" '2.00.31のアンインストール
        UninstallProc "AC0A53F6-FCBA-453E-A939-D432DE0A2AEA" '2.00.37(テスト用)のアンインストール
    End If

End Sub
Private Function UninstallProc(ByVal strPram As String) As Long

    Dim strPath As String

    strPath = PathCombine(Interaction.Environ("SYSTEMROOT"), "System32\msiexec.exe")

    UninstallProc = ShellExeWithWait(strPath, "/x {" & strPram & "} /passive /norestart")

End Function
Private Function InstallProc(ByVal strFilePath As String) As Long

    'InstallProc = ShellExeWithWait(strFilePath, "/qn")
    InstallProc = ShellExeWithWait(strFilePath, vbNullChar)

End Function
…