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 Sub Workbook_BeforeClose(Cancel As Boolean)
    ThisWorkbook.Saved = True
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
   MsgBox "このファイルは保存することができません。", 16, "保存不可"
   Cancel = True
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 = "完成工事高F"
Attribute VB_Base = "0{B44BF068-6CC0-471B-AC93-D56D3501765C}{1E8DFEFE-941C-41B6-A28A-3D3B56C33869}"
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()
Application.Calculation = xlCalculationManual
With Workbooks("keisinData.xls").Worksheets("DATA")
    For i = 421 To 575
        If i = 422 Or i = 428 Or i = 434 Or i = 440 Then     'コードは000形式にする
            Controls("Text" & i).Value = Format(Controls("Text" & i).Value, "000")
        End If
        If i = 452 Or i = 458 Or i = 464 Or i = 470 Then      'コードは000形式にする
            Controls("Text" & i).Value = Format(Controls("Text" & i).Value, "000")
        End If
        If i = 483 Or i = 489 Or i = 495 Or i = 501 Then     'コードは000形式にする
            Controls("Text" & i).Value = Format(Controls("Text" & i).Value, "000")
        End If
        If i = 514 Or i = 520 Or i = 526 Or i = 532 Then     'コードは000形式にする
            Controls("Text" & i).Value = Format(Controls("Text" & i).Value, "000")
        End If
        If i = 545 Or i = 551 Or i = 557 Or i = 563 Then     'コードは000形式にする
            Controls("Text" & i).Value = Format(Controls("Text" & i).Value, "000")
        End If
       .Cells(i, 2).Value = Controls("Text" & i).Text
    Next
    For i = 623 To 732
       .Cells(i, 2).Value = Controls("TextBox" & i).Text
    Next

End With
Application.Run "'" & ActiveWorkbook.Name & "'!頁指定へ" '現在表示されている頁を表示する'H16/5/28修正
Application.Calculation = xlCalculationAutomatic

MsgBox "登録しました。", 64, AAA
Unload Me
End Sub
Private Sub CommandButton2_Click()
営業年度.Show
End Sub

Private Sub Text421_Change()
Text422.Value = Cells(Text421.ListIndex + 135, 145).Text
End Sub
Private Sub Text427_Change()
Text428.Value = Cells(Text427.ListIndex + 135, 145).Text
End Sub
Private Sub Text433_Change()
Text434.Value = Cells(Text433.ListIndex + 135, 145).Text
End Sub
Private Sub Text439_Change()
Text440.Value = Cells(Text439.ListIndex + 135, 145).Text
End Sub
Private Sub Text452_Change()
Text453.Value = Cells(Text452.ListIndex + 135, 145).Text
End Sub
Private Sub Text458_Change()
Text459.Value = Cells(Text458.ListIndex + 135, 145).Text
End Sub
Private Sub Text464_Change()
Text465.Value = Cells(Text464.ListIndex + 135, 145).Text
End Sub
Private Sub Text470_Change()
Text471.Value = Cells(Text470.ListIndex + 135, 145).Text
End Sub
Private Sub Text483_Change()
Text484.Value = Cells(Text483.ListIndex + 135, 145).Text
End Sub
Private Sub Text489_Change()
Text490.Value = Cells(Text489.ListIndex + 135, 145).Text
End Sub
Private Sub Text495_Change()
Text496.Value = Cells(Text495.ListIndex + 135, 145).Text
End Sub
Private Sub Text501_Change()
Text502.Value = Cells(Text501.ListIndex + 135, 145).Text
End Sub
Private Sub Text514_Change()
Text515.Value = Cells(Text514.ListIndex + 135, 145).Text
End Sub
Private Sub Text520_Change()
Text521.Value = Cells(Text520.ListIndex + 135, 145).Text
End Sub
Private Sub Text526_Change()
Text527.Value = Cells(Text526.ListIndex + 135, 145).Text
End Sub
Private Sub Text532_Change()
Text533.Value = Cells(Text532.ListIndex + 135, 145).Text
End Sub
Private Sub Text545_Change()
Text546.Value = Cells(Text545.ListIndex + 135, 145).Text
End Sub
Private Sub Text551_Change()
Text552.Value = Cells(Text551.ListIndex + 135, 145).Text
End Sub
Private Sub Text557_Change()
Text558.Value = Cells(Text557.ListIndex + 135, 145).Text
End Sub
Private Sub Text563_Change()
Text564.Value = Cells(Text563.ListIndex + 135, 145).Text
End Sub

Private Sub UserForm_Initialize()
Dim n As Integer
With Workbooks("keisinData.xls").Worksheets("DATA")
    For i = 421 To 575
        Controls("Text" & i).Value = .Cells(i, 2).Text
    Next
    For i = 623 To 732
        Controls("TextBox" & i).Value = .Cells(i, 2).Text
    Next
    For i = 0 To 32
        For n = 421 To 439 Step 6
            Controls("Text" & n).AddItem Cells(135 + i, 146).Value
        Next n
        For n = 452 To 470 Step 6
            Controls("Text" & n).AddItem Cells(135 + i, 146).Value
        Next n
        For n = 483 To 501 Step 6
            Controls("Text" & n).AddItem Cells(135 + i, 146).Value
        Next n
        For n = 514 To 532 Step 6
            Controls("Text" & n).AddItem Cells(135 + i, 146).Value
        Next n
        For n = 545 To 563 Step 6
            Controls("Text" & n).AddItem Cells(135 + i, 146).Value
        Next n
    Next i
End With
For i = 451 To 575 Step 31
    Controls("Text" & i).AddItem "有"
    Controls("Text" & i).AddItem "無"
Next

MultiPage1.Value = 0
End Sub

Attribute VB_Name = "新規作成"
Attribute VB_Base = "0{7D7E24D5-E760-4670-8C78-A4DDB9526A82}{D145D3EA-DBAF-4230-A424-32C8E48F77F4}"
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 msg As Integer
Dim i As Integer
Private Sub CommandButton1_Click()
If TextBox2.Value = "" Then
MsgBox "会社名が入力されていません。"
Exit Sub
End If
msg = MsgBox(TextBox2.Value & "の経審申請ファイルを作成しますか？", 1 + 32, "新規作成")
If msg <> 1 Then
Exit Sub
End If
Dim ファイル名 As String
ファイル名 = Dir(ActiveWorkbook.Path & "\経審\*ks.xls")
   Do While ファイル名 <> ""
          If ファイル名 = TextBox2.Value & "ks.xls" Then
          MsgBox "このファイルはすでに存在します。別の名前で作成してください。"
          TextBox2.SetFocus
          Exit Sub
          End If
        ファイル名 = Dir()
Loop
Unload Me
Cells(30, 2).Value = TextBox2.Value & "の経審申請ファイルを作成しています。しばらくお待ちください・・・"
Application.ScreenUpdating = False
Workbooks.Open Filename:=ActiveWorkbook.Path & "\経審原本.xls"
Worksheets("DATA").Unprotect
Worksheets("DATA").Cells(7, 2).Value = TextBox2.Value
Sheets("MENU").Select
ActiveSheet.Unprotect
Cells(3, 8).Value = TextBox2.Value

Application.DisplayAlerts = False

ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & "\経審\" & TextBox2.Value & "ks.xls"
ActiveWorkbook.Close

Application.DisplayAlerts = True

ThisWorkbook.Activate
ファイル名リスト表示
MsgBox TextBox2.Value & "の経審申請ファイルを作成しました。リストボックスから選択して読込んでください。"
Cells(30, 2).Value = ""
End Sub


Attribute VB_Name = "シート表示"
Option Explicit
Public i As Integer
Public Const AAA As String = "経審申請"
Const SW_SHOWNORMAL = 1
Const SE_ERR_NOASSOC = 31
Const ERROR_FILE_NOT_FOUND = 2&
Dim fname       As String
Public gPage       As Integer
Sub kTorikomi1()
    gPage = 20
    frmKojin.Show
End Sub
Sub kTorikomi2()
    gPage = 67
    frmKojin.Show
End Sub
Sub kTorikomi3()
    gPage = 113
    frmKojin.Show
End Sub
Sub kTorikomi4()
    gPage = 19
    frmKojin.Show
End Sub


Sub 取込み()
    frm取込み.Show
End Sub


Sub ツールへ()
    Dim file_name As Object

    For Each file_name In Windows
        If file_name.Caption Like "*ks.xls" Then
            MsgBox "事業所ファイルを閉じてから行なってください。", 16, AAA
            Exit Sub
        End If
    Next
    Workbooks.Open ThisWorkbook.Path & "\ツール.xls"
    Application.Run "ツール.xls!初期処理"
End Sub
Sub 初期処理()
    Dim strPathName As String
    Dim myFso       As Object
    Dim myName      As String
    Dim MyB         As String
    Dim StartFg     As String
    Dim VerNo       As String

'    StartFg = 0
    Application.Calculation = xlCalculationAutomatic
    

'    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = False
    MyB = ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value
    strPathName = ThisWorkbook.Path & "\経審申請\" & MyB
    Application.Calculation = xlCalculationManual
    
'20130523 kon
'    If Dir(strPathName, vbNormal) <> "" Then
    If Dir(strPathName & "\", vbNormal) <> "" Then
        
        strPathName = ThisWorkbook.Path & "\経審申請\" & MyB & "\keisinData.xls"
        Workbooks.Open strPathName
        バージョンチェック
    Else
        Cells(1, 7).Value = "初期設定中・・・"
        myName = ThisWorkbook.Path & "\経審申請\原本"                                   'コピー元フォルダ
        Set myFso = CreateObject("Scripting.FileSystemObject")
        myFso.CopyFolder myName, strPathName, OverWriteFiles:=True                    'フォルダのコピー
        Set myFso = Nothing
        Cells(1, 7).MergeArea.ClearContents
        
        strPathName = ThisWorkbook.Path & "\経審申請\" & MyB & "\keisinData.xls"
        Workbooks.Open strPathName
        基本データ取り込み
    
    End If
'20130510 kon
    DoEvents
    ThisWorkbook.Activate
    DoEvents

    
    
'    If MyB = Dir(strPathName, 16) Then
'        Sheets("MENU").Select
'        バージョンチェック
'    Else
'        Cells(1, 7).Value = "初期設定中・・・"
'        myName = ThisWorkbook.Path & "\経審申請\原本"                                   'コピー元フォルダ
'        myFso.CopyFolder myName, strPathName, OverWriteFiles:=True                    'フォルダのコピー
'        Cells(1, 7).MergeArea.ClearContents
'        StartFg = 1
'    End If
    
'    strPathName = ThisWorkbook.Path & "\経審申請\" & MyB & "\keisinData.xls"
'    If Dir(strPathName, vbNormal) <> "" Then
'        Workbooks.Open strPathName
'    Else
'        MsgBox "データが見つかりません。", vbInformation
'        Exit Sub
'    End If
    
'    If StartFg = 1 Then
'        基本データ取り込み
'        StartFg = 0
'    End If
    Application.Calculation = xlCalculationAutomatic
    'バージョン値の表示
    GetVerText VerNo
    ThisWorkbook.Sheets("MENU").Cells(4, 7).Value = "Ver " & VerNo
    ThisWorkbook.Sheets("MENU").Cells(1, 1).Select
    
    Application.ScreenUpdating = True

End Sub

Private Sub GetVerText(ByRef no 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
    Close #f

End Sub

Sub 基本データ取り込み()
        
        With Workbooks(ThisWorkbook.Worksheets("DATA").Cells(1, 1).Value)
            '郵便番号
                Workbooks("keisinData.xls").Worksheets("DATA").Cells(4, 2).Value = Mid(.Worksheets("会社情報").Cells(9, 2).Value, 1, 3)
                Workbooks("keisinData.xls").Worksheets("DATA").Cells(5, 2).Value = Mid(.Worksheets("会社情報").Cells(9, 2).Value, 5, 4)
            
            '所在地
                Workbooks("keisinData.xls").Worksheets("DATA").Cells(6, 2).Value = .Worksheets("会社情報").Cells(10, 2).Value
            
            '会社名
                Workbooks("keisinData.xls").Worksheets("DATA").Cells(7, 2).Value = .Worksheets("会社情報").Cells(8, 2).Value
            
            '代表者職名
                Workbooks("keisinData.xls").Worksheets("DATA").Cells(8, 2).Value = .Worksheets("会社情報").Cells(11, 2).Value
            
            '代表者氏名
                Workbooks("keisinData.xls").Worksheets("DATA").Cells(9, 2).Value = .Worksheets("会社情報").Cells(12, 2).Value

            '電話番号
                Workbooks("keisinData.xls").Worksheets("DATA").Cells(10, 2).Value = .Worksheets("会社情報").Cells(13, 2).Value
    
            'FAX
'                Workbooks("keisinData.xls").Worksheets("DATA").Cells(94, 2).Value = .Worksheets("会社情報").Cells(14, 2).Value
    
        End With
    
        With Workbooks("DaMenu.xls").Worksheets("標準報酬月額")
    
            '住所
                Workbooks("keisinData.xls").Worksheets("DATA").Cells(43, 2).Value = .Cells(153, 7).Value
            
            '氏名
                Workbooks("keisinData.xls").Worksheets("DATA").Cells(44, 2).Value = .Cells(154, 7).Value

            '電話番号
                Workbooks("keisinData.xls").Worksheets("DATA").Cells(45, 2).Value = .Cells(155, 7).Value
    
            'FAX
'                Workbooks("keisinData.xls").Worksheets("DATA").Cells(94, 2).Value = .Cells(156, 7).Value
    
        End With
    
 

End Sub
Sub バージョンチェック()
    Dim Filename As String
    Dim Ver As String
    Dim MyB         As String
    
    MyB = ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value
    Filename = ThisWorkbook.Path & "\経審申請\" & MyB & "\ver.txt"    '会社フォルダのＶｅｒ.txtにバージョン値が記載されている。
    Cells(5, 5).Value = GetTextData(1, Filename)                    'Ｖｅｒ.txtのバージョン値を取得
    
    Filename = ThisWorkbook.Path & "\経審申請\原本\ver.txt"    '会社フォルダのＶｅｒ.txtにバージョン値が記載されている。
    Ver = GetTextData(1, Filename)                    'Ｖｅｒ.txtのバージョン値を取得
    
    If Ver = Cells(5, 5).Value Then                   'バージョンが一致していてたら何もしない
        Cells(5, 5).MergeArea.ClearContents
        Exit Sub
    End If
    If MsgBox("バージョンアップしますか？", 4 + 32, Cells(4, 5).Value) <> 6 Then Exit Sub
    
    Cells(1, 7).Value = Cells(4, 5).Value & "バージョンアップ中・・・"
    'Da保存フォルダがなかったら作成する
    If Dir(ThisWorkbook.Path & "\経審申請\" & MyB & "\Da保存", 16) = "" Then
        MkDir ThisWorkbook.Path & "\経審申請\" & MyB & "\Da保存"
    End If
    
    Call 書類入替
    
    Cells(1, 7).MergeArea.ClearContents
    Cells(1, 10).ClearContents
    Cells(5, 5).MergeArea.ClearContents
    FileCopy Filename, ThisWorkbook.Path & "\経審申請\" & MyB & "\ver.txt"

    MsgBox "完了", vbInformation
   
End Sub

Sub 書類入替()
    Dim MyB         As String
    Dim OS          As String
    Dim n           As String
    Dim f           As Object
    Dim g           As Object
    Dim Adb         As String
    Dim myBPath     As String
    Dim myFso       As Object
    Dim ファイル名 As String
    
    On Error GoTo ErrorCheck
    
    MyB = ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value '会社名
    myBPath = ThisWorkbook.Path & "\経審申請\" & MyB & "\"    '会社のフォルダパス
    
    OS = Application.OperatingSystem                        'OSのバージョン情報
'20130509 kon 2013
'    If Right(OS, 4) = "6.00" Or Right(OS, 4) = "6.01" Then
    If Right(OS, 4) = "6.00" Or Right(OS, 4) = "6.01" Or Right(OS, 4) = "6.02" Then
        
        n = 24 'Vista 7 コメント
        Else
        n = 14 'XP コメント
    End If
    
    Set myFso = CreateObject("Scripting.FileSystemObject")

    Set f = CreateObject("Shell.Application").Namespace(ThisWorkbook.Path & "\経審申請\原本\")        '原本フォルダ
    Set g = CreateObject("Shell.Application").Namespace(ThisWorkbook.Path & "\経審申請\" & MyB & "\") '会社フォルダ
    
    ファイル名 = Dir(ThisWorkbook.Path & "\経審申請\原本" & "\*.xls")  '会社フォルダのエクセルファイル
    
    Application.DisplayAlerts = False
    Do While ファイル名 <> ""
            
          '存在するか否か　存在しない場合は新規書類のためただ入れ込むだけ
          If myFso.FileExists(Filespec:=myBPath & ファイル名) Then
             Else
              myFso.CopyFile ThisWorkbook.Path & "\経審申請\原本\" & ファイル名, myBPath
              Cells(1, 10).Value = "新規書類" & ファイル名 & "設定中・・・"
          End If

          If f.GetDetailsOf(f.ParseName(ファイル名), n) <> g.GetDetailsOf(g.ParseName(ファイル名), n) Then 'コメントに記載されている文字を比較して異なっていたら・・・
              
            Cells(1, 10).Value = ファイル名 & "入れ替え中・・・"
            Cells(1, 10).Value = ""
            
            On Error Resume Next
            MkDir (ThisWorkbook.Path & "\経審申請\" & MyB & "\Da保存\")
            On Error GoTo 0
            If ファイル名 = "経営申請.xls" Then
                Call BukUpZaimu(ファイル名, ThisWorkbook.Path & "\経審申請\" & MyB & "\Da保存\" & Format(Date, "gemmdd") & "_" & Format(Time, "h_mm "), ThisWorkbook.Path & "\経審申請\" & MyB)
            Else
                Call BukUp(ファイル名, ThisWorkbook.Path & "\経審申請\" & MyB & "\Da保存\" & Format(Date, "gemmdd") & "_" & Format(Time, "h_mm ") & " " & ファイル名, ThisWorkbook.Path & "\経審申請\" & MyB)
            End If
            '原本フォルダのファイルと入替
            myFso.CopyFile ThisWorkbook.Path & "\経審申請\原本\" & ファイル名, myBPath '異なっていたら入れる。
                
            End If
            ファイル名 = Dir()
    Loop
    
    
    Set f = Nothing
    Set g = Nothing
    Set myFso = Nothing
    
    Application.DisplayAlerts = True
    
    Exit Sub

ErrorCheck:
    MsgBox "バージョンアップに失敗しました。", vbInformation
    Cells(1, 7).MergeArea.ClearContents
    Cells(1, 10).ClearContents
    Cells(5, 5).MergeArea.ClearContents
    End
End Sub
Sub BukUp(シート名, フルパス, 元パス)
'    Dim 保存ファイル名 As String
    Dim ファイル区分 As String
    Dim MyFile As String
'    Dim 台帳ファイル名 As String
    Dim 印刷範囲 As String
    Dim n As Integer
    Dim wRange As Range '印刷範囲以外のオブジェクトと印刷範囲内のマクロ付のオブジェクトを削除する
    Dim wLeft, wTop, wRight, wBottom
    Dim shapeLeft, shapeTop, shapeRight, shapeBottom
    Dim s As Shape
    
    Application.ReferenceStyle = xlA1
    
    Workbooks.Open 元パス & "\" & シート名

'    If Mid(シート名, 1, Len(シート名) - 4) = "施工金額" Then
'        印刷範囲 = "$B$4:$V$124"
'    ElseIf Mid(シート名, 1, Len(シート名) - 4) = "予備付属明細書" Then
'        印刷範囲 = "$B$6:$BA$147"
'    Else
        印刷範囲 = ActiveSheet.PageSetup.PrintArea
'    End If
    
'    If シート名 = "工事経歴" Then
'        n = Cells(10000, 3).End(xlUp).Row '最終行を取得して
'        Workbooks.Open ThisWorkbook.Path & "\経審KeepFile.xls"
'        Range("A1:Q" & n).Value = Workbooks(MyFile).Worksheets("工事経歴").Range("A1:Q" & n).Value
'
'    Else
        ActiveSheet.Unprotect

        Workbooks.Open ThisWorkbook.Path & "\建設KeepFile.xls"
        
        Workbooks(シート名).Worksheets(Mid(シート名, 1, Len(シート名) - 4)).Copy Before:=ActiveWorkbook.Sheets(1) 'シートをコピーする
        ActiveSheet.Unprotect
        With Range(印刷範囲)
            wTop = .Top
            wLeft = .Left
            wBottom = .Top + .Height
            wRight = .Left + .Width
        End With
        For Each s In ActiveSheet.Shapes
            shapeTop = s.Top
            shapeLeft = s.Left
            shapeBottom = s.Top + s.Height
            shapeRight = s.Left + s.Width
            If s.Name Like "Drop*" Then
            Else
            If (wTop <= shapeTop And wLeft <= shapeLeft And _
                wBottom >= shapeBottom And wRight >= shapeRight) And s.OnAction = "" Then
                Else
                s.Delete
            End If
            End If
        Next
        Cells.Copy
        Cells.PasteSpecial Paste:=xlValues '数式をすべて値にする
        
        Range(印刷範囲).Value = Workbooks(シート名).Worksheets(Mid(シート名, 1, Len(シート名) - 4)).Range(印刷範囲).Value2
        Worksheets("INFO").Range("A1").Value = ファイル区分
        Worksheets("INFO").Shapes("BOTAN2").Copy 'マクロボタンを設定する
        
        Worksheets(Mid(シート名, 1, Len(シート名) - 4)).Paste 'マクロボタンを設定する
'    End If
    Range("A1").Select
    Application.CutCopyMode = False
    ActiveWindow.DisplayGridlines = False
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs フルパス '保存する
    ActiveWorkbook.Close False
    Workbooks(シート名).Activate
    ActiveSheet.EnableSelection = xlUnlockedCells
    ActiveSheet.Protect UserInterfaceOnly:=True
    ActiveWorkbook.Close False
    
End Sub

Sub BukUpZaimu(シート名, フルパス, 元パス)
'    Dim 保存ファイル名 As String
    Dim ファイル区分 As String
    Dim MyFile As String
'    Dim 台帳ファイル名 As String
    Dim 印刷範囲 As String
    Dim n, i As Integer
    Dim wRange As Range '印刷範囲以外のオブジェクトと印刷範囲内のマクロ付のオブジェクトを削除する
    Dim wLeft, wTop, wRight, wBottom
    Dim shapeLeft, shapeTop, shapeRight, shapeBottom
    Dim s As Shape
    Dim sName As String
    
    
    Application.ReferenceStyle = xlA1
    
    Workbooks.Open 元パス & "\" & シート名
    For i = 1 To Worksheets.Count
        sName = Sheets(i).Name
        Sheets(i).Select
        印刷範囲 = ActiveSheet.PageSetup.PrintArea
'        Application.ScreenUpdating = False
'        Application.DisplayAlerts = False
        ActiveSheet.Unprotect
        
        Workbooks.Open ThisWorkbook.Path & "\建設KeepFile.xls"
        
        Workbooks(シート名).Worksheets(sName).Copy Before:=ActiveWorkbook.Sheets(1) 'シートをコピーする
        ActiveSheet.Unprotect
        With Range(印刷範囲)
            wTop = .Top
            wLeft = .Left
            wBottom = .Top + .Height
            wRight = .Left + .Width
        End With
        For Each s In ActiveSheet.Shapes
            shapeTop = s.Top
            shapeLeft = s.Left
            shapeBottom = s.Top + s.Height
            shapeRight = s.Left + s.Width
            If s.Name Like "Drop*" Then
            Else
            If (wTop <= shapeTop And wLeft <= shapeLeft And _
                wBottom >= shapeBottom And wRight >= shapeRight) And s.OnAction = "" Then
                Else
                s.Delete
            End If
            End If
        Next
        Cells.Copy
        Cells.PasteSpecial Paste:=xlValues '数式をすべて値にする
        
        Range(印刷範囲).Value = Workbooks(シート名).Worksheets(sName).Range(印刷範囲).Value2
        Worksheets("INFO").Range("A1").Value = ファイル区分
        Worksheets("INFO").Shapes("BOTAN2").Copy 'マクロボタンを設定する
        
        Worksheets(sName).Paste 'マクロボタンを設定する
        Range("A1").Select
        Application.CutCopyMode = False
        ActiveWindow.DisplayGridlines = False
        Application.CutCopyMode = False
        ActiveWorkbook.SaveAs フルパス & sName & " " & シート名 '保存する
        ActiveWorkbook.Close False
    Next i

    Workbooks(シート名).Activate
    ActiveSheet.EnableSelection = xlUnlockedCells
    ActiveSheet.Protect UserInterfaceOnly:=True
    ActiveWorkbook.Close False
    
End Sub

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
Sub 分析申請書へ()
    シートへ ("分析申請書")
End Sub
Sub 資格の技術職員名簿へ()
    シートへ ("資格の技術職員名簿一覧表")
End Sub
Sub 完成工事高付表へ()
    シートへ ("工事種類別完成工事高付表")
End Sub


Sub 提出票へ()
    シートへ ("提出票")
End Sub
Sub 申請付表へ()
    シートへ ("申請付表")
End Sub
Sub 審査項目へ()
    シートへ ("審査項目")
End Sub
Sub 兼業事業へ()
    シートへ ("兼業事業")
End Sub
Sub 経営申請へ()
    シートへ ("経営申請")
End Sub
Sub 技術職員名簿へ()
    シートへ ("技術職員名簿")
End Sub
Sub 完成工事高へ()
    シートへ ("完成工事高")
End Sub
Sub 手数料Bへ()
    シートへ ("手数料B")
End Sub
Sub 手数料へ()
    シートへ ("手数料")
End Sub

Sub 経営申請シートへ(fNam As String)
    Dim AA As Variant
    Dim i As Integer
    Dim n As Integer
    Dim file_name As Object
    Dim myPath As String
    
    AA = Array("経営申請", "経営申請2")
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    myPath = PathCombine(ThisWorkbook.Path, "経審申請")
    myPath = PathCombine(myPath, ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value)
    
    
    Application.DisplayAlerts = False
    Workbooks.Open PathCombine(myPath, "経営申請.xls"), Notify:=False
    Application.DisplayAlerts = True
    
    For i = 0 To 7
        Sheets(AA(i)).Select
        Cells(1, 180).Value = "[keisinData.xls]DATA!"
    Next

    Call kSyori
    
    Sheets(fNam).Select

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Sub シートへ(シート)
    Dim myPath As String
    Dim wb As Workbook

    Application.ScreenUpdating = False
    myPath = PathCombine(ThisWorkbook.Path, "経審申請")
    myPath = PathCombine(myPath, ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value)
   
    Application.ScreenUpdating = False
    
    For Each wb In Workbooks
        If wb.Name = ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value Then
            wb.Activate
            
            Exit Sub
        End If
    Next
    
    Application.DisplayAlerts = False
    Workbooks.Open PathCombine(myPath, シート & ".xls"), Notify:=False
    Application.DisplayAlerts = True
    
    Call kSyori
    
    Sheets(シート).Select
    Cells(1, 180).Value = "[keisinData.xls]DATA!"
'    Cells(1, 180).Font.ThemeColor = xlThemeColorDark1
    If シート = "経営申請" Then
        Sheets("経営申請２").Select
        Cells(1, 180).Value = "[keisinData.xls]DATA!"
        Sheets(シート).Select
    End If

    Cells(1, 1).Select
    
    
    ActiveWindow.ScrollColumn = 1
    ActiveWindow.ScrollRow = 1
    Application.ScreenUpdating = True

End Sub
Sub kSyori()
    Application.ScreenUpdating = False
    Dim s As Worksheet
    For Each s In Worksheets
        With s
            .Activate
            ActiveWindow.DisplayHeadings = False
            .EnableSelection = xlUnlockedCells
            .Protect UserInterfaceOnly:=True
        End With
    Next
    ActiveWindow.DisplayWorkbookTabs = False
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 path1 As String, ByVal path2 As String) As String

    If Right(path1, 1) = "\" Then
        PathCombine = path1 & path2
    Else
        PathCombine = path1 & "\" & path2
    End If

End Function


'''Sub Auto_Open()
'''Dim myStr As String
'''
'''
'''Worksheets("MENU").Select
'''Cells(30, 2).Value = "しばらくお待ちください・・・"
'''Application.ScreenUpdating = False
'''Call メニューバーの作成
'''シート限定
'''ファイル名リスト表示
'''    If Dir(ThisWorkbook.Path & "\gyouseisyosi.dat") = "gyouseisyosi.dat" Then
'''        Open ThisWorkbook.Path & "\gyouseisyosi.dat" For Input As #1
'''        With Worksheets("DATA")
'''            .Unprotect
'''            For i = 1 To 3
'''                Input #1, myStr
'''                .Range("P" & i + 1).Value = myStr
'''            Next
'''        Close #1
'''        .Protect
'''        End With
'''
'''    End If
'''
'''Cells(30, 2).Value = ""
'''Cells(7, 5).Select
'''Application.Calculation = xlAutomatic
'''ActiveWindow.WindowState = xlMaximized
'''End Sub
Sub シート限定()
Dim s As Worksheet
  For Each s In Worksheets
    With s
      .Activate
      .EnableSelection = xlUnlockedCells
      .Protect UserInterfaceOnly:=True
       ActiveWindow.DisplayHeadings = False
    End With
  Next
Worksheets("MENU").Select
ActiveWindow.DisplayWorkbookTabs = False
End Sub
Sub ファイル名リスト表示()
ActiveSheet.ListBoxes("FList").RemoveAllItems
Dim ファイル名 As String
ファイル名 = Dir(ActiveWorkbook.Path & "\経審\*ks.xls")
   Do While ファイル名 <> ""
       With ActiveSheet.ListBoxes("FList")
             .AddItem Left(ファイル名, Len(ファイル名) - 6)
        ファイル名 = Dir()
    End With
    Loop
Cells(3, 5).Select
End Sub

Sub 削除()
    With ActiveSheet.ListBoxes("FList")
        If .Value > 0 Then
            Application.ScreenUpdating = False
            Dim file_name As Object
                For Each file_name In Windows
                   If file_name.Caption = .List(.Value) & "ks.xls" Then
                      MsgBox "このファイルは現在起動中です。起動中のファイルは削除できません。"
                       Exit Sub
                    End If
                 Next
            If MsgBox("選択されたファイルを削除してもいいですか？（元に戻せません。）", 1 + 48, "削除") <> 1 Then Exit Sub
                Kill ActiveWorkbook.Path & "\経審\" & .List(.Value) & "ks.xls"
                .RemoveItem (.Value)
                MsgBox "削除しました。", , AAA
                Application.ScreenUpdating = True
        Else
        MsgBox "ファイルを選択して実行してください。", , AAA
        Exit Sub
        End If
    End With
End Sub

Sub 行政書士へ()
行政書士F.Show
End Sub
Sub シートMENU()
Sheets("MENU").Select
End Sub
Sub マニュアルへ()
    Application.Run "DaAddin.xla!OpenManual"
End Sub
Sub 戻るへ()
On Error Resume Next
Sheets("MENU").Select
Application.ScreenUpdating = False
Workbooks(Worksheets("HELP").Cells(2, 17).Value).Activate
Sheets("MENU").Select
End Sub
Sub 新規読込()
On Error GoTo ErrorCheck
Application.ScreenUpdating = False
Dim file_name As Object
     For Each file_name In Windows
        If file_name.Caption = "経審原本.xls" Then
           Workbooks("経審原本.xls").Activate
            Exit Sub
         End If
      Next
Workbooks.Open Filename:=ActiveWorkbook.Path & "\" & "経審原本.xls"
シート限定
Exit Sub
ErrorCheck:
   MsgBox Error(Err), , "エラー"
End Sub
Sub 新規作成へ()
新規作成.Show
End Sub
Sub 保護解除()
ActiveSheet.Unprotect
MsgBox "シートの保護を解除しました。", , "保護解除"
End Sub
Sub スクロール範囲限定解除()
ActiveSheet.ScrollArea = ""
End Sub
Sub 終了()
    Dim wb As Workbook
    Dim n As Integer
    
    If MsgBox("終了しますか？", 4 + 32, "終了") <> 6 Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    For Each wb In Workbooks
        Cells(1, 7).Value = wb.Name & " 終了準備中・・・・"
        If wb.Path = ThisWorkbook.Path & "\経審申請\" & ThisWorkbook.Worksheets("DATA").Cells(2, 1).Value Then
            wb.Save  '強制的に保存して
            wb.Close '強制的に閉じる
…