VBA 工作中开发的小工具[20130610]

'##############PGM・Versionについての定数##############
   Public Const cPgmName = "開発ツール"
   Public Const cVersion = "V1.00"
  
Sub Auto_Open()
    Call Sub_メニューバー追加
End Sub

Sub Sub_メニューバー追加()
    Call Sub_メニューバー復元
    Call Sub_メニューバー復元2
    Set cstBar = Application.CommandBars("Worksheet Menu Bar")
    Set cstMenu = cstBar.Controls.Add(Type:=msoControlPopup)
    cstMenu.Caption = cPgmName
    With cstMenu
        .Controls.Add Type:=msoControlButton
        .Controls(1).Caption = cPgmName & " SQL文自動作成"
        .Controls(1).OnAction = "doSQL"
       
        .Controls.Add Type:=msoControlButton
        .Controls(2).BeginGroup = True
        .Controls(2).Caption = cPgmName & " TestDataHead自動作成"
        .Controls(2).OnAction = "doTableHead"
       
        .Controls.Add Type:=msoControlButton
        .Controls(3).BeginGroup = True
        .Controls(3).Caption = cPgmName & " データコピーSQL生成"
        .Controls(3).OnAction = "doDataCopy"
       
        .Controls.Add Type:=msoControlButton
        .Controls(4).BeginGroup = True
        .Controls(4).Caption = cPgmName & " 受信ファイル作成"
        .Controls(4).OnAction = "doRcvFile"
       
        .Controls.Add Type:=msoControlButton
        .Controls(5).BeginGroup = True
        .Controls(5).Caption = cPgmName & " 終了(&E)"
        .Controls(5).OnAction = "Sub_メニューバー復元"
       
        .Controls.Add Type:=msoControlButton
        .Controls(6).BeginGroup = True
        .Controls(6).Caption = cPgmName & " Help(&H)"
        .Controls(6).OnAction = "Help_Proc"
    End With


End Sub

Private Sub Sub_メニューバー復元()
    On Error Resume Next
    Application.CommandBars("Worksheet Menu Bar").Controls(cPgmName).Delete
End Sub

Private Sub Sub_メニューバー復元2()
    On Error Resume Next
    Application.CommandBars(cPgmName).Delete
End Sub

Sub doSQL()
    Dim dicColName As Object, myKey
'    Dim targetBook As Workbook, i As Long, j As Long

    iMax = Range("SQL").Rows.Count
    Dim newSheetPos As Integer
    newSheetPos = 1
    fileSaveDir = "C:\work\98_DBレイアウト\最新バージョン\"

    For i = 1 To iMax
        With Range("SQL")
            WK_Sheet = .Cells(i, 1)
            strTargetTable = fileSaveDir & "エンティティ項目定義書_" & WK_Sheet & ".xlsx"
            If WK_Sheet = "" Then
                GoTo GO_Break
            End If
            If Dir(strTargetTable) <> "" Then
                Set targetBook = Workbooks.Open(strTargetTable)
                tableName = targetBook.Sheets("1.項目定義").Cells(2, 33).Value
               
                iRow = 7
                iCol = 2
                arrayKey = ""
                Do
'                    dicColName.Add targetBook.Sheets("1.項目定義").Cells(iRow, iCol + 13).Value, targetBook.Sheets("1.項目定義").Cells(iRow, iCol).Value
                   
                    If targetBook.Sheets("1.項目定義").Cells(iRow, iCol + 34).Value <> "" Then
                        arrayKey = arrayKey & iRow - 5 & ","
                    End If
                    iRow = iRow + 1
                   
                Loop Until targetBook.Sheets("1.項目定義").Cells(iRow, iCol).Value = ""
               
               
                '取得内容設定
                .Cells(i, 2) = "全て"
                .Cells(i, 3) = Mid(arrayKey, 1, Len(arrayKey) - 1)
                .Cells(i, 4) = "高速処理→②"
                .Cells(i, 5) = "select * from " & tableName & " where COMPANY_CD = '[COMPANY_CD]'"
            End If
            Workbooks("エンティティ項目定義書_" & WK_Sheet & ".xlsx").Close SaveChanges:=False
           
        End With
       
GO_Break:

    Next i
   
End Sub
Sub doTableHead()
    Dim dicColName As Object, myKey
    Dim targetBook As Workbook, i As Long, j As Long

    iMax = Range("SQL").Rows.Count
    Dim newSheetPos As Integer
    newSheetPos = 1
    fileSaveDir = "C:\work\98_DBレイアウト\最新バージョン\"


    For i = 1 To iMax
        Set dicColName = CreateObject("Scripting.Dictionary")
        With Range("SQL")
            WK_Sheet = .Cells(i, 1)
            strTargetTable = fileSaveDir & "エンティティ項目定義書_" & WK_Sheet & ".xlsx"
            If WK_Sheet = "" Then
                GoTo GO_Break
            End If
            If Dir(strTargetTable) <> "" Then
                Set targetBook = Workbooks.Open(strTargetTable)
                tableName = targetBook.Sheets("1.項目定義").Cells(2, 33).Value
               
                iRow = 7
                iCol = 2
'                arrayKey = ""
                Do
                    dicColName.Add targetBook.Sheets("1.項目定義").Cells(iRow, iCol + 13).Value, targetBook.Sheets("1.項目定義").Cells(iRow, iCol).Value
                    iRow = iRow + 1
                   
                Loop Until targetBook.Sheets("1.項目定義").Cells(iRow, iCol).Value = ""
               
            End If
           
           
            Workbooks("エンティティ項目定義書_" & WK_Sheet & ".xlsx").Close SaveChanges:=False
           
           
           
            Set strTargetSheet = ActiveWorkbook.Sheets(WK_Sheet)
            iRow = 3
            iCol = 2
            Do
                strTargetSheet.Cells(1, iCol).Value = dicColName.Item(strTargetSheet.Cells(iRow, iCol).Value)
                iCol = iCol + 1
            Loop Until strTargetSheet.Cells(iRow, iCol).Value = ""
        End With
       
GO_Break:
        Set dicColName = Nothing
    Next i
   
   

End Sub

Sub doDataCopy()
    Dim dicColName As Object, myKey
    Dim targetBook As Workbook, i As Long, j As Long

    Const cnsFILENAME = "\tempSQL.txt"
    Dim intFF As Integer            ' FreeFile値
    Dim strREC As String            ' 書き出すレコード内容


    intFF = FreeFile
    ' 指定ファイルをOPEN(出力モード)
    Open ThisWorkbook.Path & cnsFILENAME For Output As #intFF

    ' レコードを出力
    Print #intFF, "DECLARE"
    Print #intFF, "BEGIN"

    iMax = Range("SQL").Rows.Count
    スキーマ元 = Range("schema_from").Value
    スキーマ先 = Range("schema_to").Value
    会社コード元 = Range("COMPANY_CD_FROM").Value
    会社コード先 = Range("COMPANY_CD_TO").Value
   
    Dim newSheetPos As Integer
    newSheetPos = 1
    fileSaveDir = "C:\work\98_DBレイアウト\最新バージョン\"


    For i = 1 To iMax
        Set dicColName = CreateObject("Scripting.Dictionary")
        With Range("SQL")
            WK_Sheet = .Cells(i, 1)
            strTargetTable = fileSaveDir & "エンティティ項目定義書_" & WK_Sheet & ".xlsx"
            If WK_Sheet = "" Then
                GoTo GO_Break
            End If
            If Dir(strTargetTable) <> "" Then
                Set targetBook = Workbooks.Open(strTargetTable)
                tableName = targetBook.Sheets("1.項目定義").Cells(2, 33).Value
               
                iRow = 7
                iCol = 2
                tmpSQL = ""
                Do
                    If targetBook.Sheets("1.項目定義").Cells(iRow, iCol + 13).Value = "COMPANY_CD" Then
                        tmpSQL = tmpSQL & "'" & 会社コード先 & "',"
                    Else
                        tmpSQL = tmpSQL & targetBook.Sheets("1.項目定義").Cells(iRow, iCol + 13).Value & ","
                    End If
                    iRow = iRow + 1
                Loop Until targetBook.Sheets("1.項目定義").Cells(iRow, iCol).Value = ""

                tmpSQL = Mid(tmpSQL, 1, Len(tmpSQL) - 1)
                Print #intFF, "    /***** " & WK_Sheet & " *****/"
                Print #intFF, "    /* コピー先のDB削除 */"
                Print #intFF, "    delete from " & スキーマ先 & "." & tableName & " where COMPANY_CD = '" & 会社コード先 & "';"
                Print #intFF, "    /* データコピー */"
                Print #intFF, "    insert into " & スキーマ先 & "." & tableName & " select " & tmpSQL & " from " & スキーマ元 & "." & tableName & " where COMPANY_CD = '" & 会社コード元 & "';"
                Print #intFF, ""
            End If
           
            Workbooks("エンティティ項目定義書_" & WK_Sheet & ".xlsx").Close SaveChanges:=False
           
        End With
       
GO_Break:
        Set dicColName = Nothing
    Next i
   
    Print #intFF, "    commit;"
    Print #intFF, "EXCEPTION"
    Print #intFF, "    when others then"
    Print #intFF, "      rollback;"
    Print #intFF, "END;"
   
    ' 指定ファイルをCLOSE
    Close #intFF

End Sub

Sub doRcvFile()

    Const cnsFILENAME = "\tempSQL1.txt"
    Dim intF As Integer            ' FreeFile値
    Set targetSheet = ActiveSheet
    today = Format(Date, "yyyymmdd")
   
    Dim strSheetName As String
      
      
    strSheetName = targetSheet.Name

    file = "C:\temp\" & strSheetName & "_" & targetSheet.Cells(1, 2).Value & "_" & today & "120101000"
    ' 指定ファイルをOPEN(出力モード)
    intF = FreeFile
    Open file For Output As #intF

    iRow = 2
    iCol = 5
    Do
   
        jRow = 3
        tmpBuf = ""
        Do
            If targetSheet.Cells(jRow, 3).Value = "X" Then
                tmpBuf = tmpBuf & fnc_x(targetSheet.Cells(jRow, 4).Value, targetSheet.Cells(jRow, iCol).Value)
            ElseIf targetSheet.Cells(jRow, 3).Value = "I" Then
                tmpBuf = tmpBuf & fnc_i(targetSheet.Cells(jRow, 4).Value, targetSheet.Cells(jRow, iCol).Value)
            ElseIf targetSheet.Cells(jRow, 3).Value = "N" Then
                tmpBuf = tmpBuf & fnc_n(targetSheet.Cells(jRow, 4).Value, targetSheet.Cells(jRow, iCol).Value)
            Else
                MsgBox ("属性不正のエラー!")
            End If
            jRow = jRow + 1
        Loop Until targetSheet.Cells(jRow, 2).Value = ""
        Print #intF, tmpBuf
       
        iCol = iCol + 1
    Loop Until targetSheet.Cells(iRow, iCol).Value = ""
   
    ' 指定ファイルをCLOSE
    Close #intF
   
    MsgBox ("処理完了いたしました｡")
End Sub

Function fnc_x(agmLen As Integer, agmVal As String) As String
    If agmLen > Len(agmVal) Then

        fnc_x = agmVal & Space(agmLen - Len(agmVal))
    Else
   
        fnc_x = agmVal
    End If
End Function

Function fnc_i(agmLen As Integer, agmVal As String) As String
    If agmLen > Len(agmVal) Then

        fnc_i = Repace(Space(agmLen - Len(agmVal)), " ", "0") & agmVal
    Else
   
        fnc_i = agmVal
    End If
End Function

Function fnc_n(agmLen As Integer, agmVal As String) As String
    If agmLen > Len(agmVal) Then

        fnc_n = agmVal & Repace(Space(agmLen - Len(agmVal)), "  ", "　")
    Else
   
        fnc_n = agmVal
    End If
End Function