Public ID As String
Public Text As String
Public onAction As Boolean
Public Click As Boolean
Public Screentip As String
Public Supertip As String
Public Enabled As Boolean
Public Image As String
Public Keytip As String
Public Label As String
Public ShowImage As Boolean
Public ShowLabel As Boolean
Public Visible As Boolean
Public Description As String
Public Size As Integer
Public Pressed As Boolean
Public SelectedItemID As Integer
Public SelectedItemIndex As Integer
Public rec As ADODB.Recordset
Public Property Get Self() As clsItemData
ID = dbChg("String", rec("ID").Value)
Text = dbChg("String", rec("Text").Value)
onAction = dbChg("Boolean", rec("onAction").Value)
Click = dbChg("Boolean", rec("Click").Value)
Screentip = dbChg("String", rec("Screentip").Value)
Supertip = dbChg("String", rec("Supertip").Value)
Enabled = dbChg("Boolean", rec("Enabled").Value)
Image = dbChg("String", rec("Image").Value)
Keytip = dbChg("String", rec("Keytip").Value)
Label = dbChg("String", rec("Label").Value)
ShowImage = dbChg("Boolean", rec("ShowImage").Value)
ShowLabel = dbChg("Boolean", rec("ShowLabel").Value)
Visible = dbChg("Boolean", rec("Visible").Value)
Description = dbChg("String", rec("Description").Value)
Size = dbChg("Integer", rec("Size").Value)
Pressed = dbChg("Boolean", rec("Pressed").Value)
SelectedItemID = dbChg("Integer", rec("SelectedItemID").Value)
SelectedItemIndex = dbChg("Integer", rec("SelectedItemIndex").Value)
Set Self = Me
End Property
Public cn As ADODB.connection
Public rs As ADODB.Recordset
Public cmd As ADODB.Command
Public Const rel_ID2007 = "http://schemas.microsoft.com/office/2006/relationships/ui/extensibility"
Public Const rel_ID2010 = "http://schemas.microsoft.com/office/2007/relationships/ui/extensibility"
Public Const customUI_ID2007 = "http://schemas.microsoft.com/office/2006/01/customui"
Public Const customUI_ID2010 = "http://schemas.microsoft.com/office/2009/07/customui"
Public Const Ver2007 = "Ver2007"
Public Const Ver2010 = "Ver2010"
Public Const Type_rel = "rel"
Public Const Type_customUI = "customUI"
Private Const adOpenDynamic As Long = 2
Private Const adLockOptimistic As Long = 3
Public Function IsBookOpened(a_sFilePath) As Boolean
On Error Resume Next
'// 保存済みのブックか判定
Open a_sFilePath For Append As #1
Close #1
If Err.Number > 0 Then
'// 既に開かれている場合
IsBookOpened = True
Else
'// 開かれていない場合
IsBookOpened = False
End If
End Function
Public Sub Dev01BtnRibbonSet_onAction()
Data.getItemData
RibbonCommonInputAssist.rbIRibbonUI.Invalidate
End Sub
Public Function CmbBoxData(ByVal strID As String, ByVal index As Integer, ByVal Field As String) As String
Dim strSql As String
strSql = "SELECT * FROM [CmbList$] WHERE [ID] = '" & strID & "' AND [ItemIndex] = " & CStr(index)
cnOpen (ExcelConnect)
Set rs = GetRecordSet(strSql, cn)
CmbBoxData = ""
rs.MoveFirst
CmbBoxData = IIf(IsNull(rs.Fields(Field).Value), "", rs.Fields(Field).Value)
cnClose
End Function
Public Function GetItemCmbControl(ByVal setControlID As String, ByVal index As Integer, ByVal GetType As String) As String
Dim strSql As String
strSql = "SELECT * FROM [CmbList$] " & _
" WHERE [ID] = '" & setControlID & "'" & _
" AND [ItemIndex] = " & index
cnOpen (ExcelConnect)
Set rs = GetRecordSet(strSql, cn)
rs.MoveFirst
GetItemCmbControl = rs.Fields(GetType).Value
cnClose
End Function
Public Sub CsvToClipBoard()
Dim Target As String
Dim fso As New FileSystemObject
Dim f As TextStream
Target = Application.GetOpenFilename("Csvファイル,*.csv")
If Target = "False" Then Exit Sub
Set f = fso.OpenTextFile(Target)
ClipBoadCopy Replace(f.ReadAll, ",", vbTab)
f.Close
End Sub
Public Sub RangeToCsv()
Dim Target As String
Target = Application.GetSaveAsFilename(FileFilter:="Csvファイル,*.csv")
If Target = "False" Then Exit Sub
Dim iRow As Integer
Dim iColmn As Integer
Dim rtnString As String
Dim strLine As String
Dim fso As New FileSystemObject
For iRow = Selection(1).Row To Selection(Selection.count).Row
For iColmn = Selection(1).Column To Selection(Selection.count).Column
If iColmn = Selection(1).Column Then
strLine = Cells(iRow, iColmn).Value
Else
strLine = strLine & "," & Cells(iRow, iColmn).Value
End If
Next iColmn
If iRow = Selection(1).Row Then
rtnString = strLine
Else
rtnString = rtnString & vbCrLf & strLine
End If
Next iRow
With fso.CreateTextFile(Target)
.WriteLine rtnString
.Close
End With
End Sub
Public Function NullEmpty(ByVal Data As Variant) As String
If IsNull(Data) Then
NullEmpty = ""
Exit Function
End If
NullEmpty = CStr(Data)
End Function
Public Function GetItemControl(ByVal setControlID As String, ByVal GetType As String) As String
Dim strSql As String
strSql = "SELECT * FROM [ItemData$] WHERE [ID] = '" & setControlID & "'"
cnOpen (ExcelConnect)
Set rs = GetRecordSet(strSql, cn)
rs.MoveFirst
GetItemControl = IIf(IsNull(rs.Fields(GetType).Value), "", rs.Fields(GetType).Value)
cnClose
End Function
Public Sub SetItemControl(ByVal setControlID As String, ByVal GetType As String, ByVal Data As String, Optional ByVal blnSingle = True)
Dim strSql As String
Dim SetData As String
If blnSingle = True Then
SetData = "'" & chgData(Data) & "'"
Else
SetData = chgData(Data)
End If
strSql = "Update [ItemData$] Set [" & GetType & "] = " & SetData & " WHERE [ID] = '" & setControlID & "'"
SqlExecute (strSql)
RibbonCommonInputAssist.Data.getItemData
End Sub
Public Sub SetItemControlMulti(ByVal GetType As String, ByVal Data As Boolean, ParamArray setControlID())
Dim strSql As String
Dim SetData As String
Dim iCount As Integer
Dim strWhere As String
For iCount = LBound(setControlID) To UBound(setControlID)
If iCount = LBound(setControlID) Then
strWhere = " [ID] = '" & setControlID(iCount) & "'"
Else
strWhere = strWhere & " OR [ID] = '" & setControlID(iCount) & "'"
End If
Next iCount
strSql = "Update [ItemData$] Set [" & GetType & "] = " & Data & " WHERE " & strWhere
SqlExecute (strSql)
Set RibbonCommonInputAssist.Data = New clsDataGet
For iCount = LBound(setControlID) To UBound(setControlID)
RibbonCommonInputAssist.rbIRibbonUI.InvalidateControl setControlID(iCount)
Next iCount
End Sub
Public Sub SetCmbList(ByVal setControlID As String, ByVal getIndex As Integer, ByVal ItemLabel As String)
Dim strSql As String
strSql = "Update [CmbList$] Set [ItemLabel] = '" & chgData(ItemLabel) & "'" & _
" WHERE [ID] = '" & setControlID & "'" & _
" AND [itemIndex] = " & getIndex
SqlExecute (strSql)
End Sub
Public Sub SetSaveControl(ByVal setControlID As String, ByVal getIndex As Integer, ByVal getField As String, ByVal Data As String, Optional blnSingle As Boolean = False)
Dim strSql As String
Dim strData As String
If blnSingle = True Then
strData = "'" & Data & "'"
Else
strData = "'" & chgData(Data) & "'"
End If
strSql = "Update [SaveData$] Set [Data] = " & strData & "" & _
" WHERE [ID] = '" & setControlID & "'" & _
" AND [Field] = '" & getField & "'" & _
" AND [itemIndex] = " & getIndex
SqlExecute (strSql)
End Sub
Public Function GetSaveControl(ByVal setControlID As String, ByVal getIndex As Integer, ByVal getField As String) As String
Dim strSql As String
strSql = "SELECT * FROM [SaveData$] " & _
" WHERE [ID] = '" & setControlID & "'" & _
" AND [Field] = '" & getField & "'" & _
" AND [itemIndex] = " & getIndex
cnOpen (ExcelConnect)
Set rs = GetRecordSet(strSql, cn)
rs.MoveFirst
GetSaveControl = IIf(IsNull(rs.Fields("Data").Value), "", rs.Fields("Data").Value)
cnClose
End Function
Public Function chgData(ByVal Data As String) As String
chgData = Replace(Data, "'", "''")
chgData = Replace(chgData, " ", "' + SPACE(1) + '")
End Function
Public Function CmbBoxIndex(ByVal strID As String) As Integer
Dim strSql As String
strSql = "SELECT Count(*) As Cnt FROM [CmbList$] WHERE [ID] = '" & strID & "'"
cnOpen (ExcelConnect)
Set rs = GetRecordSet(strSql, cn)
CmbBoxIndex = 0
rs.MoveFirst
CmbBoxIndex = rs.Fields("Cnt").Value
cnClose
End Function
Public Sub SqlExecute(ByVal strSql As String)
cnOpen (ExcelConnect)
Set cmd = New ADODB.Command
With cmd
.CommandText = strSql
.ActiveConnection = cn
.Execute
End With
cnClose
End Sub
Public Function strKetaSoroe(ByVal 元データ As String, ByVal 桁数 As Integer) As String
Dim iLength As Integer
iLength = Len(元データ)
If 桁数 < iLength Then
strKetaSoroe = "Error"
Else
strKetaSoroe = 元データ & String(桁数 - iLength, " ")
End If
End Function
Public Function GetRecordSet(strSql As String, objCN As Object) As ADODB.Recordset
Dim objRS As ADODB.Recordset
Set objRS = New ADODB.Recordset
objRS.Open strSql, objCN, adOpenDynamic, adLockOptimistic
Set GetRecordSet = objRS
End Function
Public Function UpdRecordSet(strSql As String, objCN As Object) As ADODB.Recordset
Dim objRS As ADODB.Recordset
Set objRS = New ADODB.Recordset
objRS.Open strSql, objCN, adOpenKeyset, adLockPessimistic
Set UpdRecordSet = objRS
End Function
Public Function ExcelCheck(ByVal strPath As String, ByVal strSheet) As Boolean
Dim fso As Scripting.FileSystemObject
Dim WkBkName As String
Set fso = New Scripting.FileSystemObject
ExcelCheck = True
If fso.FileExists(strPath) = False Then
MsgBox "指定されたファイルが存在しません。", vbAbortRetryIgnore, "エラー"
ExcelCheck = False
Set fso = Nothing
Exit Function
End If
WkBkName = fso.GetFileName(strPath)
Set fso = Nothing
If BookChkOpen(strPath) = False Then
MsgBox "指定されたブックが開かれていません。", vbAbortRetryIgnore, "エラー"
ExcelCheck = False
Exit Function
End If
If SheetExist(Workbooks(WkBkName), strSheet) = False Then
MsgBox "指定されたシートが存在しません。", vbAbortRetryIgnore, "エラー"
ExcelCheck = False
Exit Function
End If
End Function
'**************************************************************************************
'* ブックが開かれている場合 :true
'* ブックが開かれていない場合:false
'**************************************************************************************
Public Function BookChkOpen(ByVal strPath) As Boolean
On Error Resume Next
Open strPath For Append As #1
Close #1
If Err.Number > 0 Then
BookChkOpen = True
Else
BookChkOpen = False
End If
End Function
'**************************************************************************************
'* シートが存在する場合 :true
'* シートが存在しない場合:false
'**************************************************************************************
Public Function SheetExist(ByVal Wkbk As Workbook, ByVal strSheet As String) As Boolean
Dim ws As Worksheet
Dim flag As Boolean
For Each ws In Wkbk.Worksheets
If ws.Name = strSheet Then flag = True
Next ws
If flag = True Then
SheetExist = True
Else
SheetExist = False
End If
End Function
Public Function ExcelConnect() As String
ExcelConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & ThisWorkbook.Path & "\" & ThisWorkbook.Name & ";" _
& "Extended Properties=""Excel 8.0;" _
& "HDR=Yes"";"
End Function
Public Function ExcelConnectSelect(ByVal strPath As String, ByVal strBookName As String) As String
ExcelConnectSelect = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & strPath & "\" & strBookName & ";" _
& "Extended Properties=""Excel 8.0;IMEX=1" _
& "HDR=Yes"";"
End Function
Public Sub cnOpen(ByVal ConnectString As String)
Set cn = New ADODB.connection
cn.ConnectionString = ConnectString
cn.Open
End Sub
Public Sub cnClose()
If (rs Is Nothing) = False Then
If rs.State <> adStateClosed Then
rs.Close
End If
End If
Set rs = Nothing
If cn.State <> adStateClosed Then
cn.Close
End If
Set cn = Nothing
End Sub
Public Function ReplaceSpaceToTab(ByVal AfterString As String) As String
ReplaceSpaceToTab = Replace(AfterString, " ", vbTab)
End Function
Public Function ReplaceTabToSpace(ByVal AfterString As String) As String
ReplaceTabToSpace = Replace(AfterString, vbTab, " ")
End Function
Public Function xmlVerChk(ByVal Data As String, ByVal XML_FileType As String) As String
Dim ChkData As String
Select Case XML_FileType
Case Type_rel
ChkData = rel_ID2007
Case Type_customUI
ChkData = customUI_ID2007
End Select
If InStr(Data, ChkData) > 0 Then
xmlVerChk = Ver2007
Else
xmlVerChk = Ver2010
End If
End Function
Public Function xmlChgVer(ByVal Data As String, ByVal XMLType As String, ByVal Ver As String) As String
Dim ChkData As String
Dim DataVer As String
Dim ChgAfterData As String
Dim ChgBeforeData As String
DataVer = xmlVerChk(Data, XMLType)
If DataVer = Ver Then
xmlChgVer = Data
Else
Select Case XMLType
Case Type_rel
If Ver = Ver2007 Then
ChgBeforeData = rel_ID2010
ChgAfterData = rel_ID2007
Else
ChgBeforeData = rel_ID2007
ChgAfterData = rel_ID2010
End If
Case Type_customUI
If Ver = Ver2007 Then
ChgBeforeData = customUI_ID2010
ChgAfterData = customUI_ID2007
Else
ChgBeforeData = customUI_ID2007
ChgAfterData = customUI_ID2010
End If
End Select
xmlChgVer = Replace(Data, ChgBeforeData, ChgAfterData)
End If
End Function
'*******************************
' クリップボードに文字列を格納
'*******************************
Public Sub ClipBoadCopy(ByVal str As String)
With CreateObject("Forms.TextBox.1")
.MultiLine = True
.Text = str
.SelStart = 0
.SelLength = .TextLength
.Copy
End With
End Sub
Public Function dbChg(ByVal DBtype As String, ByVal Data As Variant) As Variant
Dim blnNull As Boolean
blnNull = IsNull(Data)
If blnNull = False Then blnNull = IIf(Data = "", True, False)
If blnNull = True Then
Select Case DBtype
Case "String"
dbChg = ""
Case "Integer"
dbChg = 0
Case "Boolean"
dbChg = True
Case Else
dbChg = ""
End Select
Else
dbChg = Data
End If
End Function