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 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
'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
'WaitForSingleObject
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
'WaitForSingleObjectで使用する定数
Private Const INFINITE = &HFFFF ' Infinite timeout
'ShellExecuteEXで使用する定数
Private Const SEE_MASK_NOCLOSEPROCESS = &H40

Private Const SW_SHOWNORMAL = 1
Private Const SE_ERR_NOASSOC = 31
Private Const ERROR_FILE_NOT_FOUND = 2
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    MsgBox "このファイルは保存できません。", vbCritical + vbOKOnly, "保存不可"
    Cancel = True
    
End Sub
Private Sub Workbook_Open()

    Dim strbuffer As String
    Dim nRet As Long

    If Not IsToolsDate Then
        If MsgBox("一括申請ツールがバージョンアップされていません。一括申請ツールをインストールしますか？", vbInformation + vbYesNo, "一括申請") = vbYes Then
            電子申請一括ツール
            Application.Run "DaAddin.xla!閉じる"
            Exit Sub
        Else
            MsgBox "一括申請ツールをバージョンアップする必要があります。メニューのツール画面から再度インストールをお願いいたします。"
            Application.Run "DaAddin.xla!閉じる"
            Exit Sub
        End If
    End If

    'レジストリに台帳パスを埋める(送信番号取得のため)
    strbuffer = Replace(ThisWorkbook.path, "\DaProcess", "")
    strbuffer = Replace(strbuffer, "\", "\\")

    nRet = XXX_SetRegistryString(HKEY_CURRENT_USER, "software\cells\daityo", "path", strbuffer)

    Dim strURL As String

    'If Range("K26").Value <> 1 Then
        XXX_SetRegistryString HKEY_CURRENT_USER, "software\cells\daityo", "url", LOGIN_URL
    'Else
        'XXX_SetRegistryString HKEY_CURRENT_USER, "software\cells\daityo", "url", TEST_URL
    'End If
    
    '''YBNO21642
    Application.Run "EAppCom.xla!TetsuzukiDB"
    '''END 21642

    #If DEBUG_MODE Then
        '1なら画面にテストモードと表示する
        Sheets("MENU").Unprotect
        Cells(6, 1).value = "テストモード"
        Sheets("MENU").Protect
    #Else
        Sheets("MENU").Unprotect
        Cells(6, 1).Clear
        Sheets("MENU").Protect
    #End If

    SearchSQL = vbNullString

End Sub
Private Function IsSansyo() As Boolean

    Dim Ref As Variant

    For Each Ref In ActiveWorkbook.VBProject.References
        If Ref.isbroken And Ref.GUID = "{05D7A42E-73F8-4A87-AF3F-8AAEF91CF810}" Then
            IsSansyo = False
            Exit Function
        End If
    Next Ref

    IsSansyo = True

End Function
Private Function IsToolsDate() As Boolean

    Dim ret As Boolean
    Dim fso As Object
    Dim FileName As String
    Dim objFile As Object
    
    ret = False
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    FileName = PathCombine(VBA.Interaction.Environ("ProgramFiles"), SIGN_EXE_PATH)
    
    If IsExist(FileName, False) Then
        Set objFile = fso.GetFile(FileName)
        'ツールが古い
        If CDate(objFile.DateCreated) > #3/1/2013 11:00:00 AM# Then
            ret = True
        Else
            ret = False
        End If
        Set objFile = Nothing
    End If

    Set fso = Nothing
    
    IsToolsDate = ret

End Function
Private Sub 電子申請一括ツール()

    Dim ret     As Long
    Dim str     As String
        
    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のアンインストール
    
    ret = InstallProc(VBA.Strings.Trim(Workbooks("DaMenu.xls").path) & "\setup.exe")
    
'    str = VBA.Strings.Trim(Workbooks("DaMenu.xls").path) & "\setup.exe"
'
'    ret = ShellExecute(0, "Open", str & vbNullString, vbNullString, vbNullString, SW_SHOWNORMAL)
    Select Case ret
        Case SE_ERR_NOASSOC
            MsgBox "一括申請ツールのインストールに失敗しました。", vbInformation, "一括申請ツール"
        Case ERROR_FILE_NOT_FOUND
            MsgBox "一括申請ツールのインストールが見つかりません。", vbInformation, "一括申請ツール"
    End Select

End Sub
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 = "open"
        .lpFile = Interaction.Environ("SYSTEMROOT") & "\System32\msiexec.exe"
        .lpParameters = "/x {" & strPram & "} /passive"
        .lpDirectory = vbNullChar
        .nShow = SW_SHOWNORMAL
        .hInstApp = 0
        .lpIDList = 0
    End With

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

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

    Dim ret     As Long
    Dim sdtSEXI As SHELLEXECUTEINFO

    With sdtSEXI
        .cbSize = Len(sdtSEXI)
        .fMask = SEE_MASK_NOCLOSEPROCESS
        .hwnd = Application.hwnd
        .lpVerb = "open"
        .lpFile = strFilePath
        .lpParameters = "/qn"
        .lpDirectory = vbNullChar
        .nShow = SW_SHOWNORMAL
        .hInstApp = 0
        .lpIDList = 0
    End With

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

End Function

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

Attribute VB_Name = "frmSearch"
Attribute VB_Base = "0{956E3C2A-B3C5-45C2-B95E-72244A66CE36}{AC9B5865-4A5A-47EA-81E3-BA10EFDAE79F}"
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 dbcon As New ADODB.Connection
Private dbRes As New ADODB.Recordset
Private Sub cmdSearch_Click()

   InitList

   Unload Me

End Sub
Private Sub UserForm_Initialize()

   'データベース変数初期化
   InitDBObject DB_PATH, dbcon

   InitDisp

End Sub
Private Sub UserForm_Terminate()
    
    Dim nRet As Integer
    
    nRet = XXX_SetRegistryString(HKEY_CURRENT_USER, "software\cells\daityo", "DisplayDay", txtNearDay.Text)
    
    Set dbRes = Nothing

End Sub
Private Sub InitDisp()
    
    Dim i As Long
    
    '会社情報リストボックス
    cboCompany.Clear
    cboCompany.AddItem "すべて"
        
    ' レコードセットを取得
    dbRes.Open "SELECT distinct 会社名 FROM 申請データ", dbcon, adOpenForwardOnly, adLockReadOnly
    Do Until dbRes.EOF
        '非表示
        cboCompany.AddItem dbRes("会社名")
        dbRes.MoveNext
    Loop

    cboCompany.ListIndex = 0

    ' レコードセット、データベースを閉じる
    dbRes.Close
    
    '手続き情報リストボックス
    cboTetuzuki.Clear
    cboTetuzuki.AddItem "すべて"
    
    '種類ボックス
    Me.cboSyu.Clear
    cboSyu.AddItem "すべて"
    cboSyu.AddItem "社"
    cboSyu.AddItem "雇"
    cboSyu.AddItem "労"
    cboSyu.ListIndex = 0
        
    ' レコードセットを取得
    dbRes.Open "SELECT distinct 手続名 FROM 申請データ", dbcon, adOpenForwardOnly, adLockReadOnly
    
    Do Until dbRes.EOF
        '非表示
        cboTetuzuki.AddItem dbRes("手続名")
        dbRes.MoveNext
    Loop

    cboTetuzuki.ListIndex = 0

    ' レコードセット、データベースを閉じる
    dbRes.Close

    '年月ボックスの中身
    Me.cboYear.Clear
    For i = 2010 To 2015
        cboYear.AddItem i
    Next i
    cboYear.ListIndex = Year(Now()) - 2010
    
    Me.cboMonth.Clear
    For i = 1 To 12
        cboMonth.AddItem i
    Next i
    cboMonth.ListIndex = Month(Now()) - 1
    
    '直近n日を取得する
     '何日分表示するか取得する
    Dim nRet As Integer
    Dim mDay As String
    
    nRet = XXX_GetRegistryString(HKEY_CURRENT_USER, "software\cells\daityo", "DisplayDay", mDay)
       
    If IsNumeric(mDay) Then
        '1以上60以下使う
        If CInt(mDay) >= 1 And CInt(mDay) <= 60 Then
            txtNearDay.Text = mDay
        Else
            txtNearDay.Text = 14
            nRet = XXX_SetRegistryString(HKEY_CURRENT_USER, "software\cells\daityo", "DisplayDay", txtNearDay.Text)
        End If
    Else
        '数字でない場合は、14日(2週)分
        txtNearDay.Text = 14
        nRet = XXX_SetRegistryString(HKEY_CURRENT_USER, "software\cells\daityo", "DisplayDay", txtNearDay.Text)
    End If

    Me.cboJyokyo.Clear
    cboJyokyo.AddItem ""
    cboJyokyo.AddItem "申請"
    cboJyokyo.AddItem "到達"
    cboJyokyo.AddItem "審査中"
    cboJyokyo.AddItem "審査終了"
    cboJyokyo.AddItem "手続終了"
    cboJyokyo.AddItem "複数"
    cboJyokyo.AddItem "エラー"
    
    cboJyokyo.ListIndex = 0

End Sub
Private Sub InitList()

    Dim strSQL As String

    strSQL = "SELECT id,作成日,申請番号,申請先,会社名,社or雇or労,手続名,内容,到達番号,"
    strSQL = strSQL & "SWITCH(状況 = 1,'申請',状況 = 2,'到達',状況 = 3,'審査中',状況 = 4,'審査終了',状況 = 5,'手続終了',状況 = 6,'複数',"
    strSQL = strSQL & "状況 = 7 AND LEFT(申請番号,14) < '" & Format(DateAdd("n", -5, Now), "YYYYMMDDHHmmss") & "','エラー')"
    strSQL = strSQL & ",フォルダ名,その他1,その他2,その他3,担当 FROM 申請データ WHERE (状況 <> 0 AND 状況 <> 99) "

    If Trim(txt001.Text) <> vbNullString Then
        strSQL = strSQL & " AND 申請番号 = """ & txt001.Text & """"
    End If
    If Trim(txt002.Text) <> vbNullString Then
        strSQL = strSQL & " AND 到達番号 = """ & txt002.Text & """"
    End If
    If cboSyu.ListIndex <> 0 Then
        strSQL = strSQL & "AND 社or雇or労 = """ & cboSyu.List(cboSyu.ListIndex) & """"
    End If
    If cboTetuzuki.ListIndex <> 0 Then
        strSQL = strSQL & "AND 手続名 = """ & cboTetuzuki.List(cboTetuzuki.ListIndex) & """"
    End If
    If Trim(txt004.Text) <> vbNullString Then
        strSQL = strSQL & " AND 会社名 like ""%" & txt004.Text & "%"""
    End If
    If Trim(txt005.Text) <> vbNullString Then
        strSQL = strSQL & " AND FD通番 = """ & txt005.Text & """"
    End If
    If Trim(txt006.Text) <> vbNullString Then
        strSQL = strSQL & " AND 担当 = """ & txt006.Text & """"
    End If
    If Trim(txt007.Text) <> vbNullString Then
        strSQL = strSQL & " AND その他1 like  ""%" & txt007.Text & "%"""
    End If
    If Trim(txt008.Text) <> vbNullString Then
        strSQL = strSQL & " AND その他2 like ""%" & txt008.Text & "%"""
    End If
    If Trim(txt009.Text) <> vbNullString Then
        strSQL = strSQL & " AND その他3 like ""%" & txt009.Text & "%"""
    End If
    If Me.cboJyokyo.ListIndex <> 0 Then
        strSQL = strSQL & " AND 状況 = " & Me.cboJyokyo.ListIndex
    End If
    
    If Me.optNearly.value Then
'20120301 kon #14048
'        strSQL = strSQL & "AND id > """ & Format(DateAdd("d", -14, Now), "yyyymmdd") & String(9, "0") & """"
'        strSQL = strSQL & "AND id > """ & Format(DateAdd("m", -1, Now), "yyyymmdd") & String(9, "0") & """"
'何日分表示するか取得する
            Dim nRet As Integer
            Dim mDay As String
            
            'nRet = XXX_GetRegistryString(HKEY_CURRENT_USER, "software\cells\daityo", "DisplayDay", mDay)
            
            If IsNumeric(Me.txtNearDay.Text) Then
                '1以上60以下使う
                If CInt(Me.txtNearDay.Text) < 1 Or CInt(Me.txtNearDay.Text) > 60 Then
                    Me.txtNearDay.Text = "14"
                End If
            Else
                '数字でない場合は、14日(2週)分
                Me.txtNearDay.Text = "14"
            End If
            strSQL = strSQL & "AND id > """ & Format(DateAdd("d", CInt(Me.txtNearDay.Text) * -1, Now), "yyyymmdd") & String(9, "0") & """"
            nRet = XXX_SetRegistryString(HKEY_CURRENT_USER, "software\cells\daityo", "DisplayDay", Me.txtNearDay.Text)
    ElseIf Me.opHere Then
        strSQL = strSQL & " AND id BETWEEN '" & cboYear & Format(cboMonth, "00") & "000000000000' AND '" & cboYear & Format(cboMonth, "00") & "999999999999'"
    End If

    strSQL = strSQL & " ORDER BY id DESC"

    SearchSQL = strSQL
    
    'frm申請済リスト.InitList strSQL
    申請済リスト SearchSQL

End Sub

Attribute VB_Name = "frmProgress"
Attribute VB_Base = "0{48B29F5A-0DE1-452D-9D1C-0162E2B30BE7}{3EE75957-CB19-4B8F-A8B1-B9E43C6E6591}"
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

Attribute VB_Name = "Module1"
Option Explicit
Public Const aaa As String = "e-Gov 一括電子申請"
Sub 初期処理()
    Dim fso
    Dim n As Integer
    Dim i As Integer
    Dim FileName As String
    Dim MyStr As String
    
    ThisWorkbook.Activate
    Worksheets("MENU").Select

'    IDとＰＷを表示
    FileName = Workbooks("DaMenu.xls").path & "\DaProcess\Da保存\電子申請申請者\申請者情報1.txt"
    Open FileName For Input As #1
        For i = 1 To 29
            Input #1, MyStr
            ActiveSheet.Cells(6, 4).value = MyStr
            MyStr = ""
        Next
    Close #1
    Open FileName For Input As #1
        For i = 1 To 30
            Input #1, MyStr
            ActiveSheet.Cells(7, 4).value = MyStr
            MyStr = ""
        Next
    Close #1
    
End Sub
Sub 終了へ()
    
    Application.Run "DaAddin.xla!閉じる"

End Sub
Sub 印刷()
    
    ActiveSheet.PrintOut

End Sub
Sub Da保存へ()
    
    Application.Run "DaAddin.xla!Da保存へ"

End Sub
Sub Da保存読込へ()

    Application.Run "DaAddin.xla!Da保存読込へ"

End Sub
Public Sub 未送信トレイ()

    frm未送信トレイ.Show

End Sub
Public Sub 申請済リスト(Optional ByVal sql As String = vbNullString)

    ' 参照設定「Microsoft Active Data Object 2.x Library」
    Dim dbcon As New ADODB.Connection
    Dim dbRes As New ADODB.Recordset
    Dim dbCol As ADODB.Field
    Dim strSQL As String

    ' 画面描画更新停止
     Application.ScreenUpdating = False
    ThisWorkbook.Worksheets("送信済リスト").Protect UserInterfaceOnly:=True

    Worksheets("送信済リスト").Activate
    Worksheets("送信済リスト").Rows("3:65536").ClearContents
    
    InitDBObject DB_PATH, dbcon
    
    strSQL = "SELECT id,作成日,申請番号,申請先,会社名,社or雇or労,手続名,内容,到達番号,"
    strSQL = strSQL & "SWITCH(状況 = 1,'申請',状況 = 2,'到達',状況 = 3,'審査中',状況 = 4,'審査終了',状況 = 5,'手続終了',状況 = 6,'複数',"
    '#19505 20121018
    'strSQL = strSQL & "状況 = 7 AND LEFT(申請番号,14) < '" & Format(DateAdd("n", -5, Now), "YYYYMMDDHHmmss") & "','エラー')"
    strSQL = strSQL & "状況 = 7 ,'エラー')"
    'END  #19505
    strSQL = strSQL & ",フォルダ名,その他1,その他2,その他3,担当 FROM 申請データ WHERE (状況 <> 0 AND 状況 <> 99) "
    
    '何日分表示するか取得する
            Dim nRet As Integer
            Dim mDay As String
            
            nRet = XXX_GetRegistryString(HKEY_CURRENT_USER, "software\cells\daityo", "DisplayDay", mDay)
               
            If IsNumeric(mDay) Then
                '1以上60以下使う
                If CInt(mDay) < 1 Or CInt(mDay) > 60 Then
                    mDay = "14"
                End If
            Else
                '数字でない場合は、14日(2週)分
                mDay = "14"
            End If
            strSQL = strSQL & "AND id > """ & Format(DateAdd("d", CInt(mDay) * -1, Now), "yyyymmdd") & String(9, "0") & """"
            nRet = XXX_SetRegistryString(HKEY_CURRENT_USER, "software\cells\daityo", "DisplayDay", mDay)
    
    'strSQL = strSQL & "AND id > """ & Format(DateAdd("m", -1, Now), "yyyymmdd") & String(9, "0") & """"
    strSQL = strSQL & " ORDER BY id DESC"

    If sql = vbNullString Then
        sql = strSQL
    End If
    
    dbRes.Open sql, dbcon, adOpenKeyset, adLockReadOnly
    Range("A3").CopyFromRecordset dbRes
    
    dbRes.Close
    
    Set dbRes = Nothing
    dbcon.Close
    
    Set dbcon = Nothing
    ' 画面描画更新復帰
    'Call GP_StartSCUPD
    Application.ScreenUpdating = True
         
    Worksheets("送信済リスト").Select

End Sub
Public Sub パーソナライズ起動()

    Dim objIE As Object
    Dim ret As String

    'ログイン
    InitIE objIE, True

    Set objIE = Nothing

End Sub
'
' IE初期化
'
Public Function InitIE(ByRef objIE As Object, Optional ByVal flg As Boolean = True) As Boolean

    Dim ret As Boolean
    ret = False

    Set objIE = CreateObject("InternetExplorer.Application")

    objIE.Visible = flg

    #If DEBUG_MODE Then
        objIE.Navigate (EGOV_TEST_URL_MAIN & "?egovparam=PK011K0001") '指定アドレスに飛ばす
    #Else
        objIE.Navigate (LOGIN_URL) 'LOGIN_URL
    #End If
'    IEWait objIE
'
'    If objIE.locationurl <> TARGET_URL Then
'        ret = False
'        InitIE = ret
'        Exit Function
'    End If
'
'    Do
'        ret = Login(objIE)
'    Loop Until objIE.locationurl <> LOGIN_URL Or ret = False

    InitIE = ret

End Function
Public Sub PID設定画面()

    frmP設定.Show

End Sub
'20110415 YBNO5741 笹 相対パス
Public Function GetDataPath(ByVal str As String) As String

    Dim lngPos As Long

    lngPos = InStrRev(str, "\") + 1

    GetDataPath = Mid(str, lngPos)

End Function
Public Sub DispFormat(ByVal path As String)

    Dim iCount As Long
    Dim fso As Object
    Dim FileObj As Object
    Dim App As Object
    
    If Not IsExist(PathCombine(PathCombine(Workbooks("DaMenu.xls").path, "DaProcess\eGov\申請データ"), GetDataPath(path)), True) Then
        MsgBox "フォルダが見つかりません。", vbInformation + vbOKOnly, "一括申請"
        Exit Sub
    End If
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    For Each FileObj In fso.GetFolder(Workbooks("DaMenu.xls").path & "\DaProcess\eGov\申請データ\" & GetDataPath(path)).Files
        If Right(FileObj, 7) = "_01.xml" Then
            DispXMLData Workbooks("DaMenu.xls").path & "\DaProcess\eGov\申請データ\" & GetDataPath(path) & "\" & GetDataPath(FileObj)
        End If
        If Right(FileObj, 4) = ".csv" Then
            Set App = CreateObject("Excel.Application")
            App.Visible = True
            App.Workbooks.Open Workbooks("DaMenu.xls").path & "\DaProcess\eGov\申請データ\" & GetDataPath(path) & "\" & GetDataPath(FileObj)
            Set App = Nothing
        End If
    Next FileObj
    
    Set fso = Nothing
    
End Sub
Public Sub DispDataFolder(ByVal path As String)

    Dim str As String

    If Not IsExist(PathCombine(PathCombine(Workbooks("DaMenu.xls").path, "DaProcess\eGov\申請データ"), GetDataPath(path)), True) Then
        MsgBox "フォルダが見つかりません。", vbInformation + vbOKOnly, "一括申請"
        Exit Sub
    End If

    str = PathCombine(Environ("windir"), "EXPLORER.EXE") & " " & Workbooks("DaMenu.xls").path & "\DaProcess\eGov\申請データ\" & GetDataPath(path)

    Shell str, vbNormalFocus

End Sub
'END 20110415 YBNO5741 笹 相対パス
Public Sub cmdSearch_Click()

    frmSearch.Show

End Sub
Public Sub cmdBack_Click()

    SearchSQL = vbNullString
    ThisWorkbook.Sheets("MENU").Select

End Sub
Public Sub cmdPrint_Click()
    
    If MsgBox("プリンタの準備はいいですか？", 1 + 32, "印刷") <> 1 Then Exit Sub
    
    On Error GoTo EPROC:
    Range("B3:O" & Range("$A$65536").End(xlUp).Row).PrintOut
    Exit Sub
EPROC:
    MsgBox "印刷を中止したのか、失敗しました。", vbInformation + vbOKOnly, "送信済リスト"
End Sub
Public Sub cmdUpdate_Click()

    Dim iCount As Long
    Dim iSumCount As Long
    Dim SousinNo As String
    Dim ToutatuNo As String

    If ThisWorkbook.ReadOnly = True Then
        MsgBox "他のユーザーが申請中あるいは、データ管理中です。本処理できるのは一人だけです。", vbInformation + vbOKOnly, "読み取り専用"
        Exit Sub
    End If

    '対象の件数を調べて、大まかな時間を表示する。
    iSumCount = ActiveSheet.Range("$A$65536").End(xlUp).Row - 2
    
    If iSumCount < 1 Then Exit Sub
    
    If MsgBox("到達番号と状況をE-GOVから取得しますか。" & vbCrLf & "(" & iSumCount & "件のデータがあります。" & 10 * iSumCount & "秒以上かかる場合があります。)", vbOKCancel + vbQuestion, "E-GOV") = vbCancel Then Exit Sub

    Load frmProgress
    frmProgress.Caption = "一括申請"
    frmProgress.Enabled = False
   
    Dim Send As New egov.Send
    'IDとパスワード
    Dim id As String
    Dim password As String
    
    XXX_GetRegistryString HKEY_CURRENT_USER, "software\cells\daityo", "id", id
    XXX_GetRegistryString HKEY_CURRENT_USER, "software\cells\daityo", "password", password

    If id = vbNullString And password = vbNullString Then
        MsgBox "idとパスワードが登録されていません。", vbInformation + vbOKOnly, "電子申請"
        Exit Sub
    End If

    Send.PersonalizeID = id
    Send.PersonalizePassword = password

    #If DEBUG_MODE Then
        '1ならテストモードに
        Send.BasicID = EGOV_TEST_BASIC_ID
        Send.BasicPassword = EGOV_TEST_BASIC_PW
        Send.EgovUrl = EGOV_TEST_URL_MAIN
        MsgBox "テストモードです。" & vbCrLf & "テスト環境に接続します。"
    #Else
        Send.EgovUrl = EGOV_URL_MAIN
    #End If
       
    Dim IsLogon As Boolean
    Dim ret As Boolean
    Dim strMsg As String
    
    IsLogon = False

    iCount = 1
    
    frmProgress.Show vbModeless
    
    'データベース変数初期化
    Dim dbcon As New ADODB.Connection
    InitDBObject DB_PATH, dbcon
    
    Do While Cells(iCount + 2, 1).value <> vbNullString
        
        If IsLogon = False Then
                ret = Logon(Send, strMsg)
                
                If Not ret Then
                    MsgBox strMsg, vbInformation + vbOKOnly, aaa
                    Unload frmProgress
                    Exit Sub
                Else
                    IsLogon = True
                End If
        End If
        
        frmProgress.lblPercent.Caption = Format(iCount, "000#") & "/" & Format(iSumCount, "000#件")
        frmProgress.lblMessage.Caption = Cells(iCount + 2, 4).value & " " & _
                                                Cells(iCount + 2, 5).value & " " & _
                                                Cells(iCount + 2, 6).value & " 処理中・・・"
        DoEvents
                
        SousinNo = Select申請番号(dbcon, Cells(iCount + 2, 1).value)
        ToutatuNo = Select到達番号(dbcon, Cells(iCount + 2, 1).value)

        '現在の状況から更新データを探すか決める
        If Cells(iCount + 2, 10).value = "手続終了" Or _
            Cells(iCount + 2, 10).value = "複数" Then 'Or _
            '(Cells(iCount + 2, 10).Value = "申請" And Format(DateAdd("n", -5, Now), "YYYYMMDDHHmmss") < SousinNo) Then
            '更新はしないデータ
        Else
            '更新するデータ
            '送信番号と到達番号の有無の組み合わせから分岐する
            If SousinNo <> vbNullString And ToutatuNo <> vbNullString Then
                '状況だけ更新する
                '#19734
                IsLogon = UpdateSendNumber(dbcon, Cells(iCount + 2, 1).value, Send, SousinNo, ToutatuNo)
            ElseIf SousinNo <> vbNullString And ToutatuNo = vbNullString Then
                '到達番号と状況を更新する
                '#19734
                IsLogon = UpdateSendNumber(dbcon, Cells(iCount + 2, 1).value, Send, SousinNo, ToutatuNo)
            Else
                '送信番号がない場合は、何もできない
            End If
        End If
        
'        If SousinNo <> vbNullString And Cells(iCount + 2, 10).Value <> "手続終了" _
'            And Cells(iCount + 2, 10).Value <> "エラー" And Cells(iCount + 2, 10).Value <> "複数" Then
'            UpdateSendNumber dbcon, Cells(iCount + 2, 1).Value, send, SousinNo, ToutatuNo
'        End If
        
        iCount = iCount + 1
    Loop
    
    Unload frmProgress
    
    Send.Logout
    Set dbcon = Nothing
    DoEvents
    
    '再読込
    申請済リスト SearchSQL
    
End Sub
'#19734
'Private Sub UpdateSendNumber(ByRef dbcon As ADODB.Connection, ByVal SinseiId As String, ByRef Send As egov.Send, ByVal SousinNo As String, ByVal ToutatuNo As String)
Private Function UpdateSendNumber(ByRef dbcon As ADODB.Connection, ByVal SinseiId As String, ByRef Send As egov.Send, ByVal SousinNo As String, ByVal ToutatuNo As String) As Boolean

    Dim sd As New egov.SinseiData
    Dim ret As egov.SEND_RETURN_VALUE
    Dim value As Boolean

    sd.SousinNo = SousinNo

    ret = Send.GetDataByToutatuNo(sd)
    
    If ret = SEND_RETURN_VALUE_SUCCESS Then
        Debug.Print ret
        If Not ToutatuNo <> vbNullString Then
            Update到達番号 dbcon, SinseiId, sd.ToutatuNo
        End If
        Update状況 dbcon, SinseiId, Jyoukyoukbn(sd.Jyokyou)
        value = True
    ElseIf ret = SEND_RETURN_VALUE_EGOV_SYSTEM_TOUTATU_ERR Then
        Update状況 dbcon, SinseiId, Jyoukyoukbn(sd.Jyokyou)
        value = True
    Else
        value = False
    End If
    
'    If Not ToutatuNo <> vbNullString Then
'        Update到達番号 dbcon, SinseiId, sd.ToutatuNo
'    End If
    UpdateSendNumber = value
End Function
Private Function Jyoukyoukbn(ByVal str As String) As Integer

    Dim ret As Integer

    Select Case str
        Case "申請": ret = 1
        Case "到達": ret = 2
        Case "審査中": ret = 3
        Case "審査終了": ret = 4
        Case "手続終了": ret = 5
        Case "複数": ret = 6
        Case Else: ret = 7
    End Select

    Jyoukyoukbn = ret
    
End Function
Public Sub 図218_Click()

    Dim objIE As Object
    Dim ret As String
    
    ret = False

    Set objIE = CreateObject("InternetExplorer.Application")

    objIE.Visible = True

    objIE.Navigate ("http://plus-samurai.jp/daityo/wp-content/uploads/sinseigo.pdf") 'LOGIN_URL

    Set objIE = Nothing

End Sub
Public Function Logon(ByRef Send As egov.Send, ByRef strMsg As String) As Boolean

    Dim ret As Boolean
    
    ret = False

     Select Case Send.Logon
        Case egov.SEND_RETURN_VALUE.SEND_RETURN_VALUE_SUCCESS
            ret = True
        Case egov.SEND_RETURN_VALUE.SEND_RETURN_VALUE_ID_OR_PASS_MISTAKE
            strMsg = SEND_MSG_ID_OR_PASS_MISTAKE
        Case egov.SEND_RETURN_VALUE.SEND_RETURN_VALUE_NOT_APP
            strMsg = SEND_MSG_NOT_APP
        Case egov.SEND_RETURN_VALUE_FAILE_HTTP_REQUEST
            strMsg = SEND_MSG_FAILE_HTTP_REQUEST
        Case egov.SEND_RETURN_VALUE.SEND_RETURN_VALUE_EGOV_SYSTEM_SIMPLE_ERR
            strMsg = SEND_MSG_SYSTEM_SIMPLE_ERR
        Case egov.SEND_RETURN_VALUE_EGOV_SYSTEM_ERR
            strMsg = SEND_MSG_SYSTEM_SYSTEM_ERR
    End Select

    Logon = ret

End Function

Attribute VB_Name = "frm未送信トレイ"
Attribute VB_Base = "0{94A8DF35-0A7E-45BC-91FF-9CA65CCA3A1E}{979BA13B-1B34-4ED2-8C60-B2AF70A60BCA}"
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 dbcon As New ADODB.Connection
Private dbRes As New ADODB.Recordset
Private Sub UserForm_Initialize()

    Dim nRet As Long

    'データベース変数初期化
    InitDBObject DB_PATH, dbcon

    InitList

    If ThisWorkbook.ReadOnly = True Then
        MsgBox "他のユーザーが申請処理実行中です。申請処理できるのは一人だけです。", vbInformation + vbOKOnly, Me.Caption
        Me.cmdSend.Enabled = False
        Me.cmdDelete.Enabled = False
    End If

    '電子申請ツールの有無を調べる
    Dim str As String
    str = PathCombine(Environ("ProgramFiles"), SIGN_EXE_PATH)

    #If DEBUG_MODE Then
        Me.Caption = "テストモード"
    #End If

    Dim flg As String

    nRet = XXX_GetRegistryString(HKEY_CURRENT_USER, "software\cells\daityo", "AutoSend", flg)

    If flg <> vbNullString Then
        optSendAuto.value = CBool(flg)
        optSendManual.value = Not CBool(flg)
    Else
        optSendAuto.value = True
    End If

End Sub
Private Sub UserForm_Terminate()

    Dim nRet As Long

    nRet = XXX_SetRegistryString(HKEY_CURRENT_USER, "software\cells\daityo", "AutoSend", optSendAuto.value)

    dbcon.Close

    Set dbRes = Nothing
    Set dbcon = Nothing

End Sub
Private Sub cmdDisp_Click()

    Dim iCount As Long
   
    iCount = ListBoxSelectedCount(lstData)

    If iCount = 0 Then
        MsgBox "申請データが選択されていません。", vbExclamation + vbOKOnly, "電子申請"
        Exit Sub
    End If

    If Me.lstData.ListIndex <> -1 Then
        DispFormat Me.lstData.List(Me.lstData.ListIndex, 1)
    End If

End Sub
Private Sub cmdFolder_Click()

    Dim iCount As Long
   
    iCount = ListBoxSelectedCount(lstData)

    If iCount = 0 Then
        MsgBox "申請データが選択されていません。", vbExclamation + vbOKOnly, "電子申請"
        Exit Sub
    End If

    If Me.lstData.ListIndex <> -1 Then
        DispDataFolder Me.lstData.List(Me.lstData.ListIndex, 1)
    End If

End Sub
Private Sub cmdDelete_Click()

    Dim iCount As Long
    Dim str As String
   
    iCount = ListBoxSelectedCount(lstData)

    If iCount = 0 Then
        MsgBox "申請データが選択されていません。", vbExclamation + vbOKOnly, "電子申請"
        Exit Sub
    End If
    
    str = "選択したデータを削除しますか？" & vbCrLf & _
           "(削除件数 : " & iCount & "件)"
…