Const RibbonActionModule = "Action"
Const ClickActionModule = "Click"
Const MainActionModule = "Main"
Public Function RibbonActionCreate(ByVal SubID As String) As String
Dim strPgm As String
strPgm = strPgm & vbCrLf & "Public Sub " & SubID & "_onAction()"
strPgm = strPgm & vbCrLf & " Dim rtnCode As Integer"
strPgm = strPgm & vbCrLf & " rtnCode = " & SubID & "_Main"
strPgm = strPgm & vbCrLf & " If rtnCode <> 0 Then"
strPgm = strPgm & vbCrLf & " MsgBox """ & SubID & "_onAction:Error :"" & rtnCode"
strPgm = strPgm & vbCrLf & " End If"
strPgm = strPgm & vbCrLf & "End Sub"
RibbonActionCreate = strPgm
End Function
Public Function ClickActionCreate(ByVal SubID As String) As String
Dim strPgm As String
strPgm = strPgm & vbCrLf & "Public Sub " & SubID & "_Click()"
strPgm = strPgm & vbCrLf & " Dim rtnCode As Integer"
strPgm = strPgm & vbCrLf & " rtnCode = " & SubID & "_Main"
strPgm = strPgm & vbCrLf & " If rtnCode <> 0 Then"
strPgm = strPgm & vbCrLf & " MsgBox """ & SubID & "_Click:Error :"" & rtnCode"
strPgm = strPgm & vbCrLf & " End If"
strPgm = strPgm & vbCrLf & "End Sub"
RibbonActionCreate = strPgm
End Function
Public Function MainActionCreate(ByVal SubID As String) As String
Dim strPgm As String
strPgm = strPgm & vbCrLf & "Public Function " & SubID & "_Main() As Integer"
strPgm = strPgm & vbCrLf & "On Error GoTo ERR_" & SubID & ""
strPgm = strPgm & vbCrLf & " " & SubID & "_Main = 0"
strPgm = strPgm & vbCrLf & "Exit Function"
strPgm = strPgm & vbCrLf & "ERR_" & SubID & ":"
strPgm = strPgm & vbCrLf & " " & SubID & "_Main = Err.Number"
strPgm = strPgm & vbCrLf & "End Function"
MainActionCreate = strPgm
End Function
Public Sub DeleteModule(ByVal ModuleName As String)
''このプロシージャを削除します
With ThisWorkbook.VBProject.VBComponents(ModuleName).CodeModule
.DeleteLines 1, .CountOfLines
End With
End Sub
Public Sub InsertModule(ByVal ModuleName As String, ByVal Data As String)
''このプロシージャを削除します
With ThisWorkbook.VBProject.VBComponents(ModuleName).CodeModule
.AddFromString (Data)
End With
End Sub
Public Sub ModuleCreateMain()
Dim strSql As String
DeleteModule (RibbonActionModule)
DeleteModule (ClickActionModule)
DeleteModule (MainActionModule)
strSql = "SELECT * FROM [ItemData$] "
cnOpen (ExcelConnect)
Set rs = GetRecordSet(strSql, cn)
Do Until rs.EOF
If rs.Fields("onAction").Value Then
Call InsertModule(RibbonActionModule, RibbonActionCreate(rs.Fields("ID").Value))
End If
If rs.Fields("Click").Value Then
Call InsertModule(ClickActionModule, ClickActionCreate(rs.Fields("ID").Value))
End If
If rs.Fields("onAction").Value Or rs.Fields("Click").Value Then
Call InsertModule(MainActionModule, MainActionCreate(rs.Fields("ID").Value))
End If
rs.MoveNext
Loop
cnClose
End Sub