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_Open()

    Dim strbuffer As String
    Dim nRet As Long
    Dim msg As String

    If Application.Run("EAppCom.xla!IsInstallEgovDll") Then
        If MsgBox("最新の一括申請ツールをインストールします。よろしいですか？", vbQuestion + vbOKCancel, "電子申請") = vbOK Then
            'インストール
            Application.Run "EAppCom.xla!InstallEgovDll"
        Else
            '閉じる
            msg = "処理を中止します。お手数ですが、台帳メニューの[ツール]-[4. 一括申請ツールのインストール]より最新版をインストールしてください。"
            MsgBox msg, vbInformation + vbOKOnly, "電子申請"
            ThisWorkbook.Close False
            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

    '画面にバージョンを表記する
    Sheets("MENU").Unprotect
    Cells(27, 2).value = Application.Run("EAppCom.xla!GetEGovDLLFileVersion")
    Sheets("MENU").Protect

    CheckDbVersion

End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    MsgBox "このファイルは保存できません。", vbCritical + vbOKOnly, "保存不可"
    Cancel = True
    
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(ByRef msg As String) As Boolean
'
'    Dim ret As Boolean
'    Dim fso As Object
'    Dim FileName As String
'    Dim objFile As Object
'    Dim MSGString As String
'
'    MSGString = "お手数ですが、台帳メニューの[ツール]-[4. 一括申請ツールのインストール]より最新版をインストールしてください。"
'
'    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) > #1/1/2014 11:00:00 AM# Then
'            ret = True
'        Else
'            msg = "電子申請ツールが最新ではありません。" & vbCrLf & MSGString
'            ret = False
'        End If
'        Set objFile = Nothing
'    Else
'        msg = "電子申請ツールがインストールされていません。" & vbCrLf & MSGString
'    End If
'
'    Set fso = Nothing
'
'    IsToolsDate = ret
'
'End Function
'Private Sub 電子申請一括ツール()
'
'    Dim ret     As Long
'    Dim str     As String
'
'    'MsgBox ToolVersion(VBA.Strings.Trim(Workbooks("DaMenu.xls").path) & "\台帳電子申請ツール.msi")
'
''    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のアンインストール
'
'    ret = InstallProc(VBA.Strings.Trim(Workbooks("DaMenu.xls").path) & "\setup.exe")
'
'    Select Case ret
'        Case SE_ERR_NOASSOC
'            MsgBox "一括申請ツールのインストールに失敗しました。", vbInformation, "一括申請ツール"
'        Case ERROR_FILE_NOT_FOUND
'            MsgBox "一括申請ツールのインストールが見つかりません。", vbInformation, "一括申請ツール"
'    End Select
'
'End Sub
'Private Function ToolVersion(ByVal fname As String) As String
'
'    ' msiファイルを開く
'    Const msiOpenDatabaseModeReadOnly = 0 '読取専用モード
'
'    Dim installer As Object
'    Set installer = CreateObject("WindowsInstaller.Installer")
'    Dim database  As Object
'    Set database = installer.OpenDatabase(fname, msiOpenDatabaseModeReadOnly)
'
'    ToolVersion = GetPropertyValue(database, "ProductVersion")
'
'    database.Commit
'    Set database = Nothing
'    Set installer = Nothing
'
'End Function
'Private Function GetPropertyValue(ByRef database As Object, ByVal propertyName As String)
'
'  Dim query As String
'   Dim view As Object
'    Dim record As Object
'  Dim value As String
'
'   query = "SELECT Value FROM Property WHERE Property='" & propertyName & "'"
'  Set view = database.OpenView(query)
' view.Execute
'    Set record = view.Fetch
' value = record.StringData(1)
'    GetPropertyValue = value
'
'    Set record = Nothing
'    Set view = Nothing
'
'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
'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 = "runas"
'        .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{3520709B-5D25-4F7A-9ECF-5BDCED08F1AC}{51694714-9558-4C8F-B03F-27C09F9DC228}"
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()

'20140425 kon 25093
    If optNearly.value = True Then
        If txtNearDay.Text = "" Then
            MsgBox "直近データで検索する場合は、日数を入力してください。", vbInformation, "送信済リスト"
            Exit Sub
        End If
        '20140410 kon 24776
        If txtNearDay.Text >= 60 Then
            MsgBox "直近データは、60日未満で入力してください。", vbInformation, "送信済リスト"
            Exit Sub
        End If
        
    End If
    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
    
    
'YBNO 25532  ito 20150320　申請先追加　------------------------------------------------------
    '申請先情報リストボックス
    cobSaki.Clear
    cobSaki.AddItem "すべて"
    
    ' レコードセットを取得
    dbRes.Open "SELECT distinct 申請先 FROM 申請データ", dbCon, adOpenForwardOnly, adLockReadOnly
     
    Do Until dbRes.EOF
        '非表示
        cobSaki.AddItem dbRes("申請先")
        dbRes.MoveNext
    Loop

    cobSaki.ListIndex = 0

    ' レコードセット、データベースを閉じる
    dbRes.Close
'YBNO 25532  ito 20150320　ここまで　------------------------------------------------------
    

    '年月ボックスの中身
    Me.cboYear.Clear
    
    'YB 29808 20160105 fuku
'    For i = 2010 To 2015
    For i = 2010 To Year(Now())
        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
    ''' # 25189
    If cboCompany.ListIndex <> 0 Then
        strSQL = strSQL & " AND 会社名 like ""%" & cboCompany.List(cboCompany.ListIndex) & "%"""
    End If
'    If Trim(txt004.Text) <> vbNullString Then
'        strSQL = strSQL & " AND 会社名 like ""%" & txt004.Text & "%"""
'    End If
''' End 25189
    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
    
    'YBNO 25532  ito 20150320　提出先追加
    If cobSaki.ListIndex <> 0 Then
        strSQL = strSQL & "AND 申請先 = """ & cobSaki.List(cobSaki.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{793F3DA0-63BC-4F0E-AA17-462733AC9180}{41CD8EFB-803E-4CFD-A4D6-CE5750BFE5F4}"
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"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'公文書取得ボタンの表示は
'フォルダの表示を右クリック→キーボードのコントロールキーをクリック

'修正履歴
'27293 控シートの会社名が入るセルの書式設定を変更 20150325 hara
'30055 Q&A機能の追加 20160126 hara
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
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

'30055 Q&Aボタンの機能追加 hara
Public Sub QAの表示()
    Dim sheetName As String
    
    sheetName = ActiveSheet.Name
    Debug.Print sheetName
    
    Application.Run "CellsSupport.xlam!DisplayQA", sheetName, "台帳"
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
    Worksheets("送信済リスト").Rows("3:65536").ClearFormats '#26486
    
    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
    
    '色つける
    SetColor
    
    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
    
    If ExsitMyNoForDir(PathCombine(PathCombine(Workbooks("DaMenu.xls").path, "DaProcess\eGov\申請データ"), GetDataPath(path))) Then
        If Application.Run("DaAddin.xla!MNMode", True, False) Then
            'ログ
            Dim procfilemei As String
            procfilemei = XMLDataToDataFileName(PathCombine(PathCombine(Workbooks("DaMenu.xls").path, "DaProcess\eGov\申請データ"), GetDataPath(path) & "\kousei.xml"))
            procfilemei = PathCombine(PathCombine(PathCombine(Workbooks("DaMenu.xls").path, "DaProcess\eGov\申請データ"), GetDataPath(path)), procfilemei)
            
            Dim CompanyAccount As String
            
            CompanyAccount = Application.Run("GetCompanyAccountByCompanyName", XmlValue(procfilemei, "//事業所名|//事業所名称|//事業所名略称"))
                           
            Dim TargetName As String
            
            TargetName = XmlValue(procfilemei, "//被保険者氏名|//氏名カタカナ")
            
            Dim summry As String
            
            summry = PathCombine(PathCombine(Workbooks("DaMenu.xls").path, "DaProcess\eGov\申請データ"), GetDataPath(path) & "\kousei.xml")
            summry = XMLDataToProcName(summry)
            
            Application.Run "DaAddin.xla!ProcLogging", CompanyAccount, PROC_NAME, "申請書の表示", summry, vbNullString, TargetName, "成功"
        End If
    End If
    
    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

    If ExsitMyNoForDir(PathCombine(PathCombine(Workbooks("DaMenu.xls").path, "DaProcess\eGov\申請データ"), GetDataPath(path))) Then
        If Application.Run("DaAddin.xla!MNMode", True, False) Then
            'ログ
            Dim procfilemei As String
            procfilemei = XMLDataToDataFileName(PathCombine(PathCombine(Workbooks("DaMenu.xls").path, "DaProcess\eGov\申請データ"), GetDataPath(path) & "\kousei.xml"))
            procfilemei = PathCombine(PathCombine(PathCombine(Workbooks("DaMenu.xls").path, "DaProcess\eGov\申請データ"), GetDataPath(path)), procfilemei)
            
            Dim CompanyAccount As String
            
            CompanyAccount = Application.Run("GetCompanyAccountByCompanyName", XmlValue(procfilemei, "//事業所名|//事業所名称|//事業所名略称"))
                           
            Dim TargetName As String
            
            TargetName = XmlValue(procfilemei, "//被保険者氏名|//氏名カタカナ")
                           
            Dim summry As String
            
            summry = PathCombine(PathCombine(Workbooks("DaMenu.xls").path, "DaProcess\eGov\申請データ"), GetDataPath(path) & "\kousei.xml")
            summry = XMLDataToProcName(summry)
                           
            Application.Run "DaAddin.xla!ProcLogging", CompanyAccount, PROC_NAME, "データフォルダの表示", summry, vbNullString, TargetName, "成功"
        End If
    End If

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
    Dim Send As Object
    Set Send = CreateObject("Cells.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
Public Function UpdateSendNumber(ByRef dbCon As ADODB.Connection, ByVal SinseiId As String, ByRef Send As Object, ByVal SousinNo As String, ByVal ToutatuNo As String) As Boolean

    'Dim sd As New egov.SinseiData
    Dim sd As Object
    Set sd = CreateObject("Cells.SinseiData")
    
'    Dim ret As egov.SEND_RETURN_VALUE
    Dim ret As Long
    
    Dim value As Boolean

    sd.SousinNo = SousinNo

    ret = Send.GetDataByToutatuNo(sd)
    
…