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
#If Win64 Then
''' 64bit Excelの場合
    Private Sub Workbook_Open()
        Dim str As String
        str = "64bit版 Excelでは、本ソフトはご利用できません。"
        str = str & vbCrLf & "32bit版 Excelをご用意ください。"
        MsgBox str, vbExclamation + vbOKOnly, "台帳"
        ThisWorkbook.Close
    End Sub
#Else
''' 32bit Excelの場合
Private Sub Workbook_Open()
    
    Dim wb As Object, ブックの数 As Integer
    Dim VerNo As String
    Dim YMString As String
    Dim MyStr1 As String
    Dim MyStr2 As String


'ネットワーク判定
    If StrConv(Dir(ThisWorkbook.path & "\CSV\daityoN.ccf"), vbUpperCase) <> "DAITYON.CCF" Then
'20080414 KON
'        Call NetWorkCheck
        errStr = NetWorkCheck()
        If errStr <> "" Then
'            On Error Resume Next
            ブックの数 = 0
            For Each wb In Application.Workbooks
                If UCase(wb.Name) <> "PERSONAL.XLS" And UCase(wb.Name) <> "DaAddin.xla" Then
                    ブックの数 = ブックの数 + 1
                End If
            Next wb
            MsgBox errStr, vbInformation, "台帳"
            Application.DisplayAlerts = False
            
            If ブックの数 = 1 Then
                Application.DisplayAlerts = False
                Application.Quit
                Application.DisplayAlerts = True
                Exit Sub
            Else
                Application.DisplayAlerts = False
                ThisWorkbook.Close
                Application.DisplayAlerts = True
                Exit Sub
            End If
        End If
    End If
    
    '事務組合判定
    If StrConv(Dir(ThisWorkbook.path & "\CSV\jFile.dat"), vbUpperCase) = "JFILE.DAT" Then
        'メニューに表示
        ThisWorkbook.Worksheets("MENU").Range("C94").Value = "TypeG"
    End If
    
    'バージョン番号取得
    GetVerText VerNo, YMString
    
    Workbooks.Open ThisWorkbook.path & "\DaAddin.xla"
    
    Workbooks.Open ThisWorkbook.path & "\DaProcess\eGov\EAppCom.xla" '20120927 電子申請用
    
    '保守番号等取得
    Dim TextFilename As String
    Dim f As Integer
    
    f = FreeFile
    TextFilename = ThisWorkbook.path & "\DaProcess\保守契約番号.txt"
    Open TextFilename For Input As #f
        Input #f, MyStr1 'ID
        Input #f, MyStr2 'LiveUpdateするかどうか
    Close #f

    If Len(Trim(MyStr1)) = 0 Then
        MyStr2 = "#FALSE#"
    End If

    'バージョン番号を表示
    ThisWorkbook.Worksheets("MENU").Shapes("テキスト ボックス 2").TextFrame.Characters.Text = "Ver." & VerNo
    ThisWorkbook.Worksheets("MENU").Shapes("Rectangle 4").TextFrame.Characters.Text = YMString
  
    'プログラムをダウンロードするか否かを確認
    Dim IsLiveUpdate As Boolean
    IsLiveUpdate = False
        
    If MyStr2 = "#TRUE#" And ThisWorkbook.ReadOnly = False Then
        'LiveUpdateする
        Application.ScreenUpdating = False          '画面を更新しない
        IsLiveUpdate = LiveUpdate(MyStr1, VerNo)
        Application.ScreenUpdating = True           '画面を更新する
    End If
    
    '元AutoOpenの処理
    Init IsLiveUpdate
''' End YBNO 299 笹 LiveUpdate修正
    Application.ScreenUpdating = False
    If Dir(ThisWorkbook.path & "\賃金管理\Addtin.xls") <> "" Then
        Workbooks.Open ThisWorkbook.path & "\賃金管理\Addtin.xls", ReadOnly:=True
        Workbooks("Addtin.xls").Worksheets("MENU").Shapes("SOGO").Visible = False
        Application.Windows("Addtin.xls").Visible = False
    End If
    
    'バージョン確認して、セルズサポートリボンを加える
    If Not Left(Application.Version, 2) < 12 Then
        On Error Resume Next
        If Not IsExistRibbon("セルズサポート") Then
            Workbooks.Open(FileName:= _
            ThisWorkbook.path & "\CellsSupport.xlam").RunAutoMacros Which:=xlAutoOpen
        End If
        On Error GoTo 0
    End If

End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    If ThisWorkbook.Worksheets("MENU").Cells(1, 50).Value <> 1 Then
        If ActiveWorkbook.Name = ThisWorkbook.Name Or ActiveWorkbook.Name Like "*da.xls" Then
            MsgBox "「終了」ボタンから終了してください。", vbInformation, "台帳MENU"
            Cancel = True
        Else
            If MsgBox("台帳の関連ファイルの終了は「終了」または「閉じる」ボタンから実行してください。" & Chr(10) & "「終了」等のボタンが無い場合のみ終了します。" & Chr(10) & "終了しますか？", 4 + 32, "終了") = 6 Then
            ActiveWorkbook.Close False
            Else
            Cancel = True
            End If
        End If
    End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Cancel = True
MsgBox "このファイルは保存することはできません。", 16, "保存"
End Sub
'20101228 メニューのバージョン番号と更新年月を表示するための取得メソッド
Private Sub GetVerText(ByRef no As String, ByRef ym As String)

    Dim TextFilename As String
    Dim f As Integer
    
    TextFilename = ThisWorkbook.path & "\ver.txt"
    f = FreeFile()
    
    Open TextFilename For Input As #f
        Input #f, no
        Input #f, ym
    Close #f

End Sub
Private Function IsFileExist(ByVal FolderName As String) As Boolean

    Dim FSO As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If FSO.GetFolder(FolderName).Files.Count > 0 Then
        IsFileExist = True
    Else
        IsFileExist = False
    End If
    
    Set FSO = Nothing

End Function
Private Function IsFolderExist(ByVal FolderName As String, Optional ByVal Sw As Boolean = False) As Boolean

    Dim FSO As Object
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If FSO.FolderExists(FolderName) Then
        IsFolderExist = True
    Else
        If Sw Then
            FSO.CreateFolder FolderName
            IsFolderExist = True
        Else
        IsFolderExist = False
        End If
    End If
    
    Set FSO = Nothing

End Function
'End 20101228 メニューのバージョン番号と更新年月を表示するための取得メソッド
#End If


Attribute VB_Name = "StatupModule"
Option Explicit
#If Win64 Then
#Else
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 CallMe()
'  '引数はカスタムタブ(tab要素)のlabel属性の値,もしくは"アドイン"
'  Call SelRibbonTAB("セルズサポート")
'End Sub
Public Function IsExistRibbon(ByVal myTabName As String) As Boolean
    
    Dim ret As Boolean
    Dim myAcc As Office.IAccessible
    
    Set myAcc = Application.CommandBars("Ribbon")
    Set myAcc = GetAcc(myAcc, "リボン タブ", ROLE_SYSTEM_PAGETABLIST)
    
    Set myAcc = GetAcc(myAcc, myTabName, ROLE_SYSTEM_PAGETAB)
    
    If myAcc Is Nothing Then
        ret = False
    Else
        ret = True
    End If
    
    Set myAcc = Nothing
    
    IsExistRibbon = ret

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
#End If

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
Private Sub CommandButton1_Click()
    
    Call 終了

End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    
    ''' YBNO2475 グループ化画面と処理を共通化する
    'Call 開く
    Call 開く(ActiveCell.Value)
    ''' END YBNO2475 グループ化画面と処理を共通化する

End Sub

Attribute VB_Name = "Sheet5"
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 = "Sheet6"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True
Option Explicit

Attribute VB_Name = "今日生まれた人は"
Attribute VB_Base = "0{75E430E3-9082-4577-B42F-10DFAE0061C6}{C7D6F7A7-C86E-4ED0-8048-BA62749A75B0}"
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
Dim 待った As Boolean
Private Sub CommandButton1_Click()
    If CommandButton1.Caption = "STOP" Then
        待った = True
        DoEvents
        CommandButton1.Caption = "更新"
    Else
    If MsgBox("誕生日データを更新しますか？", 4 + 32, "更新") <> 6 Then Exit Sub
        If Dir(ThisWorkbook.path & "\DaProcess\MyTool\誕生日チェック年齢検索対象リスト.dat") = "" Then
            MsgBox "誕生日データが一度も作成されていません。初めてのリスト作成はこのボタンから実行できませんので、このシートの「検索と抽出」の「誕生日」からおこなってください。", 48, "リスト更新"
            Exit Sub
        End If
        Application.ScreenUpdating = False
        Workbooks.Open ThisWorkbook.path & "\DaProcess\誕生日チェック.xls", ReadOnly:=True
        Application.Run ActiveWorkbook.Name & "!初期処理"
    End If
    DoEvents
End Sub

Private Sub UserForm_Activate()
    Dim MyStr As String
    Dim i As Integer
    Dim j As Integer
    
    Dim TextFilename As String
    Me.Caption = Format(Date, "M月D日") & "  Happy Birthday !! "
    待った = False
    TextFilename = ThisWorkbook.path & "\CSV\DAY\1" & Format(Date, "MMDD") & ".dat"
    Open TextFilename For Input As #1
        Input #1, MyStr
            Label1.Caption = "今日は" & MyStr
        Input #1, MyStr
            Label4.Caption = MyStr
        Do Until EOF(1)
            Input #1, MyStr
            ListBox1.AddItem MyStr
        Loop
    Close #1
    If Application.Wait(Now + TimeSerial(0, 0, Cells(3, 17).Value)) Then
        DoEvents
        If 待った = True Then Exit Sub
        Unload Me
    End If
End Sub

Attribute VB_Name = "Check"
Attribute VB_Base = "0{5378E827-357D-4498-9DE3-F04A5F79AA19}{D3132C36-6383-47C3-8D05-22F9BBAC1CF4}"
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()
    Call チェック("年齢チェック.xls")
End Sub
Private Sub CommandButton2_Click()
    Call チェック("月変チェック.xls")
End Sub
Private Sub CommandButton3_Click()
    Call チェック("取得チェック.xls")
End Sub
Private Sub CommandButton4_Click()
    Call チェック("給与チェック.xls")
End Sub
Private Sub チェック(ファイル As String)
    Application.ScreenUpdating = False
    Unload Me
    Workbooks.Open FileName:=ThisWorkbook.path & "\DaProcess\" & ファイル
    ActiveSheet.EnableSelection = xlUnlockedCells
    ActiveSheet.Protect UserInterfaceOnly:=True
    ActiveWindow.DisplayHeadings = False
    ActiveWindow.DisplayWorkbookTabs = False
    Application.ScreenUpdating = True
    Application.Run ファイル & "!CHECKFへ"
End Sub
Private Sub CommandButton5_Click()
Call チェック("誕生日チェック.xls")
End Sub


Attribute VB_Name = "Module2"
Option Explicit
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
Sub End1()
''' YBNO 2032 Ontimeの設定を反映させる
    'Application.OnTime Now() + TimeValue("00:00:1"), "End2"
    Dim n As Long
    n = GetTextData(1, ThisWorkbook.path & "\DaProcess\MyTool\Ontime.dat")
    Application.OnTime Now + TimeValue("00:00:0" & n), "End2"
End Sub
Sub End2()
ActiveWorkbook.Close False
End Sub
'-----------------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------------
'20100903masa　テキスト読み込み　書き込み　関係
'
'
Public Function GetTextData(ByVal i As Integer, ByVal FileName As String) As String
  
    Dim buffer() As String '文字列受け取り用
    
    GetStringArray buffer, FileName

    GetTextData = buffer(i - 1)

End Function
Public Sub SetTextData(ByVal i As Integer, ByVal str As String, ByVal FileName As String)

    '先に全部読み込む

    Dim buffer() As String '文字列受け取り用
    
    GetStringArray buffer, FileName
    
    '書き換えたい文字列
    buffer(i - 1) = str
    
    Dim FileNumber As Integer 'ファイル番号
    Dim LineCount As Integer '行数

    '初期処理
    FileNumber = FreeFile
    LineCount = 0

    'DOTO FreeFileで番号を得ること
    Open FileName For Output As #FileNumber

    For LineCount = 0 To UBound(buffer)
            'ファイルをバイナリで読み込んで配列に格納
            Print #FileNumber, buffer(LineCount)
    Next
           
    Close #FileNumber
    
End Sub
Public Sub GetStringArray(ByRef str() As String, ByVal FileName As String)

    Dim FileNumber As Integer 'ファイル番号
    Dim LineCount As Integer '行数

    '初期処理
    FileNumber = FreeFile
    LineCount = 0

    'DOTO FreeFileで番号を得ること
    Open FileName For Input As FileNumber

        Do While Not EOF(FileNumber)
            'ファイルの長さで配列をデータを保持しながら初期化
            ReDim Preserve str(LineCount)
    
            'ファイルをバイナリで読み込んで配列に格納
            Line Input #FileNumber, str(LineCount)
            LineCount = LineCount + 1
        Loop
           
    Close #FileNumber

End Sub
Public Function PathCombine(ByVal str1 As String, ByVal str2 As String) As String

    If Right(str1, 1) = "\" Then
        PathCombine = str1 & str2
    Else
        PathCombine = str1 & "\" & str2
    End If
'
'
'
'20100903masa　テキスト読み込み　書き込み　関係ここまで
'-----------------------------------------------------------------------------------------------------
'-----------------------------------------------------------------------------------------------------
End Function
''' YBNO 2032 Ontimeの設定を反映させる
Public Function IsOpen(ByVal BookName As String) As Boolean

    Dim ret As Boolean
    Dim wb As Excel.Workbook

    ret = False

    For Each wb In Workbooks
        If wb.Name = BookName Then
            ret = True
            Exit For
        End If
    Next

    IsOpen = ret

End Function


Attribute VB_Name = "frmUser"
Attribute VB_Base = "0{FC934D57-9CEA-4A51-BD5A-3B133696383B}{10FDE942-CE02-413C-8453-BF349D89F7B3}"
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 cmdYomikomi_Click()
        Call yomikomiRtn
End Sub
Private Sub UserForm_Initialize()
    Dim ファイル名  As String
    
    ListBox1.Clear
    ファイル名 = Dir(ThisWorkbook.path & "\DaProcess\Da保存\ユーザーフォルダ\", vbDirectory)
    
    ' 現在のフォルダと親フォルダは無視します。
    With ListBox1
 
        Do While ファイル名 <> ""
            If ファイル名 <> "." And ファイル名 <> ".." Then
                .AddItem ファイル名
            End If
            ファイル名 = Dir()
        Loop
    End With

End Sub
Sub yomikomiRtn()
    
    Dim iCnt        As Integer
    
    For iCnt = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(iCnt) = True Then
            Workbooks.Open FileName:=ThisWorkbook.path & "\DaProcess\Da保存\ユーザーフォルダ\" & ListBox1.List(iCnt)
            On Error Resume Next
            Application.Run ListBox1.List(iCnt) & "!Auto_Open"
            Application.Run ListBox1.List(iCnt) & "!初期処理"
            On Error GoTo 0
            Exit For
        End If
    Next iCnt
    Unload Me
End Sub

Attribute VB_Name = "セル確認"
Attribute VB_Base = "0{411A8DC3-E898-4C23-9A88-46DB40CA8F11}{EAA11E6C-012B-4EF5-8A9C-BD127F7B8627}"
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()
    On Error GoTo check
    With Worksheets(ComboBox1.Value)
        .EnableSelection = xlUnlockedCells
        .Protect UserInterfaceOnly:=True
        .Cells(Val(TextBox1.Value), Val(TextBox2.Value)).Value = TextBox3.Text
    End With
    MsgBox "OK"
    Unload Me
    Exit Sub
check:
    MsgBox "エラー"
End Sub
Private Sub CommandButton2_Click()
    On Error GoTo check
    With Worksheets(ComboBox1.Value)
        .Unprotect
        TextBox3.Value = .Cells(Val(TextBox1.Value), Val(TextBox2.Value)).FormulaR1C1
    End With
    Exit Sub
check:
    MsgBox "エラー"
End Sub
Private Sub UserForm_Initialize()
    Dim S As Worksheet
    For Each S In Worksheets
        ComboBox1.AddItem S.Name
    Next
    ComboBox1.Value = ActiveSheet.Name
End Sub


Attribute VB_Name = "シート"
Attribute VB_Base = "0{800ED33A-4A80-44AD-8B48-68E8B05B0BA5}{A02DDC50-879F-4338-B99B-1DCE1A888D89}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False







Private Sub CommandButton1_Click()
    If ListBox1.ListIndex = -1 Then
        MsgBox "シートが選択されていません", 16, AA
    Else
        Sheets(ListBox1.Value).Select
        Unload Me
    End If
End Sub
Private Sub UserForm_Initialize()
Dim S As Worksheet
  For Each S In Worksheets
    With S
      ListBox1.AddItem S.Name
    End With
Next
End Sub

Attribute VB_Name = "社労士事務所"
Attribute VB_Base = "0{04B864B5-8BE5-4489-A5C9-93E89C6D1E9D}{3C38A12C-E179-49C6-9155-01D90FE57276}"
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 i As Integer
    Dim no As String
    If Trim(TextBox4.Value) = "" Then
        MsgBox "社労士データが登録されていないデータは切り替えることができません。", 16, "切替"
        Exit Sub
    End If
    If MsgBox("社労士データを切り替えますか？", 1 + 32, "社労士データ") <> 1 Then Exit Sub
    For i = 1 To 5 '読み込むファイル名の末尾の番号を取得する
        If Controls("OptionButton" & i).Value = True Then
            no = Format(i, "#")
        Exit For
    End If
    
    Next
    If no = "1" Then '１は空欄にする
        no = ""
    End If
    Dim MyF As String
    Application.Calculation = xlCalculationManual
    With ThisWorkbook.Worksheets("標準報酬月額")
            For i = 1 To 9
                .Cells(150 + i, 7).Value = Controls("TextBox" & i).Value
            Next
        .Cells(150, 8).Value = no '印
    End With
    Application.Calculation = xlCalculationAutomatic
    MsgBox "切り替えました。", 64, "社労士データの切替"
    Unload Me
End Sub
Private Sub OptionButton1_Click()
Call 事務所情報の読込("")
End Sub
Private Sub OptionButton2_Click()
Call 事務所情報の読込("2")
End Sub
Private Sub OptionButton3_Click()
Call 事務所情報の読込("3")
End Sub
Private Sub OptionButton4_Click()
Call 事務所情報の読込("4")
End Sub
Private Sub OptionButton5_Click()
Call 事務所情報の読込("5")
End Sub

Private Sub UserForm_Initialize()
    Dim no As String
    no = ThisWorkbook.Worksheets("標準報酬月額").Cells(150, 8).Value
    If no = "" Then '空欄だったら
        no = "1"
    End If
    Controls("OptionButton" & no).Value = True
End Sub
Sub 事務所情報の読込(no As String)
    Dim i As Integer
    Dim TextFilename As String
    Dim MyStr As String
    Dim mCnt    As Integer  '20100528 kon
    
    
    On Error GoTo ERRORC
'20100528 kon
    If no = "" Then
        mCnt = 9
    Else
        mCnt = 10
    End If
    
    TextFilename = ThisWorkbook.path & "\DaProcess\MyTool\ZimusyoJoho" & no & ".dat"
'20100528 kon
'    For i = 1 To 10
    For i = 1 To mCnt
         Controls("TextBox" & i).Value = ""
    Next
    
    Open TextFilename For Input As #1
'20100528 kon
'    For i = 1 To 10
        For i = 1 To mCnt
            Input #1, MyStr
            Controls("TextBox" & i).Value = MyStr
        Next
    Close #1
Exit Sub
ERRORC:
'20070620 kon
'TextBox4.Value = ""
'20091018 masaya
For i = 1 To 10
     Controls("TextBox" & i).Value = ""
Next
On Error Resume Next
Close #1
On Error GoTo 0
End Sub



Attribute VB_Name = "セル移動"
Attribute VB_Base = "0{AC5705FD-719A-4C19-9F8F-362BF9B39069}{9398F558-B27E-492E-A245-8EAD67FFB6DF}"
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 CommandButton7_Click()
下へ1
End Sub

Private Sub CommandButton8_Click()
上へ1
End Sub

Private Sub CommandButton5_Click()
右へ1
End Sub

Private Sub CommandButton6_Click()
左へ1
End Sub


Attribute VB_Name = "frm開く"
Attribute VB_Base = "0{14EC5622-72E2-448A-AEBE-0431F7CEB4CC}{245872B0-2AC9-4885-8F44-3ACF88599B5A}"
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
Dim ListNo As Integer
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    'このマクロを編集する場合は「開く」も編集すること->しなくてもよいように共通化します
Dim Msg As Integer
Dim MyB As String
If ListBox1.ListIndex = -1 Then Exit Sub
''' YBNO 2475 グループ化画面のために共通化する
    開く ListBox1.Value
'    Dim Wb As Workbook
'    For Each Wb In Workbooks
'        If Wb.Name = ListBox1.Value & "da.xls" Then
'            Wb.Activate
'            Exit Sub
'        End If
'    Next
'    If Dir(ThisWorkbook.path & "\" & ListBox1.Value & "da.xls") <> "" Then
'        If ActiveWorkbook.Name Like "*da.xls" Then
'        Msg = MsgBox(Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 6) & "を閉じます。この台帳を保存しますか？", 3 + 64, "読込")
'        MyB = ActiveWorkbook.Name
'        If Msg = 2 Then Exit Sub
'        End If
'
'        Workbooks.Open ThisWorkbook.path & "\" & ListBox1.Value & "da.xls"
'        Sheets("MENU").Select
'        Application.ScreenUpdating = False
'        If Cells(6, 5).Value < 7.6 Or Mid(Worksheets("MENU").Cells(6, 5).Value, 1, 1) = "V" Then
'            If ActiveWorkbook.ReadOnly = True Then
'                MsgBox "この事業所台帳はバージョンが古いため、バージョンアップする必要がありますが、読み取り専用で開かれたため処理することができません。" & Chr(10) & _
'                "一旦この事業所台帳を閉じますので後で再度起動してください。", 16, "アップ"
'                ActiveWorkbook.Close False
'                Exit Sub
'            End If
'            Workbooks.Open ThisWorkbook.path & "\VerUp.xla"
'            Application.Run "VerUp.xla!初期処理"
'
'        Else
'        Application.Run "'" & ActiveWorkbook.Name & "'!初期処理"
'        End If
'        If Msg = 6 Then
'        Workbooks(MyB).Save
'        Workbooks(MyB).Close False
'        ElseIf Msg = 7 Then
'        Workbooks(MyB).Close False
'        End If
'    Else
'        MsgBox "この台帳は存在しません。", 16, "台帳"
'        Exit Sub
'    End If
''' END YBNO 2475 グループ化画面のために共通化する
    Application.ScreenUpdating = True
    Unload Me

End Sub

Private Sub ListBox2_Click()
    If ListBox2.ListIndex = -1 Then Exit Sub
    If ListBox2.ListIndex = 0 Then
        ListBox1.Clear
        Dim ファイル名 As String
        Dim i As Integer
        ファイル名 = Dir(Workbooks("DaMenu.xls").path & "\*da.xls") '台帳ファイル
        Do While ファイル名 <> "" 'ファイルなくなるまで
                ListBox1.AddItem Left(ファイル名, Len(ファイル名) - 6)
                ファイル名 = Dir()
        Loop
    Else
        ListNo = ListBox2.ListIndex
        リスト表示
    End If
End Sub
Private Sub UserForm_Initialize()
    Dim TextFilename As String
    Dim MyData(1) As String
    Dim i As Integer
    ListBox2.AddItem "すべての台帳"
    TextFilename = ThisWorkbook.path & "\DaProcess\MyTool\FileList.dat"
    Open TextFilename For Input As #1
        For i = 1 To 20
            Input #1, MyData(1)
            ListBox2.AddItem MyData(1)
        Next
    Close #1
    ListBox2.ListIndex = 0
End Sub
Private Sub リスト表示()
    ListBox1.Clear
    Dim TextFilename As String
    Dim MyData(1) As String
    TextFilename = ThisWorkbook.path & "\DaProcess\MyTool\FileList" & ListNo & ".dat"
    Open TextFilename For Input As #1
        Do Until EOF(1)
            Input #1, MyData(1)
            ListBox1.AddItem MyData(1)
        Loop
    Close #1
End Sub

Attribute VB_Name = "Upload"
Attribute VB_Base = "0{B1FACE3E-708B-4A29-9230-A0EB1703810F}{51FDB025-A4E9-4C48-9BE9-45EA1041C3F2}"
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
        
        
        WebWindow.navigate "http://www.team-cells.jp/php01/fileupload.html" 'HP開く
        DoEvents
         
…