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


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 = "CommonModule"
'#27319 hara 機密保持契約書に同意していただく画面を新規作成 20150427
'28400 リボンの整理 20160126 hara
'30026 コンタクトフォームのレイアウト変更 20160126 hara
'30055 Q&A機能の追加 20160126 hara
'#38933 taka 20170927 F出力の出力のみ機能を廃止
Option Explicit

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
                       (ByVal hwnd As Long, ByVal lpOperation As String, _
                        ByVal lpFile As String, ByVal lpParameters As String, _
                        ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
'==================================================
'UrlEncodeUtf8: 文字列をUTF-8でエンコードするFunction
'==================================================
'strSource: 元の文字列
'返り値: エンコードされた文字列
'==================================================
Public Function UrlEncodeUtf8(ByRef strSource As String) As String
Dim objSC As Object
Set objSC = CreateObject("ScriptControl")
objSC.Language = "Jscript"
UrlEncodeUtf8 = objSC.CodeObject.encodeURIComponent(strSource)
Set objSC = Nothing
End Function
'==================================================
'UrlDecodeUtf8: 文字列をUTF-8でデコードするFunction
'==================================================
'strSource: 元の文字列
'返り値: エンコードされた文字列
'==================================================
Public Function URLDecodeUTF8(strSource As String) As String
Dim objSC As Object
Set objSC = CreateObject("ScriptControl")
objSC.Language = "Jscript"
URLDecodeUTF8 = objSC.CodeObject.decodeURIComponent(strSource)
Set objSC = Nothing
End Function
Public Sub OpenLink(ByVal URL As String)

    Dim rc As Long
    rc = ShellExecute(0, "Open", URL, "", "", 1)

End Sub
Function ieChk() As Integer
    Dim ieVer As String
    Dim FSO As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")

    ieVer = FSO.GetFileVersion _
    ("C:\Program Files\Internet Explorer\IEXPLORE.EXE ")
    
    ieVer = Left(ieVer, InStr(ieVer, ".") - 1)

    ieChk = ieVer
    
    Set FSO = Nothing

End Function
Public Function ExcelVersionSPString() As String

    Dim buf As String

    Select Case Application.Version
        Case "11.0"
            buf = "Excel 2003"
            Select Case Application.Build
                Case Is < 6355 '5612
                    buf = buf & " SPなし:" & Application.Build
                Case Is < 7969 '6355
                    buf = buf & " SP1:" & Application.Build
                Case Is < 8173 '7969
                    buf = buf & " SP2:" & Application.Build
                Case Is >= 8173 '8173
                    buf = buf & " SP3:" & Application.Build
                Case Else
                    buf = buf & " 不明:" & Application.Build
            End Select
        Case "12.0"
            buf = "Excel 2007"
            Select Case Application.Build
                Case Is < 6211 '4518
                    buf = buf & " SPなし:" & Application.Build
                Case Is < 6423 '6211
                    buf = buf & " SP1:" & Application.Build
                Case Is < 6606 '6423
                    buf = buf & " SP2:" & Application.Build
                Case Is >= 6606 '6606
                    buf = buf & " SP3:" & Application.Build
                Case Else
                    buf = buf & " 不明:" & Application.Build
            End Select
        Case "14.0"
            buf = "Excel 2010"
            Select Case Application.Build
                'YBNO 27497  ito 20150430
                'Case Is < 6024 '4756
                Case Is < 6029 '4763
                    buf = buf & " SPなし:" & Application.Build
                'YBNO 27497  ito 20150407
                'Case Is >= 6024 '6024
                Case Is < 7015 '6029
                    buf = buf & " SP1:" & Application.Build
                'YBNO 27497  ito 20150407　追加　---------------------
                Case Is >= 7015 '7015
                    buf = buf & " SP2:" & Application.Build
                'YBNO 27497  ito 20150407　ここまで　-----------------
                Case Else
                    buf = buf & " 不明:" & Application.Build
            End Select
        Case "15.0"
            buf = "Excel 2013"
            'YBNO 27497  ito 20150407　追加　---------------------
            Select Case Application.Build
                Case Is < 4569 '4420
                    buf = buf & " SPなし:" & Application.Build
                Case Is >= 4569 '4569
                    buf = buf & " SP1:" & Application.Build
                Case Else
                    buf = buf & " 不明:" & Application.Build
            End Select
            'YBNO 27497  ito 20150407　ここまで　-----------------
        'YB#30026 hara エクセル2016対応 20161119 start
        Case "16.0"
            buf = "Excel 2016"
            Select Case Application.Build
                Case Is <= 6366
                    buf = buf & "：" & Application.Build
                Case Else
                    '処理なし
                    'YB 34181 同じ処理を追加
                    buf = buf & "：" & Application.Build
            End Select
        'YB#30026 hara エクセル2016対応 end
        Case Else
            buf = "動作対象外"
    End Select

    ExcelVersionSPString = buf
    
End Function
Public Function OSInfoString() As String

    Dim buf As String

    Dim Locator As Variant
    Dim Service As Variant
    Dim OsSet As Variant
    Dim Os As Variant
    Dim Arc As String
    Dim strOsDVersion As Variant
    
    Set Locator = CreateObject("WbemScripting.SWbemLocator")
    Set Service = Locator.ConnectServer
    Set OsSet = Service.ExecQuery("Select * From Win32_OperatingSystem")
    
    For Each Os In OsSet
        On Error Resume Next
        Arc = CStr(Os.OSArchitecture) '32bit環境だとエラーになる
        On Error GoTo 0
        If Arc = vbNullString Then Arc = "32bit"
        '#30477 hara 20160308 start OSのビルド番号を出力処理を追加Os.Version
        buf = Os.Caption & " " & Os.CSDVersion & "(" & CStr(Arc) & ") " & Os.Version
        '#30477 end
    Next Os

    Set Service = Nothing
    Set OsSet = Nothing
    Set Locator = Nothing

    OSInfoString = buf

End Function

'----------------------------------------
'30055 hara
'ブラウザに表示しないHTMLのタグを削除して
'必要なものだけを残したHTMLを作成する関数
'----------------------------------------
Public Function F_ModifyDisplay(ByRef webObject As Object, ParamArray idName())
    Dim idElement As Object
    Dim idTag As String
    Dim i
    
    On Error Resume Next
    
    For i = LBound(idName) To UBound(idName)
        idTag = CStr(idName(i))
        Set idElement = webObject.Document.getElementById(idTag)
        If Not idElement Is Nothing Then idElement.OuterHTML = ""
    Next
End Function

'-----------------------------------------------------------
'30055 hara
'引数で指定したシート名に関連するQ&Aページを表示する
' sheetName Q&Aボタンが配置してあるシート名
' appName   どのソフトからの呼び出しか(台帳、Cells給与など)
'-----------------------------------------------------------
Public Function DisPlayQA(ByVal sheetName As String, ByVal appName As String)
    Select Case appName
        Case "台帳"
            IsDaityo = True
            IsKyuyo = False
        Case "Cells給与"
            IsDaityo = False
            IsKyuyo = True
        Case Else
    End Select
    
    TagName = sheetName
    qaView.Show
End Function

'#40596  ito 20180409/20180514　---------------------------------
'ファイル出力に使用。DaAddin.xlaのDa保存と同仕様。
Public Function Hani(Scope As String)
    Dim i As Integer
    For i = 1 To Len(Scope)
        If Mid(Scope, i, 1) = ":" Then
            Hani = Left(Scope, i - 1) & ":"
            Exit For
        End If
    Next
    For i = Len(Scope) To 1 Step -1
        If Mid(Scope, i, 1) = ":" Then
            Hani = Hani & Right(Scope, Len(Scope) - i)
            Exit For
        End If
    Next
End Function
'#40595  -----------------------------------------------

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
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


Attribute VB_Name = "LinkModule"
Option Explicit
'セルズソフトA
'Private Const CELLS_SOFT_A_1 As String = "http://www.cells.co.jp/daityo-p/" 'YB32929
Private Const CELLS_SOFT_A_1 As String = "https://www.cells.co.jp/daityo-p/"
'Private Const CELLS_SOFT_A_2 As String = "http://www.cells.co.jp/kyuyo-p/" 'YB32929
Private Const CELLS_SOFT_A_2 As String = "https://www.cells.co.jp/kyuyo-p/"
'Private Const CELLS_SOFT_A_5 As String = "http://www.cells.co.jp/uriage/" 'YB32929
Private Const CELLS_SOFT_A_5 As String = "https://www.cells.co.jp/uriage/"
'Private Const CELLS_SOFT_A_8 As String = "http://www.cells.co.jp/oyakata/" 'YB32929
Private Const CELLS_SOFT_A_8 As String = "https://www.cells.co.jp/oyakata/"
'Private Const CELLS_SOFT_A_1 As String = "http://plus-samurai.jp/daityo/"
'Private Const CELLS_SOFT_A_2 As String = "http://www.cells.co.jp/kyuyo/"
'Private Const CELLS_SOFT_A_3 As String = "http://www.cells.co.jp/saiteki/" 'YB32929
Private Const CELLS_SOFT_A_3 As String = "https://www.cells.co.jp/saiteki/"
Private Const CELLS_SOFT_A_4 As String = "http://www.team-cells.jp/softweb/saitekine/saitekine.htm"
'Private Const CELLS_SOFT_A_5 As String = "http://www.team-cells.jp/softweb/uriage2010/"
Private Const CELLS_SOFT_A_6 As String = "http://www.team-cells.jp/softweb/kensetugyo/"
Private Const CELLS_SOFT_A_7 As String = "http://www.team-cells.jp/softweb/keisin/"
'Private Const CELLS_SOFT_A_8 As String = "http://www.team-cells.jp/softweb/oyakata/"
Private Const CELLS_SOFT_A_9 As String = "http://www.team-cells.jp/softweb/mailmeisai/meisaimail.html"
'セルズソフトB
Private Const CELLS_SOFT_B_1 As String = "http://www.plus-samurai.jp/etokusou/"
Private Const CELLS_SOFT_B_2 As String = "http://www.team-cells.jp/softweb/yuukyuu/"
Private Const CELLS_SOFT_B_3 As String = "http://www.team-cells.jp/softweb/tyuuankin/"
Private Const CELLS_SOFT_B_4 As String = "http://www.team-cells.jp/softweb/rousi2010/index.html"
Private Const CELLS_SOFT_B_5 As String = "http://www.team-cells.jp/softweb/karenda/karenda1.htm"
'Private Const CELLS_SOFT_B_6 As String = "http://www.cells.co.jp/hoken/" 'YB32929
Private Const CELLS_SOFT_B_6 As String = "https://www.cells.co.jp/hoken/"
'Private Const CELLS_SOFT_B_7 As String = "http://www.cells.co.jp/kyujin/" 'YB32929
Private Const CELLS_SOFT_B_7 As String = "https://www.cells.co.jp/kyujin/"
'便利ツール
Private Const BENRI_1 As String = "http://www.team-cells.jp/forms/search.php"
Private Const BENRI_2 As String = "http://www.team-cells.jp/hyoujyun/hyoujyunhousyu.php"
'Private Const BENRI_3 As String = "http://team-cells.jp/dl/TeamViewer_Setup_ja.exe"
'YB26660
'Private Const BENRI_3 As String = "http://www.teamviewer.com/link/?url=505374&id=417578968"
'Private Const BENRI_3 As String = "http://www.teamviewer.com/download/version_9x/TeamViewerQS.exe"
Private Const BENRI_3 As String = "https://www.cells.co.jp/daityo-s/team-viewer" '29654
Private Const WEBLOGIN As String = "https://meisai-sr.cells.jp/Login"   '#35156 hara 20170321

'台帳サポート
Public TagName As String
Public IsDaityo As Boolean
Public Const DAITYO_WEB As String = "http://plus-samurai.jp/daityo/" '台帳

Private Const DAITYO_A_WEB As String = "https://www.cells.co.jp/daityo-s/archives/category/information" 'お知らせ
Private Const DAITYO_B_WEB As String = "https://www.cells.co.jp/daityo-s/manuals" 'マニュアル
Private Const DAITYO_C_WEB As String = "https://www.cells.co.jp/daityo-s/qa" 'よくある質問
Private Const DAITYO_F_WEB As String = "https://www.cells.co.jp/daityo-s/qa/e" '電子申請
'Private Const DAITYO_A_WEB As String = "http://plus-samurai.jp/daityo/?cat=49" '
'Private Const DAITYO_B_WEB As String = "http://plus-samurai.jp/daityo/?cat=203" 'マニュアル
'Private Const DAITYO_C_WEB As String = "http://plus-samurai.jp/daityo/?tag=" 'よくある質問
Private Const DAITYO_D_WEB As String = "http://plus-samurai.jp/daityo/?category_name=reco" '今月のおすすめ
Private Const DAITYO_E_WEB As String = "http://plus-samurai.jp/daityo/?cat=5" 'バージョン情報
'Private Const DAITYO_F_WEB As String = "http://plus-samurai.jp/daityo/?cat=17" '電子申請

'Cells給与サポート
Public IsKyuyo As Boolean
'Public Const KYUYO_WEB As String = "http://www.cells.co.jp/kyuyo/" 'YB32929
Public Const KYUYO_WEB As String = "https://www.cells.co.jp/kyuyo/"

Private Const KYUYO_A_WEB As String = "https://www.cells.co.jp/kyuyo-s/archives/category/information"
Private Const KYUYO_B_WEB As String = "https://www.cells.co.jp/kyuyo-s/qa"
'Private Const KYUYO_A_WEB As String = "http://www.cells.co.jp/kyuyo/?cat=10"
'Private Const KYUYO_B_WEB As String = "http://www.cells.co.jp/kyuyo/"
'20161212 kon  #35663
 Private Const KYUYO_C_WEB As String = "https://www.cells.co.jp/kyuyo-s/manuals"

Private Const SAITEKI_WEB As String = "http://www.cells.co.jp/saiteki/"
'おしらせ
Private Const INFO_A_WEB As String = "https://www.cells.co.jp/"
Private Const INFO_B_WEB As String = "https://www.cells.co.jp/archives/category/info"
Private Const INFO_C_WEB As String = "https://twitter.com/Cells_info"
'Private Const INFO_D_WEB As String = "http://www.cells.co.jp/?category_name=%E9%9B%87%E7%94%A8%E5%8A%A9%E6%88%90%E9%87%91" 'YB32929
Private Const INFO_D_WEB As String = "https://www.cells.co.jp/?category_name=%E9%9B%87%E7%94%A8%E5%8A%A9%E6%88%90%E9%87%91"
Private Const INFO_F_WEB As String = "https://www.cells.co.jp/archives/category/seminar"
'Private Const INFO_A_WEB As String = "http://www.cells.co.jp/?category_name=%e3%81%8a%e7%9f%a5%e3%82%89%e3%81%9b"
'Private Const INFO_B_WEB As String = "http://www.cells.co.jp/?category_name=%E4%BA%BA%E4%BA%8B%E5%8A%B4%E5%8B%99%E3%83%8B%E3%83%A5%E3%83%BC%E3%82%B9"
'Private Const INFO_C_WEB As String = "http://www.cells.co.jp/?category_name=%E9%9B%87%E7%94%A8%E5%8A%A9%E6%88%90%E9%87%91"
'Private Const INFO_D_WEB As String = "http://www.cells.co.jp/?category_name=%E6%B3%95%E5%BE%8B%E6%94%B9%E6%AD%A3"
'Private Const INFO_E_WEB As String = "http://www.cells.co.jp/?category_name=%E3%83%A1%E3%83%AB%E3%83%9E%E3%82%AC" 'YB32929
Private Const INFO_E_WEB As String = "https://www.cells.co.jp/?category_name=%E3%83%A1%E3%83%AB%E3%83%9E%E3%82%AC"
'Private Const INFO_F_WEB As String = "http://www.cells.co.jp/?category_name=%E3%82%BB%E3%83%9F%E3%83%8A%E3%83%BC"

'Private Const INFO_A_WEB As String = "http://www.cells.co.jp/?category_name=%e3%81%8a%e7%9f%a5%e3%82%89%e3%81%9b"
'Private Const INFO_B_WEB As String = "http://www.cells.co.jp/?category_name=%e3%83%8b%e3%83%a5%e3%83%bc%e3%82%b9"
'Private Const INFO_C_WEB As String = "http://www.cells.co.jp/?category_name=%e6%b3%95%e6%94%b9%e6%ad%a3%e3%83%bb%e5%8a%a9%e6%88%90%e9%87%91"
'Private Const INFO_D_WEB As String = "http://www.cells.co.jp/?category_name=%e3%83%a1%e3%83%ab%e3%83%9e%e3%82%ac"
'ショッピング
Private Const SHOPING_A_WEB As String = "http://cells.shop-pro.jp/"
'Private Const SHOPING_B_WEB As String = "http://cart05.lolipop.jp/LA11732319/" 'YB32929
Private Const SHOPING_B_WEB As String = "http://cellsmeisai.shop-pro.jp/"
'注文書
'Private Const CHUMON_A_WEB As String = "http://www.cells.co.jp/chumon.pdf" 'YB32929
Private Const CHUMON_A_WEB As String = "https://www.cells.co.jp/chumon.pdf"
'YBNO 28812  ito 20150925　税抜注文書に変更
'Private Const CHUMON_B_WEB As String = "http://www.cells.co.jp/kyuyo/wp-content/uploads/komon.pdf"
'Private Const CHUMON_B_WEB As String = "http://www.cells.co.jp/kyuyo/wp-content/uploads/zeinukikomonnsaki.pdf"
'YBNO 28400 hara 20160122
'Private Const CHUMON_B_WEB As String = "http://www.cells.co.jp/kyuyo-p/wp-content/uploads/zeinukikomonnsaki.pdf" 'YB32929
Private Const CHUMON_B_WEB As String = "https://www.cells.co.jp/kyuyo-p/wp-content/uploads/zeinukikomonnsaki.pdf"

Private Const ERR_MSG_SENDMAIL As String = "'SendMail' メソッドは失敗しました: '_Workbook' オブジェクト"

Private mRibbon As IRibbonUI
Public bul As Boolean
'Callback for customUI.onLoad
Sub OnLoad(ribbon As IRibbonUI)
    
    Set mRibbon = ribbon
    
End Sub
'Callback for customButton3_1 onAction
Sub A1Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", CELLS_SOFT_A_1, "", "", 1)
End Sub
'Callback for customButton3_2 onAction
Sub A2Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", CELLS_SOFT_A_2, "", "", 1)
End Sub
'Callback for customButton3_3 onAction
Sub A3Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", CELLS_SOFT_A_3, "", "", 1)
End Sub
'Callback for customButton3_4 onAction
Sub A4Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", CELLS_SOFT_A_4, "", "", 1)
End Sub
'Callback for customButton3_5 onAction
Sub A5Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", CELLS_SOFT_A_5, "", "", 1)
End Sub
'Callback for customButton3_6 onAction
Sub A6Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", CELLS_SOFT_A_6, "", "", 1)
End Sub
'Callback for customButton3_7 onAction
Sub A7Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", CELLS_SOFT_A_7, "", "", 1)
End Sub
'Callback for customButton3_8 onAction
Sub A8Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", CELLS_SOFT_A_8, "", "", 1)
End Sub
'Callback for customButton3_9 onAction
Sub A9Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", CELLS_SOFT_A_9, "", "", 1)
End Sub
'Callback for customButton4_1 onAction
Sub B1Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", CELLS_SOFT_B_1, "", "", 1)
End Sub
'Callback for customButton4_2 onAction
Sub B2Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", CELLS_SOFT_B_2, "", "", 1)
End Sub
'Callback for customButton4_3 onAction
Sub B3Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", CELLS_SOFT_B_3, "", "", 1)
End Sub
'Callback for customButton4_4 onAction
Sub B4Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", CELLS_SOFT_B_4, "", "", 1)
End Sub
'Callback for customButton4_5 onAction
Sub B5Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", CELLS_SOFT_B_5, "", "", 1)
End Sub
'Callback for customButton4_6 onAction
Sub B6Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", CELLS_SOFT_B_6, "", "", 1)
End Sub
'Callback for customButton4_7 onAction
Sub B7Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", CELLS_SOFT_B_7, "", "", 1)
End Sub
'Callback for customButton6_1 onAction
Sub BEN1Link(control As IRibbonControl)
    '#38872  ito 20170829
    'Dim rc As Long
    'rc = ShellExecute(0, "Open", BENRI_1, "", "", 1)
    MsgBox "「台帳」の処理ファイル【書式集】をご利用ください。 " & vbCrLf & vbCrLf & "＜開き方＞" & vbCrLf & "台帳MENU → 処理ファイル → その他グループ → 書式集", 64, "テンプレート"
End Sub
'Callback for customButton6_2 onAction
Sub BEN2Link(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", BENRI_2, "", "", 1)
End Sub
'Callback for customButton6_3 onAction
Sub BEN3Link(control As IRibbonControl)
    Dim rc As Long
    'taka 20150514
'20160204 kon 29654 HPが変わり同意画面が２重で開くためコメントに
'    機密保持契約2.Show
'    If bul = True Then
        rc = ShellExecute(0, "Open", BENRI_3, "", "", 1)
'    Else
'        Exit Sub
'    End If
End Sub
'Callback for customButton6_4 onAction
Sub BEN4Link(control As IRibbonControl)
'27319 hara 20150428 start
    機密保持契約.Show
'    Upload.Show
'27319 hara 20150428 end
End Sub
'#27766 20150520 ishikawa リボンの入り口はふさいだ
'Callback for customButton6_5 onAction
Sub BEN5Link(control As IRibbonControl)
    
    If ActiveWorkbook Is Nothing Then
        MsgBox "開いてるファイルがありません", vbInformation + vbOKOnly, "Cellsサポートバー"
        Exit Sub
    End If
    
    If MsgBox("このファイルを添付して「セルズ　info@cells.co.jp」に送信しますか？", vbOKCancel, "送信") <> vbOK Then
        Exit Sub
    End If
    
    On Error GoTo ERR_ROUTIN
    ActiveWorkbook.SendMail Recipients:="info@cells.co.jp" 'ショートカットキー　M
    Exit Sub
ERR_ROUTIN:
    If Err.Number = 1004 And Err.Description = ERR_MSG_SENDMAIL Then
        Debug.Print Err.Description
    Else
        Err.Raise Err.Number, Err.Source, Err.Description
    End If
End Sub
'Callback for customButton6_6 onAction
Sub BEN6Link(control As IRibbonControl)
    
    Application.ScreenUpdating = False
    Workbooks.Open ThisWorkbook.Path & "\Ribbon\QA.xls"
    ActiveWorkbook.Unprotect
    Application.Run "QA.xls!初期処理"
    
    ActiveWorkbook.Protect
    Application.ScreenUpdating = True

End Sub
'Callback for customButton6_7 onAction
Sub BEN7Link(control As IRibbonControl)
    
    If ActiveWorkbook Is Nothing Then
        MsgBox "開いてるファイルがありません", vbInformation + vbOKOnly, "Cellsサポートバー"
        Exit Sub
    End If
    
                                                    '#38933 taka 20170921
                                                '    F出力.Show
    F出力.Show 0
    
End Sub

'#38933 taka 20170921
Sub file_export()
    
    If ActiveWorkbook Is Nothing Then
        MsgBox "開いてるファイルがありません", vbInformation + vbOKOnly, "Cellsサポートバー"
        Exit Sub
    End If
    
    F出力.Show 0
    
End Sub

'Callback for customButton6_7 onAction
Sub BEN8Link(control As IRibbonControl)
    
   frmContact.Show
    
End Sub
'Callback for customButton1_1 onAction
Sub DAALink(control As IRibbonControl)
  Dim rc As Long
  rc = ShellExecute(0, "Open", DAITYO_A_WEB, "", "", 1)
End Sub
'Callback for customButton1_2 onAction
Sub DBLink(control As IRibbonControl)
  Dim rc As Long
  rc = ShellExecute(0, "Open", DAITYO_B_WEB, "", "", 1)
End Sub
'20161212 kon  #35663
Sub DBCLink(control As IRibbonControl)
  Dim rc As Long
  rc = ShellExecute(0, "Open", KYUYO_C_WEB, "", "", 1)
End Sub



'Callback for customButton1_3 onAction
Sub DCLink(control As IRibbonControl)
  Dim rc As Long
'  rc = ShellExecute(0, "Open", DAITYO_C_WEB & Month(Now()) & "m", "", "", 1)
   rc = ShellExecute(0, "Open", DAITYO_C_WEB, "", "", 1)
End Sub
'Callback for customButton1_4 onAction
Sub DDLink(control As IRibbonControl)
  Dim rc As Long
  rc = ShellExecute(0, "Open", DAITYO_D_WEB & Month(Now()), "", "", 1)
End Sub
'Callback for customButton1_5 onAction
Sub DELink(control As IRibbonControl)
  Dim rc As Long
  rc = ShellExecute(0, "Open", DAITYO_E_WEB, "", "", 1)
End Sub
'Callback for customButton1_6 onAction
Sub DFLink(control As IRibbonControl)
  Dim rc As Long
  rc = ShellExecute(0, "Open", DAITYO_F_WEB, "", "", 1)
End Sub
'Callback for customButton1 onAction
Public Sub DSlink(ByRef control As IRibbonControl)
    'OpenLink DAITYO_WEB & "?s=" & UrlEncodeUtf8(mDFindText)
    '2016/1/18 清水
    'Dim frm As New SearchForm
    
    'frm.SoftFlg = 台帳
    'frm.Show
    '30055 Q&Aページ表示処理 20160126 hara
    Dim findPoint As Long
    IsDaityo = True
    IsKyuyo = False
    TagName = ActiveWorkbook.Name

    findPoint = InStr(TagName, "da.xls")
    'アクティブなブックが事業所名da.xlsだった場合
    If findPoint > 0 Then
        'daの文字を抜き取り、それをタグ名とする
        TagName = Mid(TagName, findPoint, 2)
    Else
'        事業所のファイル名をタグ名とする
        findPoint = InStrRev(TagName, ".")
        TagName = Left(TagName, findPoint - 1)
    End If
    
    qaView.Show
    
End Sub
'Callback for customButton2_1 onAction
Sub KALink(control As IRibbonControl)
  Dim rc As Long
  rc = ShellExecute(0, "Open", KYUYO_A_WEB, "", "", 1)
End Sub
'Callback for customButton2_2 onAction
Sub KBLink(control As IRibbonControl)
  Dim rc As Long
  rc = ShellExecute(0, "Open", KYUYO_B_WEB, "", "", 1)
End Sub
'Callback for customButton2 onAction
Sub KSlink(control As IRibbonControl)
'    Dim rc As Long
'    rc = ShellExecute(0, "Open", KYUYO_WEB & "?s=" & UrlEncodeUtf8(mKFindText), "", "", 1)
    
    '2016/1/18 清水
    'Dim frm As New SearchForm
    'frm.SoftFlg = 給与
    'frm.Show
    '30055 Q&Aページ表示処理 20160126 hara
    Dim findPoint As Long
    IsDaityo = False
    IsKyuyo = True
    
    TagName = ActiveWorkbook.Name
    findPoint = InStr(TagName, "kk.xls")
    'アクティブなブックが事業所名kk.xlsだった場合
    If findPoint > 0 Then
        'kkの文字を抜き取り、それをタグ名とする
        TagName = Mid(TagName, findPoint, 2)
    Else
        '事業所のファイル名をタグ名とする
        findPoint = InStrRev(TagName, ".")
        TagName = Left(TagName, findPoint - 1)
    End If
    
    qaView.Show
    
End Sub

'#35156 hara 20170321
'Callback for customButton2_5 onAction
Sub WEBLink(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", WEBLOGIN, "", "", 1)
    
End Sub
''Callback for customButton3_1 onAction
'Sub IALink(control As IRibbonControl)
'    Dim rc As Long
'    rc = ShellExecute(0, "Open", INFO_A_WEB, "", "", 1)
'End Sub
'
''Callback for customButton3_2 onAction
'Sub IBLink(control As IRibbonControl)
'    Dim rc As Long
'    rc = ShellExecute(0, "Open", INFO_B_WEB, "", "", 1)
'End Sub
'
''Callback for customButton3_3 onAction
'Sub ICLink(control As IRibbonControl)
'    Dim rc As Long
'    rc = ShellExecute(0, "Open", INFO_C_WEB, "", "", 1)
'End Sub
'
''Callback for customButton3_4 onAction
'Sub IDLink(control As IRibbonControl)
'    Dim rc As Long
'    rc = ShellExecute(0, "Open", INFO_D_WEB, "", "", 1)
'End Sub

'Callback for customButton4_1 onAction
Sub SALink(control As IRibbonControl)
  Dim rc As Long
  rc = ShellExecute(0, "Open", SHOPING_A_WEB, "", "", 1)
End Sub

'Callback for customButton4_2 onAction
Sub SBLink(control As IRibbonControl)
  Dim rc As Long
  rc = ShellExecute(0, "Open", SHOPING_B_WEB, "", "", 1)
End Sub
'Callback for Hyojyun onAction
Sub getSelectedItemIndex(control As IRibbonControl, id As String, index As Integer)
    Dim rc As Long
    rc = ShellExecute(0, "Open", "http://www.team-cells.jp/hyoujyun/hyoujyunhousyu.php?ken=" & UrlEncodeUtf8("沖縄県"), "", "", 1)
End Sub
'Callback for customButton7_1 onAction
Sub OHLink1(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", INFO_A_WEB, "", "", 1)
End Sub

'Callback for customButton7_2 onAction
Sub OHLink2(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", INFO_B_WEB, "", "", 1)
End Sub

'Callback for customButton7_3 onAction
Sub OHLink3(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", INFO_C_WEB, "", "", 1)
End Sub

'Callback for customButton7_4 onAction
Sub OHLink4(control As IRibbonControl)
    Dim rc As Long
    rc = ShellExecute(0, "Open", INFO_D_WEB, "", "", 1)
End Sub

'Callback for customButton7_5 onAction
Sub OHLink5(control As IRibbonControl)
  Dim rc As Long
  rc = ShellExecute(0, "Open", INFO_E_WEB, "", "", 1)
End Sub

'Callback for customButton7_6 onAction
Sub OHLink6(control As IRibbonControl)
  Dim rc As Long
  rc = ShellExecute(0, "Open", INFO_F_WEB, "", "", 1)
End Sub
'Callback for customButton8_1 onAction
Sub CALink(control As IRibbonControl)
  Dim rc As Long
  rc = ShellExecute(0, "Open", CHUMON_A_WEB, "", "", 1)
End Sub
'Callback for customButton8_2 onAction
Sub CBLink(control As IRibbonControl)
  Dim rc As Long
  rc = ShellExecute(0, "Open", CHUMON_B_WEB, "", "", 1)
End Sub

Attribute VB_Name = "SearchForm"
Attribute VB_Base = "0{BEA960F7-0567-4F60-939F-20A6FAFACCE8}{5B07B42C-4342-4E78-AE1F-D6EE46674DF4}"
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 SOFT_FLG
    台帳 = 1
    給与 = 2
End Enum
Private mSoftFlg As SOFT_FLG
Public Property Get SoftFlg() As SOFT_FLG
    SoftFlg = mSoftFlg
End Property
Public Property Let SoftFlg(ByVal value As SOFT_FLG)
    mSoftFlg = value
    
    Dim CaptionString As String
    
    Select Case value
        Case 台帳
            CaptionString = "台帳"
        Case 給与
            CaptionString = "Cells給与"
        Case Else
            CaptionString = "台帳"
    End Select
    
    Me.Caption = CaptionString & "の検索"
    
End Property
Private Sub cmdSearch_Click()
    
    Dim UrlString As String
    
    Select Case mSoftFlg
        Case 台帳
            UrlString = DAITYO_WEB
        Case 給与
            UrlString = KYUYO_WEB
        Case Else
            UrlString = DAITYO_WEB
    End Select
    
    OpenLink UrlString & "?s=" & UrlEncodeUtf8(txtSearch.Text)

    Unload Me

End Sub


Attribute VB_Name = "Upload"
Attribute VB_Base = "0{E7D3009F-EA57-42ED-AF37-CF091179759A}{7CCE176D-D169-4C9B-BEAE-1BD40C38DB39}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
Option Explicit
Private Sub CommandButton1_Click()
        Dim MyClipboard As New DataObject
        Dim hensuu1 As String
        Dim hensuu2 As String
        Dim d1      As Object
        
        WebWindow.Application.SetFocus
        
        hensuu1 = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name '現在開いているファイルを取得する
        With MyClipboard
            .SetText hensuu1 'テキスト文字列をDataObjectにコピー
            .PutInClipboard 'DataObjectのデータをクリップボードに移動
        End With
                
        Application.Wait Time:=Now + TimeValue("00:00:02")  '2秒間 ボーっとする、ボーっとしないとsendkeyが使えない場合がある。
        
        WebWindow.Application.SetFocus
        DoEvents
        SendKeys "{TAB}"
        SendKeys "{TAB}"
        SendKeys "^v"  'パスをsendkeyで貼り付ける（input type="file"はsendkeyでないと貼りつかない）
        Set MyClipboard = Nothing
End Sub
Private Sub UserForm_Activate()

        Dim MyClipboard As New DataObject
        Dim hensuu1 As String
        Dim hensuu2 As String
        Dim d1      As Object
        Dim SendButton As Object
        
        If ActiveWorkbook Is Nothing Then
            MsgBox "開いてるファイルがありません", vbInformation + vbOKOnly, "Cellsサポートバー"
            Unload Me
            Exit Sub
        End If
        
        WebWindow.Navigate "http://www.team-cells.jp/php01/fileupload.html" 'HP開く
        DoEvents
        
        hensuu1 = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name '現在開いているファイルを取得する
        With MyClipboard
            .SetText hensuu1 'テキスト文字列をDataObjectにコピー
            .PutInClipboard 'DataObjectのデータをクリップボードに移動
        End With

'20100205 kon
        If ieChk >= 8 Then
            MsgBox "参照ボタンをクリックし、ファイル名に右クリック→貼り付けして下さい。", vbInformation, "アップロード"
        Else
            Application.Wait Time:=Now + TimeValue("00:00:02")  '2秒間 ボーっとする、ボーっとしないとsendkeyが使えない場合がある。
            WebWindow.Application.SetFocus
            DoEvents
            SendKeys "{TAB}"
            SendKeys "{TAB}"
            SendKeys "^v"  'パスをsendkeyで貼り付ける（input type="file"はsendkeyでないと貼りつかない）
            Set MyClipboard = Nothing
        End If
End Sub

Attribute VB_Name = "Progressing"
Attribute VB_Base = "0{1FF8D95C-9FEE-4B42-B765-183734F29CBD}{3C2E8698-2B79-47C8-90A5-96EB22BAA7C0}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False

Attribute VB_Name = "機密保持契約2"
Attribute VB_Base = "0{0B52AEB8-7DA0-4871-8BF6-E22FA860DED6}{D3E57945-5A0C-4183-AF0A-60293CBE40E3}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False


Option Explicit
Private Sub CheckBox1_Click()
    If CheckBox1.value = True Then
        CommandButton1.Enabled = True
    Else
        CommandButton1.Enabled = False
    End If
End Sub

Private Sub CommandButton1_Click()
    '機密保持契約画面を閉じて、ファイルアップロード画面を表示
    Unload Me
End Sub


…