Malicious Office (OOXML) — 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_BeforeClose(Cancel As Boolean)
    
    Set CommonSM = Nothing

End Sub
Private Sub Workbook_Open()

    InitDBObject "MNRelevance\Syslog.accdb", conSyslog, DB_PROVIDER_ACE
    
    If Not GetTableExec("CompanyData", conSyslog) Then
        ExecSQLProc conSyslog, CreateCompanyDataTableSQL
        conSyslog.Close
        Dim f As Integer
        Dim buf As String
        
        If Dir(DaListFileName, vbNormal) <> "" Then
            f = FreeFile()
            Application.ScreenUpdating = False
            Open DaListFileName For Input As #f
                Do Until EOF(f)
                    Input #f, buf
                    SetCompanyData Split(buf, vbTab)(1), Split(buf, vbTab)(0)
                Loop
            Close #f
            Application.ScreenUpdating = True
        End If
    Else
        conSyslog.Close
    End If

End Sub
Private Sub SetCompanyData(ByVal DaName As String, ByVal Account As String)

    If Dir(Workbooks("DaMenu.xls").path & "\" & DaName) <> vbNullString Then
        Workbooks.Open Workbooks("DaMenu.xls").path & "\" & DaName
        
        EditCompanyData Workbooks(DaName), Account
        
        Workbooks(DaName).Close False
    End If

End Sub



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 = "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 = "StatupModule"
Option Explicit
Private Declare Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long

Private Const CHILDID_SELF = 0&
Private Const ROLE_SYSTEM_PAGETABLIST = &H3C
Private Const ROLE_SYSTEM_PAGETAB = &H25
'Public Sub Auto_Open()
''ファイルが開かれたときに実行されるマクロ
' Application.OnTime [Now() + "0:00:01"], "CallMe"
'End Sub
Public Sub CallMe()
  '引数はカスタムタブ(tab要素)のlabel属性の値,もしくは"アドイン"
  Call SelRibbonTAB("業務日誌")
End Sub
'20150518 YBNO 27762 エラーが起きる人いるので、CellsSuuportのアドインのソースをコピーした
Public Sub SelRibbonTAB(myTabName As String)
  Dim myAcc As Office.IAccessible
  Dim TimeLimit As Date
   
  TimeLimit = DateAdd("s", 2, Now())  'ループの制限時間:2秒
  Set myAcc = Application.CommandBars("Ribbon")
  Set myAcc = GetAcc(myAcc, "リボン タブ", ROLE_SYSTEM_PAGETABLIST)
   
  On Error Resume Next
  Do
    Set myAcc = GetAcc(myAcc, myTabName, ROLE_SYSTEM_PAGETAB)
    DoEvents
    If Now() > TimeLimit Then Exit Do  '制限時間を過ぎたらループを抜ける
  Loop While myAcc Is Nothing
  On Error GoTo 0
  
  If Not myAcc Is Nothing Then
    myAcc.accDoDefaultAction (CHILDID_SELF)
    Set myAcc = Nothing
  End If
End Sub
Private Function GetAcc(myAcc As Office.IAccessible, myAccName As String, myAccRole As Long) As Office.IAccessible
    Dim ReturnAcc As Office.IAccessible
    Dim ChildAcc As Office.IAccessible
    Dim List() As Variant
    Dim Count As Long
    Dim i As Long

    On Error GoTo Err_PROC
    If (myAcc.accState(CHILDID_SELF) <> 32769) And _
       (myAcc.accName(CHILDID_SELF) = myAccName) And _
       (myAcc.accRole(CHILDID_SELF) = myAccRole) Then
        Set ReturnAcc = myAcc
    Else
        Count = myAcc.accChildCount
     
     If Count > 0& Then
       ReDim List(Count - 1&)
       If AccessibleChildren(myAcc, 0&, ByVal Count, List(0), Count) = 0& Then
         For i = LBound(List) To UBound(List)
           If TypeOf List(i) Is Office.IAccessible Then
             Set ChildAcc = List(i)
             Set ReturnAcc = GetAcc(ChildAcc, myAccName, myAccRole)
             If Not ReturnAcc Is Nothing Then Exit For
           End If
         Next
       End If
     End If
     
   End If
   
   Set GetAcc = ReturnAcc
 Exit Function
Err_PROC:
    Set GetAcc = Nothing
 End Function
'Public Sub SelRibbonTAB(myTabName As String)
'  Dim myAcc As Office.IAccessible
'  Dim TimeLimit As Date
'
'  TimeLimit = DateAdd("s", 2, Now())  'ループの制限時間:2秒
'  Set myAcc = Application.CommandBars("Ribbon")
'  Set myAcc = GetAcc(myAcc, "リボン タブ", ROLE_SYSTEM_PAGETABLIST)
'
'  On Error Resume Next
'  Do
'    Set myAcc = GetAcc(myAcc, myTabName, ROLE_SYSTEM_PAGETAB)
'    DoEvents
'    If Now() > TimeLimit Then Exit Do  '制限時間を過ぎたらループを抜ける
'  Loop While myAcc Is Nothing
'  'On Error GoTo 0
'
'  If Not myAcc Is Nothing Then
'    myAcc.accDoDefaultAction (CHILDID_SELF)
'    Set myAcc = Nothing
'  End If
'End Sub
'Private Function GetAcc(myAcc As Office.IAccessible, myAccName As String, myAccRole As Long) As Office.IAccessible
'    Dim ReturnAcc As Office.IAccessible
'    Dim ChildAcc As Office.IAccessible
'    Dim List() As Variant
'    Dim count As Long
'    Dim i As Long
'
'    If (myAcc.accState(CHILDID_SELF) <> 32769) And _
'       (myAcc.accName(CHILDID_SELF) = myAccName) And _
'       (myAcc.accRole(CHILDID_SELF) = myAccRole) Then
'        Set ReturnAcc = myAcc
'    Else
'        count = myAcc.accChildCount
'
'     If count > 0& Then
'       ReDim List(count - 1&)
'       If AccessibleChildren(myAcc, 0&, ByVal count, List(0), count) = 0& Then
'         For i = LBound(List) To UBound(List)
'           If TypeOf List(i) Is Office.IAccessible Then
'             Set ChildAcc = List(i)
'             Set ReturnAcc = GetAcc(ChildAcc, myAccName, myAccRole)
'             If Not ReturnAcc Is Nothing Then Exit For
'           End If
'         Next
'       End If
'     End If
'
'   End If
'
'   Set GetAcc = ReturnAcc
' End Function


Attribute VB_Name = "StorageCommonModule"
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
Private Const SW_HIDE = 0   'ウィンドウ非表示
Private Const SW_SHOWNORMAL = 1 '通常の状態で開く
Private Const SW_SHOWMINIMIZED = 2  'ウィンドウ最小化
Private Const SW_SHOWMAXIMIZED = 3   'ウィンドウ最大化
Private Const SW_SHOW = 5   'ウィンドウを現在の位置とサイズで表示
Private Const SW_RESTOR = 6 'ウィンドウを元の位置とサイズで表示

Public Const ERROR_FILE_NOT_FOUND = 2&
Public Const ERROR_PATH_NOT_FOUND = 3&
Public Const ERROR_BAD_FORMAT = 11&

Public Const MSG_SENDED_FILE As String = "送信しました。"
Public Const MSG_APPNED_FILE As String = "登録しました。"
Public Const MSG_CELLS_DRIVE_NOT_READY As String = "Cellsドライブの設定がされていません。"
Public Const LOG_SUCCESS As String = "成功"
Public Const LOG_FAILURE As String = "失敗"

Public Const CAPTION_MAINTENANCE As String = "ファイル管理"
Public Const CAPTION_PERSONALBOX As String = "個人ボックス"

Public Const CAPTION_NON_PROTECT As String = "未"
Public Const CAPTION_PROTECT As String = "済"

Private Const DA_LIST As String = "DaList.txt"

Public CommonSM As New StorageManager
Public conSyslog As New ADODB.Connection
Public Function SecretCaption(ByVal tag As String) As String

    If tag = "1" Then
        SecretCaption = "秘"
    Else
        SecretCaption = ""
    End If

End Function
Public Function SendCodeCaption(ByVal code As String) As String

    If code = "0" Then
        SendCodeCaption = "送信"
    Else
        SendCodeCaption = "受信"
    End If
    
End Function
Public Function ViewStateCaption(ByVal state As String) As String
    
    If state = "0" Then
        ViewStateCaption = "未"
    Else
        ViewStateCaption = "済"
    End If

End Function
Public Function SaveCountCaption(ByVal Count As String) As String

    If CLng(Count) > 0 Then
        SaveCountCaption = CAPTION_PROTECT
    Else
        SaveCountCaption = CAPTION_NON_PROTECT
    End If

End Function
Public Function CreateCompanyCombo(ByRef cbo As MSForms.ComboBox, ByRef sm As StorageManager, ByVal Allflg As Boolean, ByVal query As String) As Boolean

    Dim ret As Boolean
    'Dim lst() As CompanyAccount
    Dim lst() As Object
   
    ret = sm.CompanyAccount(lst)
    
    If Not ret Then
        MsgBox sm.LastError
        Exit Function
    End If
    
    Dim item As Variant
    
    cbo.Clear
    
    If Allflg Then
        cbo.AddItem ""
        cbo.List(cbo.ListCount - 1, 1) = "すべて"
    End If
    
    If Sgn(lst) <> 0 Then
        For Each item In lst
            'Dim com As CompanyAccount
            Dim com As Object
            
            Set com = item
            
            If query <> vbNullString Then
                If com.Name Like "*" & query & "*" Then
                    cbo.AddItem com.AccountName
                    cbo.List(cbo.ListCount - 1, 1) = com.AccountName & "　(" & com.Name & ")"
                End If
            Else
                cbo.AddItem com.AccountName
                'YBNO 29202・29203  ito 20151022
                'cbo.List(cbo.ListCount - 1, 1) = com.Name & "(" & com.AccountName & ")"
                cbo.List(cbo.ListCount - 1, 1) = com.AccountName & "　(" & com.Name & ")"
            End If
        Next
        CreateCompanyCombo = True
    Else
        CreateCompanyCombo = False
    End If
    
End Function
Public Function CreateCompanyAccountCombobox(ByRef cbo As MSForms.ComboBox, ByVal flg As Boolean, Optional ByVal query As String = vbNullString) As Boolean

    If Not CommonSM.TicketCheck Then
        CommonSM.Ticket = Application.Run("DaAddin.xla!TicketString")
        CommonSM.Name = Application.Run("DaAddin.xla!UserNameString")
        CommonSM.AccessRight = Application.Run("DaAddin.xla!AccessRightString")
        If Not CommonSM.TicketCheck Then
            If Not Ninsyo("会社情報", GetCompanyData(ActiveWorkbook)) Then
                CreateCompanyAccountCombobox = False
                Exit Function
            End If
        End If
    End If
    CommonSM.Connect

    If CommonSM.AccessRight = "0" Then
        MsgBox "権限がありません。"
        CreateCompanyAccountCombobox = False
        Exit Function
    End If
    
    CreateCompanyAccountCombobox = CreateCompanyCombo(cbo, CommonSM, flg, query)
    
End Function
Public Sub SetDaFileToCompanyAccount(ByRef dict As Object)

    Dim item As Variant
    Dim fh As Integer

    fh = FreeFile()
        
    Open DaListFileName For Output As fh
        For Each item In dict.keys
            If dict(item) <> vbNullString Then
                Print #fh, dict(item) & vbTab & item
            End If
        Next
    Close fh

End Sub
Public Sub PersonalBox(ByVal syskey As String)

    If Not CommonSM.TicketCheck Then
        CommonSM.Ticket = Application.Run("DaAddin.xla!TicketString")
        CommonSM.Name = Application.Run("DaAddin.xla!UserNameString")
        CommonSM.AccessRight = Application.Run("DaAddin.xla!AccessRightString")
        If Not CommonSM.TicketCheck Then
            If Not Ninsyo("個人ボックス") Then Exit Sub
        End If
    End If
    CommonSM.Connect
        
    Dim frm As New PersonalBoxForm

    frm.OwnerStorageManager = CommonSM
    frm.Systemkey = syskey
    frm.Init
    frm.Show vbModeless
    
End Sub
Public Function DaListFileName()

    Dim fname As String

    fname = Application.Run("DaAddin.xla!PathCombine", Workbooks("DaMenu.xls").path, "DaProcess")
    fname = Application.Run("DaAddin.xla!PathCombine", fname, DA_LIST)

    DaListFileName = fname
    
End Function
Public Sub AddLog(ByRef SyslogParamCollection As Collection, ByRef DetailParamCollection As Collection)

    Dim sql As String
    Dim item As Variant

    InitDBObject "MNRelevance\Syslog.accdb", conSyslog, DB_PROVIDER_ACE
    
    sql = JoinInsertSQL("syslog", SyslogParamCollection)
    sql = Replace(sql, "ID,", vbNullString)

    'SQL発行
    On Error Resume Next
    conSyslog.BeginTrans
    conSyslog.Execute sql
    
    If Err.Number <> 0 Then
        conSyslog.RollbackTrans
        conSyslog.Close
        MessageBox Err.Description
        Exit Sub
    End If
    
    On Error GoTo 0
    
    Dim rec As Recordset
    
    Set rec = conSyslog.Execute("Select @@IDENTITY")
    
    sql = JoinInsertSQL("SyslogDetails", DetailParamCollection)
    sql = Replace(sql, "{0}", rec(0).Value)
    sql = Replace(sql, "{1}", SyslogParamCollection("Results"))
    sql = Replace(sql, "{2}", SyslogParamCollection("UpdateDate"))
    
    On Error Resume Next
    conSyslog.Execute sql
    
    If Err.Number <> 0 Then
        conSyslog.RollbackTrans
        conSyslog.Close
        MessageBox Err.Description
        Exit Sub
    End If
    On Error GoTo 0
    conSyslog.CommitTrans
    
    conSyslog.Close

    Set rec = Nothing

End Sub
Private Function JoinInsertSQL(ByVal tblName As String, ByRef col As Collection) As String

    Dim FiledName() As Variant
    Dim sql As String
    Dim item As Variant

    FiledName = GetFieldsArray(conSyslog, tblName)

    'INSERT文の項目名の作成
    sql = "Insert Into " & tblName & " ("

    For Each item In FiledName
        sql = sql & item & ","
    Next
    
    sql = Left(sql, Len(sql) - 1) & ") values ("

    'Insert文の値の作成
    For Each item In col
        sql = sql & "'" & item & "',"
    Next

    sql = Left(sql, Len(sql) - 1) & ")"
    
    JoinInsertSQL = sql
    
    Erase FiledName
    
End Function
Public Function SysLogDetailsParamerterCollectionForPersonal(ByVal Systemkey As String, ByVal Name As String) As Collection

    Dim col As New Collection

    col.Add "{0}", "ID"
    col.Add 1, "serialnumber"
    col.Add 1, "FG" '暫定
    col.Add Systemkey, "UserNo"
    col.Add Name, "UserName"
    col.Add "{1}", "results"
    col.Add vbNullString, "sSummary"
    col.Add "{2}", "UpdateDate"

    Set SysLogDetailsParamerterCollectionForPersonal = col

End Function
Public Function SysLogDetailsParamerterCollection(ByVal Account As String) As Collection

    Dim col As New Collection

    Dim cd As CompanyData
        
    Set cd = GetCompanyDatabyAccount(Account)

    col.Add "{0}", "ID"
    col.Add 1, "serialnumber"
    col.Add 1, "FG" '暫定
    col.Add cd.Systemkey, "UserNo"
    col.Add cd.Name, "UserName"
    col.Add "{1}", "results"
    col.Add vbNullString, "sSummary"
    col.Add "{2}", "UpdateDate"

    Set SysLogDetailsParamerterCollection = col

End Function
Public Function SysLogParamerterCollection(ByVal Account As String, ByVal screen As String, ByVal proc As String, ByVal summary As String, ByVal result As String, ByVal ProcDate As String) As Collection

    Dim col As New Collection
   
    Dim cd As CompanyData
        
    Set cd = GetCompanyDatabyAccount(Account)
    
    col.Add cd.Systemkey, "SystemKey"
    col.Add cd.Name, "Name"
    col.Add cd.Account, "Account"
    col.Add "1", "softId"
    col.Add screen, "Screen"
    col.Add proc, "Processing"
    col.Add summary, "Summary"
    col.Add result, "Results"
    col.Add CommonSM.Name, "UpdateUserName"
    col.Add Application.Run("DaAddin.xla!GetComputerName"), "UpdateMachine"
    col.Add ProcDate, "UpdateDate"

    Set SysLogParamerterCollection = col

    Set cd = Nothing

End Function
Public Function MessageBox(ByVal msg As String, Optional ByVal msgStyle As VbMsgBoxStyle = vbInformation + vbOKOnly) As VbMsgBoxResult

    '#28793
    If InStr(1, msg, "リモート名を解決できませんでした。") > 0 Then
        msg = "サーバーに接続できませんでした。"
    End If

    '#28909
    If InStr(1, msg, "基礎になる接続が閉じられました") > 0 Then
        msg = "サーバーに接続できませんでした。"
    End If

    MessageBox = MsgBox(msg, msgStyle, "Cellsドライブ")
    
End Function
Public Function ComboBoxValueExists(ByRef cbo As MSForms.ComboBox, ByVal str As String) As Boolean

    Dim i As Long

    For i = 0 To cbo.ListCount - 1
        If str = cbo.List(i, 0) Then
            ComboBoxValueExists = True
            Exit Function
        End If
    Next

    ComboBoxValueExists = False
    
End Function
Public Sub NewDataComing()

    If Not Application.Run("DaAddin.xla!MNMode", True, False) Then
        Exit Sub
    End If
    
    Dim i As Long

    If CommonSM.StateView Then
        i = CommonSM.NewContentsCount(CommonSM.Numdays, "0")
    Else
        i = CommonSM.NewContentsCount(CommonSM.Numdays, "")
    End If
    On Error GoTo 0 '#28793

    If i > 0 Then
        MessageBox "新規ファイルがあります。:" & i & "件"
    End If

End Sub
Public Function FileDelete(ByVal FilePath As String) As Boolean

    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    If fso.FileExists(FilePath) Then
        On Error GoTo Err_PROC
        fso.DeleteFile FilePath
        On Error GoTo 0
    End If
    
    Set fso = Nothing
    FileDelete = True
    Exit Function
Err_PROC:
    FileDelete = False
End Function
Public Sub FileOpen(ByVal FilePath As String)

    Dim fso As Object
    Dim app As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim extName As String
    
    extName = UCase(fso.GetExtensionName(FilePath))
    
    If extName = "XLS" Or extName = "XLSX" Or extName = "XLSM" Or extName = "XLA" Or extName = "XLAM" Then '#29586
    
        Set app = CreateObject("Excel.Application")
        app.Visible = True
        app.EnableEvents = False '#29586
        app.Workbooks.Open FilePath
        Set app = Nothing
    Else
        Dim ret As Long
    
        ret = ShellExecute(0, "open", FilePath, vbNull, vbNull, SW_SHOW)
    
        If ret < 31 Then
            If ret = ERROR_FILE_NOT_FOUND Then
                MessageBox "ファイルがみつかりません。"
            Else
                MessageBox "その他のエラー :" & CStr(ret)
            End If
        ElseIf ret = 31 Then
            MessageBox "このファイルの拡張子に関連付けられているアプリケーションが見つかりません。"
        End If

    End If
    
    Set fso = Nothing
    
End Sub
Public Function CeratePersonalDataCollection(ByVal DaName As String) As Collection

    Dim col As New Collection
    Dim alreadyFlg As Boolean
    Dim i As Long

    Application.ScreenUpdating = False

    If IsOpenBook(DaName) Then
        alreadyFlg = True
    Else
        alreadyFlg = False
        Workbooks.Open PathCombine(Workbooks("DaMenu.xls").path, DaName), , True
    End If

    Dim item As PersonalData

    With Workbooks(DaName).Worksheets("個人情報")
        For i = 6 To .Cells(Rows.Count, 2).End(xlUp).Row
            Set item = New PersonalData
            item.DaityoNumber = .Cells(i, 2).Value
            item.PersonalName = .Cells(i, 5).Value & " " & .Cells(i, 6).Value
            item.Systemkey = .Cells(i, 200).Value
            
            col.Add item, key:=CStr(i)   '本当は台帳NOをキーにしたいが、かぶっていたらコケそう。
        Next

    End With

    If alreadyFlg = False Then
        Workbooks(DaName).Close False
    End If

    Application.ScreenUpdating = True

    Set CeratePersonalDataCollection = col

End Function
Private Function IsOpenBook(ByVal FileName As String) As Boolean

    Dim item As Variant
    
    For Each item In Workbooks
        If item.Name = FileName Then
            IsOpenBook = True
            Exit Function
        End If
    Next
    
    IsOpenBook = False
    
End Function
Public Function PersonalBoxFileExist(ByRef col As Collection) As Long

    Dim ret As Boolean
    Dim i As Long
    Dim item As Variant
    'Dim SysArray() As PersonalBoxSysKey
    Dim SysArray() As Object
    ReDim SysArray(0 To col.Count - 1)
    i = 0
    For Each item In col
        'Set SysArray(i) = New PersonalBoxSysKey
        Set SysArray(i) = CreateObject("Cells.MNApiLib.Data.PersonalBoxSysKey")
        SysArray(i).Systemkey = item
        i = i + 1
    Next

    ret = CommonSM.PersonalBoxExists(SysArray)
    
    If Not ret Then
        PersonalBoxFileExist = 2
        Erase SysArray
        Exit Function
    End If
    
    If CheckUBound(SysArray) Then
        PersonalBoxFileExist = 1
    Else
        PersonalBoxFileExist = 0
    End If

    Erase SysArray

End Function
Private Function CheckUBound(ByRef obj As Variant) As Boolean

    Dim ret As Long

    On Error GoTo Err_PROC
    ret = UBound(obj)
    On Error GoTo 0
    If ret = -1 Then
        CheckUBound = False
    Else
        CheckUBound = True
    End If
    Exit Function
Err_PROC:
    CheckUBound = False
End Function
Public Sub CreatePersonalBoxList(ByRef cbo As MSForms.ComboBox, ByVal DaName As String, ByVal Allflg As Boolean)

    Dim item As Variant
    Dim pdata As PersonalData
    Dim col As Collection
    
    Set col = CeratePersonalDataCollection(DaName)
      
    cbo.Clear
    If Allflg Then
        cbo.AddItem "すべて"
    End If
    
    For Each item In col
        Set pdata = item
        cbo.AddItem pdata.DaityoNumber & " " & pdata.PersonalName
        cbo.List(cbo.ListCount - 1, 1) = pdata.DaityoNumber
        cbo.List(cbo.ListCount - 1, 2) = pdata.Systemkey
    Next
        
End Sub
Public Sub SendForm(Optional ByVal DaName As String = vbNullString, Optional ByVal FileName As String = vbNullString)

    If Not Application.Run("DaAddin.xla!MNMode", True, False) Then
        MessageBox MSG_CELLS_DRIVE_NOT_READY
        Exit Sub
    End If

    If Not CommonSM.TicketCheck Then
        CommonSM.Ticket = Application.Run("DaAddin.xla!TicketString")
        CommonSM.Name = Application.Run("DaAddin.xla!UserNameString")
        CommonSM.AccessRight = Application.Run("DaAddin.xla!AccessRightString")
        If Not CommonSM.TicketCheck Then
            If Not Ninsyo("ファイル送信") Then Exit Sub
        End If
    End If
    CommonSM.Connect
    
    Dim frm As New FileSendForm
    
    frm.OwnerStorageManager = CommonSM
    frm.Init
    frm.tag = "ファイル送信"
    If FileName <> vbNullString Then
        Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        frm.FileNameTextBox.Text = fso.GetFile(FileName).Name
        frm.FileNameTextBox.tag = fso.GetFile(FileName).ParentFolder
        Set fso = Nothing
    End If
    If DaName <> vbNullString Then
        If ComboBoxValueExists(frm.CompanyAccountComboBox, GetCompanyAccount(DaName)) Then
            frm.CompanyAccountComboBox = GetCompanyAccount(DaName)
            frm.OpenFileSendCheck.Visible = False
        End If
    End If
    frm.Show vbModeless

End Sub
Public Function GetDaFileName(ByVal CompanyAccount As String) As String

    InitDBObject "MNRelevance\Syslog.accdb", conSyslog, DB_PROVIDER_ACE
    
    GetDaFileName = SelectSingleValueProc(conSyslog, "Select FileName from CompanyData Where CompanyAccount = """ & CompanyAccount & """")
    
    conSyslog.Close

End Function
Public Function GetCompanyAccountByCompanyName(ByVal Name As String) As String

    InitDBObject "MNRelevance\Syslog.accdb", conSyslog, DB_PROVIDER_ACE
    
    GetCompanyAccountByCompanyName = SelectSingleValueProc(conSyslog, "Select CompanyAccount from CompanyData Where Name = """ & Name & """")
    
    conSyslog.Close

End Function
Public Function GetCompanyAccount(ByVal DaName As String) As String

    InitDBObject "MNRelevance\Syslog.accdb", conSyslog, DB_PROVIDER_ACE
    
    GetCompanyAccount = SelectSingleValueProc(conSyslog, "Select CompanyAccount from CompanyData Where FileName = """ & DaName & """")
    
    conSyslog.Close

End Function
Private Function GetCompanyData(ByRef wb As Workbook) As String

    InitDBObject "MNRelevance\Syslog.accdb", conSyslog, DB_PROVIDER_ACE
    
    GetCompanyData = SelectSingleValueProc(conSyslog, "Select CompanyAccount from CompanyData Where Systemkey = """ & wb.Worksheets("会社情報").Cells(4, 2).Value & """")
    
    conSyslog.Close

End Function
Public Function EditCompanyData(ByRef wb As Workbook, ByVal AccountName As String) As Boolean

    Dim buf As String
   
    InitDBObject "MNRelevance\Syslog.accdb", conSyslog, DB_PROVIDER_ACE
   
   'AccountNameの存在有無
    buf = SelectSingleValueProc(conSyslog, "Select Systemkey from CompanyData Where CompanyAccount =""" & AccountName & """")
    
    If buf <> vbNullString And buf <> wb.Worksheets("会社情報").Cells(4, 2).Value And AccountName <> vbNullString Then
        EditCompanyData = False
        MessageBox "既に他の事業所に関連されています。"
        conSyslog.Close
        Exit Function
    End If
    
    Dim syskey As String
    Dim comname As String
    
    syskey = wb.Worksheets("会社情報").Cells(4, 2).Value
    comname = wb.Worksheets("会社情報").Cells(8, 2).Value
    
    buf = SelectSingleValueProc(conSyslog, "Select count(*) from CompanyData Where Systemkey =""" & syskey & """")
    
    'KEYの存在有無
    If CLng(buf) = 0 And AccountName <> vbNullString Then
        'KEYなし
         '   Insert
        ExecSQLProc conSyslog, CreateCompanyDataInsertSQL(syskey, wb.Name, comname, AccountName)
    ElseIf CLng(buf) = 1 And AccountName <> vbNullString Then
        'KEYあり
        '    Update
        ExecSQLProc conSyslog, CreateCompanyDataUpdatetSQL(syskey, wb.Name, comname, AccountName)
    Else
        'DELETE
        ExecSQLProc conSyslog, CreateCompanyDataDeleteSQL(syskey)
    End If
    
    conSyslog.Close
    
    EditCompanyData = True
    
End Function
Private Function CreateCompanyDataDeleteSQL(ByVal Systemkey As String) As String

    Dim buf As String
    
    buf = "Delete from CompanyData where Systemkey = """ & Systemkey & """"

    CreateCompanyDataDeleteSQL = buf

End Function
Public Function CreateCompanyDataInsertSQL(ByVal Systemkey As String, ByVal FileName As String, ByVal CompanyName As String, ByVal AccountName As String) As String

    Dim buf As String
    
    buf = "Insert Into CompanyData (Systemkey,FileName,Name,CompanyAccount) Values "
    buf = buf & "(""" & Systemkey & """,""" & FileName & """,""" & CompanyName & """,""" & AccountName & """)"
    
    CreateCompanyDataInsertSQL = buf

End Function
Private Function CreateCompanyDataUpdatetSQL(ByVal Systemkey As String, ByVal FileName As String, ByVal CompanyName As String, ByVal AccountName As String) As String

    Dim buf As String

    buf = "Update Companydata Set "
    buf = buf & "FileName = """ & FileName & ""","
    buf = buf & "Name = """ & CompanyName & ""","
    buf = buf & "CompanyAccount = """ & AccountName & """"
    buf = buf & " where systemkey = """ & Systemkey & """"
 
    CreateCompanyDataUpdatetSQL = buf

End Function
Public Function GetCompanyDatabyAccount(ByVal CompanyAccount As String) As CompanyData

    Dim ret As New CompanyData

    If CompanyAccount <> vbNullString Then
        
        InitDBObject "MNRelevance\Syslog.accdb", conSyslog, DB_PROVIDER_ACE
    
        Dim buf As Variant
    
        buf = SelectSingleRecordProc(conSyslog, "Select * from CompanyData Where CompanyAccount = """ & CompanyAccount & """")
    
        If CheckUBound(buf) Then
            ret.Systemkey = buf(0, 0)
            ret.DaFileName = buf(1, 0)
            ret.Name = buf(2, 0)
            ret.Account = buf(3, 0)
        Else
            ret.Account = CompanyAccount
        End If
        
        conSyslog.Close
    End If

    Set GetCompanyDatabyAccount = ret

End Function
Public Function UpdateCompanyData(ByVal Systemkey As String, ByVal comname As String, DaName As String, ByVal AccountName As String) As Boolean

    Dim buf As String
   
    InitDBObject "MNRelevance\Syslog.accdb", conSyslog, DB_PROVIDER_ACE
   
   'AccountNameの存在有無
    buf = SelectSingleValueProc(conSyslog, "Select Systemkey from CompanyData Where CompanyAccount =""" & AccountName & """")
    
    If buf <> vbNullString And buf <> Systemkey And AccountName <> vbNullString Then
        UpdateCompanyData = False
        MessageBox "既に他の事業所に関連されています。"
        conSyslog.Close
        Exit Function
    End If
       
    buf = SelectSingleValueProc(conSyslog, "Select count(*) from CompanyData Where Systemkey =""" & Systemkey & """")
    
    'KEYの存在有無
    If CLng(buf) = 0 And AccountName <> vbNullString Then
        'KEYなし
         '   Insert
        ExecSQLProc conSyslog, CreateCompanyDataInsertSQL(Systemkey, DaName, comname, AccountName)
    ElseIf CLng(buf) = 1 And AccountName <> vbNullString Then
        'KEYあり
        '    Update
        ExecSQLProc conSyslog, CreateCompanyDataUpdatetSQL(Systemkey, DaName, comname, AccountName)
    Else
        'DELETE
        ExecSQLProc conSyslog, CreateCompanyDataUpdatetSQL(Systemkey, DaName, comname, AccountName)
    End If
    
    conSyslog.Close
    
    UpdateCompanyData = True
    
End Function
Public Sub DaDataDelete(ByVal syskey As String)

    InitDBObject "MNRelevance\Syslog.accdb", conSyslog, DB_PROVIDER_ACE

    ExecSQLProc conSyslog, CreateCompanyDataDeleteSQL(syskey)

    conSyslog.Close

End Sub
Public Function IsDaFileOpen() As Boolean

    Dim item As Variant

    For Each item In Workbooks
        If LCase(Right(item.Name, 6)) = "da.xls" Then
            IsDaFileOpen = True
            Exit Function
        End If
    Next
    IsDaFileOpen = False
End Function
Public Function Ninsyo(ByVal LogString As String, Optional ByVal AccountName As String = vbNullString) As Boolean
…