12,665
回編集
差分
ナビゲーションに移動
検索に移動
ページの作成:「==Excel VBA Utility== [Excel VBA]{{category VBAソース片}} ===basUtil=== Option Explicit ' Win32 API Private Declare Function GetPrivateProfileString…」
==Excel VBA Utility==
[Excel VBA]{{category VBAソース片}}
===basUtil===
Option Explicit
' Win32 API
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lpFileName As String) As Long
Public Const MAX_INI_LEN As Long = 256
Public Const INI_EXTENT As String = ".ini"
Public Const EXCEL_EXTENT As String = ".xls"
Public Const DIR_SEP As String = "\"
'
' 設定を保存する
'
' @param book Excelブック
' @param strKey 設定キー
' @param strVal 設定値
'
Public Function setAppSetting(ByRef book As Excel.Workbook, _
ByVal strKey As String, _
ByVal strVal As String) As Long
setAppSetting = WritePrivateProfileString( _
APP_NAME, strKey, strVal, getIniFilename(book))
End Function
'
' 設定を取得する
'
' @param book Excelブック
' @param strKey 設定キー
' @param strDefault 対応する設定値が存在しない場合のデフォルト値
'
Public Function getAppSetting(ByRef book As Excel.Workbook, _
ByVal strKey As String, _
ByVal strDefault As String) As String
Dim strBuf As String * MAX_INI_LEN
Dim result As Long
result = GetPrivateProfileString( _
APP_NAME, strKey, strDefault, strBuf, MAX_INI_LEN, _
getIniFilename(book))
getAppSetting = Left(strBuf, InStr(strBuf, vbNullChar) - 1)
End Function
'
' 初期化ファイル名を取得する
'
' @param book Excelブック
'
Private Function getIniFilename(ByRef book As Excel.Workbook) As String
getIniFilename = getWorkbookRerativeFilename(book, INI_EXTENT)
End Function
'
' EXCEL ファイルのプルパス、拡張子変更文字列を返す
'
' @param book Excelブック
' @param extents 拡張子
' @return Excelのファイル名の拡張子を変更した文字列
'
Private Function getWorkbookRerativeFilename(ByRef book As Excel.Workbook, extents As String) As String
Dim chk As String
Dim tmp As String
tmp = book.Name
chk = String(Len(EXCEL_EXTENT), " ") & tmp
If Right$(chk, Len(EXCEL_EXTENT)) = EXCEL_EXTENT Then
tmp = Left$(tmp, Len(tmp) - Len(EXCEL_EXTENT))
End If
getWorkbookRerativeFilename = getPath(book.path) & tmp & extents
End Function
'
' パス名を作成(最後が'\'で終わるように整形する)
'
' @param pathName 整形するパス名
' @return 整形されたパス名
'
Public Function getPath(ByVal pathName) As String
Dim result As String
result = pathName
If Trim$(result) = "" Then
result = "."
End If
If Right$(result, 1) <> DIR_SEP Then
result = result & DIR_SEP
End If
getPath = result
End Function
'
' ファイルを選択する
' fileFilter eg-"Microsoft Excelブック,*.xls,テキストファイル,*.txt"
'
Public Function chooseFile(Optional fileFilter As String, _
Optional rootDir As String, _
Optional filterIndex As Integer, _
Optional title As String, _
Optional buttonText As String, _
Optional MultiSelect As Boolean) As Variant
Dim drv As String
drv = UCase$(Left$(rootDir, 1))
If Not isBlank(Trim$(rootDir)) _
And ("A" <= drv And drv <= "Z") _
And (Mid$(rootDir, 2, 1) = ":") _
Then
Call ChDrive(drv)
Call ChDir(rootDir)
End If
chooseFile = Application.GetOpenFilename(fileFilter, filterIndex, title, buttonText, MultiSelect)
End Function
'
' フォルダ取得ダイアログを表示する
'
'
' @return 選択されたフォルダ名
' @param title タイトルの文字列
' options 選択オプションの値
' rootFolder 既定フォルダの文字列
'
Public Function browseForFolder(title As String, _
options, _
Optional rootFolder As String = "") As String
Dim cmdShell As Object
Dim folder As Object
On Error GoTo errHandler
Set cmdShell = CreateObject("Shell.Application")
'syntax
' object.BrowseForFolder Hwnd, Title, Options, [RootFolder]
'
Set folder = cmdShell.browseForFolder(0, title, options, rootFolder)
If Not folder Is Nothing Then
browseForFolder = folder.Items.Item.path
Else
browseForFolder = ""
End If
closer:
Set folder = Nothing
Set cmdShell = Nothing
Exit Function
errHandler:
MsgBox Err.Description, vbCritical
GoTo closer
End Function
'
' 文字列配列を、区切文字で区切られたテキストに展開する
'
' @param fields 展開する文字列配列
' @param separator 区切文字
' @return 区切文字で区切られたテキスト
'
Public Function arrayToSeparetedValueText(ByRef fields() As String, separator As String) As String
Dim ret As String
Dim i As Integer
For i = 0 To UBound(fields)
If i = 0 Then
ret = fields(i)
Else
ret = ret & separator & fields(i)
End If
Next
arrayToSeparetedValueText = ret
End Function
'
' 文字列に対する簡易ソート
'
' @param values ソート対象の文字列配列
'
Public Sub bubbleSort(ByRef values() As String)
Dim tmp As String
Dim i As Integer
Dim j As Integer
tmp = ""
For i = LBound(values) To UBound(values)
For j = i + 1 To UBound(values)
If StrComp(values(i), values(j), vbTextCompare) > 0 Then
tmp = values(i)
values(i) = values(j)
values(j) = tmp
End If
Next
Next
End Sub
'
' 指定された文字列が配列に含まれるか検査する
'
' @param str 検査文字列
' @param strAry 検査対象配列
' @return 配列に値が含まれていればTrue
'
Public Function isContainArray(str As String, strAry() As String) As Boolean
Dim i As Integer
For i = LBound(strAry) To UBound(strAry)
If str = strAry(i) Then
isContainArray = True
Exit Function
End If
Next
isContainArray = False
End Function
'
' 文字列配列に、重複項目があるかをチェックする
'
' @param values 検査対象配列
' @param duplicatedItems 重複項目を文字列配列にセットする
' @return 重複がある場合に true を返す
'
Public Function duplicatedCheck(ByRef values() As String, ByRef duplicatedItems() As String) As Boolean
Dim result As Boolean
Dim i As Integer
Dim tmp() As String
Dim dupIdx As Integer
result = False
dupIdx = 0
ReDim tmp(UBound(values))
For i = LBound(values) To UBound(values)
tmp(i) = values(i)
Next
Call Util.bubbleSort(tmp)
Dim curVal As String
For i = LBound(tmp) To UBound(tmp)
If i > LBound(tmp) Then
If curVal = tmp(i) Then
ReDim Preserve duplicatedItems(dupIdx)
duplicatedItems(dupIdx) = curVal
dupIdx = dupIdx + 1
result = True
End If
End If
curVal = tmp(i)
Next
duplicatedCheck = result
End Function
'
'ブランク判定
'
' @param str 判定する文字列
' @return 文字列が空ならTrue
'
Public Function isBlank(str As String) As Boolean
isBlank = ((Trim$(str)) = "")
End Function
'
' Boolean を "1":True、"0":False に変換
'
' @param blv 真偽値(Boolean)
' @return Trueなら"1"、Falseなら"0"
'
Public Function booleanToFlag(blv As Boolean) As String
booleanToFlag = IIf(blv, "1", "0")
End Function
'
' Boolean を "1":True、" ":False に変換
'
' @param blv 真偽値(Boolean)
' @return Trueなら"1"、Falseなら" "
'
Public Function booleanToFlag2(blv As Boolean) As String
booleanToFlag2 = IIf(blv, "1", " ")
End Function
'
' フラグ を "1":True、"0":False に変換
'
' @param flag フラグ
' @return "1"ならTrue、それ以外はFalse
'
Public Function flagToBoolean(flag As String) As String
flagToBoolean = IIf((Trim$(flag) = "1"), True, False)
End Function
{{ref Util.bas}}
[Excel VBA]{{category VBAソース片}}
===basUtil===
Option Explicit
' Win32 API
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lpFileName As String) As Long
Public Const MAX_INI_LEN As Long = 256
Public Const INI_EXTENT As String = ".ini"
Public Const EXCEL_EXTENT As String = ".xls"
Public Const DIR_SEP As String = "\"
'
' 設定を保存する
'
' @param book Excelブック
' @param strKey 設定キー
' @param strVal 設定値
'
Public Function setAppSetting(ByRef book As Excel.Workbook, _
ByVal strKey As String, _
ByVal strVal As String) As Long
setAppSetting = WritePrivateProfileString( _
APP_NAME, strKey, strVal, getIniFilename(book))
End Function
'
' 設定を取得する
'
' @param book Excelブック
' @param strKey 設定キー
' @param strDefault 対応する設定値が存在しない場合のデフォルト値
'
Public Function getAppSetting(ByRef book As Excel.Workbook, _
ByVal strKey As String, _
ByVal strDefault As String) As String
Dim strBuf As String * MAX_INI_LEN
Dim result As Long
result = GetPrivateProfileString( _
APP_NAME, strKey, strDefault, strBuf, MAX_INI_LEN, _
getIniFilename(book))
getAppSetting = Left(strBuf, InStr(strBuf, vbNullChar) - 1)
End Function
'
' 初期化ファイル名を取得する
'
' @param book Excelブック
'
Private Function getIniFilename(ByRef book As Excel.Workbook) As String
getIniFilename = getWorkbookRerativeFilename(book, INI_EXTENT)
End Function
'
' EXCEL ファイルのプルパス、拡張子変更文字列を返す
'
' @param book Excelブック
' @param extents 拡張子
' @return Excelのファイル名の拡張子を変更した文字列
'
Private Function getWorkbookRerativeFilename(ByRef book As Excel.Workbook, extents As String) As String
Dim chk As String
Dim tmp As String
tmp = book.Name
chk = String(Len(EXCEL_EXTENT), " ") & tmp
If Right$(chk, Len(EXCEL_EXTENT)) = EXCEL_EXTENT Then
tmp = Left$(tmp, Len(tmp) - Len(EXCEL_EXTENT))
End If
getWorkbookRerativeFilename = getPath(book.path) & tmp & extents
End Function
'
' パス名を作成(最後が'\'で終わるように整形する)
'
' @param pathName 整形するパス名
' @return 整形されたパス名
'
Public Function getPath(ByVal pathName) As String
Dim result As String
result = pathName
If Trim$(result) = "" Then
result = "."
End If
If Right$(result, 1) <> DIR_SEP Then
result = result & DIR_SEP
End If
getPath = result
End Function
'
' ファイルを選択する
' fileFilter eg-"Microsoft Excelブック,*.xls,テキストファイル,*.txt"
'
Public Function chooseFile(Optional fileFilter As String, _
Optional rootDir As String, _
Optional filterIndex As Integer, _
Optional title As String, _
Optional buttonText As String, _
Optional MultiSelect As Boolean) As Variant
Dim drv As String
drv = UCase$(Left$(rootDir, 1))
If Not isBlank(Trim$(rootDir)) _
And ("A" <= drv And drv <= "Z") _
And (Mid$(rootDir, 2, 1) = ":") _
Then
Call ChDrive(drv)
Call ChDir(rootDir)
End If
chooseFile = Application.GetOpenFilename(fileFilter, filterIndex, title, buttonText, MultiSelect)
End Function
'
' フォルダ取得ダイアログを表示する
'
'
' @return 選択されたフォルダ名
' @param title タイトルの文字列
' options 選択オプションの値
' rootFolder 既定フォルダの文字列
'
Public Function browseForFolder(title As String, _
options, _
Optional rootFolder As String = "") As String
Dim cmdShell As Object
Dim folder As Object
On Error GoTo errHandler
Set cmdShell = CreateObject("Shell.Application")
'syntax
' object.BrowseForFolder Hwnd, Title, Options, [RootFolder]
'
Set folder = cmdShell.browseForFolder(0, title, options, rootFolder)
If Not folder Is Nothing Then
browseForFolder = folder.Items.Item.path
Else
browseForFolder = ""
End If
closer:
Set folder = Nothing
Set cmdShell = Nothing
Exit Function
errHandler:
MsgBox Err.Description, vbCritical
GoTo closer
End Function
'
' 文字列配列を、区切文字で区切られたテキストに展開する
'
' @param fields 展開する文字列配列
' @param separator 区切文字
' @return 区切文字で区切られたテキスト
'
Public Function arrayToSeparetedValueText(ByRef fields() As String, separator As String) As String
Dim ret As String
Dim i As Integer
For i = 0 To UBound(fields)
If i = 0 Then
ret = fields(i)
Else
ret = ret & separator & fields(i)
End If
Next
arrayToSeparetedValueText = ret
End Function
'
' 文字列に対する簡易ソート
'
' @param values ソート対象の文字列配列
'
Public Sub bubbleSort(ByRef values() As String)
Dim tmp As String
Dim i As Integer
Dim j As Integer
tmp = ""
For i = LBound(values) To UBound(values)
For j = i + 1 To UBound(values)
If StrComp(values(i), values(j), vbTextCompare) > 0 Then
tmp = values(i)
values(i) = values(j)
values(j) = tmp
End If
Next
Next
End Sub
'
' 指定された文字列が配列に含まれるか検査する
'
' @param str 検査文字列
' @param strAry 検査対象配列
' @return 配列に値が含まれていればTrue
'
Public Function isContainArray(str As String, strAry() As String) As Boolean
Dim i As Integer
For i = LBound(strAry) To UBound(strAry)
If str = strAry(i) Then
isContainArray = True
Exit Function
End If
Next
isContainArray = False
End Function
'
' 文字列配列に、重複項目があるかをチェックする
'
' @param values 検査対象配列
' @param duplicatedItems 重複項目を文字列配列にセットする
' @return 重複がある場合に true を返す
'
Public Function duplicatedCheck(ByRef values() As String, ByRef duplicatedItems() As String) As Boolean
Dim result As Boolean
Dim i As Integer
Dim tmp() As String
Dim dupIdx As Integer
result = False
dupIdx = 0
ReDim tmp(UBound(values))
For i = LBound(values) To UBound(values)
tmp(i) = values(i)
Next
Call Util.bubbleSort(tmp)
Dim curVal As String
For i = LBound(tmp) To UBound(tmp)
If i > LBound(tmp) Then
If curVal = tmp(i) Then
ReDim Preserve duplicatedItems(dupIdx)
duplicatedItems(dupIdx) = curVal
dupIdx = dupIdx + 1
result = True
End If
End If
curVal = tmp(i)
Next
duplicatedCheck = result
End Function
'
'ブランク判定
'
' @param str 判定する文字列
' @return 文字列が空ならTrue
'
Public Function isBlank(str As String) As Boolean
isBlank = ((Trim$(str)) = "")
End Function
'
' Boolean を "1":True、"0":False に変換
'
' @param blv 真偽値(Boolean)
' @return Trueなら"1"、Falseなら"0"
'
Public Function booleanToFlag(blv As Boolean) As String
booleanToFlag = IIf(blv, "1", "0")
End Function
'
' Boolean を "1":True、" ":False に変換
'
' @param blv 真偽値(Boolean)
' @return Trueなら"1"、Falseなら" "
'
Public Function booleanToFlag2(blv As Boolean) As String
booleanToFlag2 = IIf(blv, "1", " ")
End Function
'
' フラグ を "1":True、"0":False に変換
'
' @param flag フラグ
' @return "1"ならTrue、それ以外はFalse
'
Public Function flagToBoolean(flag As String) As String
flagToBoolean = IIf((Trim$(flag) = "1"), True, False)
End Function
{{ref Util.bas}}
© 2006 矢木浩人
