Excel VBA Utility - 版の履歴

2020年2月16日 (日) 04:25にPirotoによる

2020-02-16T04:25:29Z

2020年2月15日 (土) 08:35にPirotoによる

2020-02-15T08:35:33Z

2020年2月15日 (土) 08:02にPirotoによる

2020-02-15T08:02:27Z

Piroto: ページの作成:「==Excel VBA Utility== [Excel VBA]{{category VBAソース片}} ===basUtil=== Option Explicit ' Win32 API Private Declare Function GetPrivateProfileString…」

2020-02-15T07:32:10Z

ページの作成:「==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}}

@@ 1行目: / 1行目: @@
 ==Excel VBA Utility==
-[[Excel VBA]]{{category VBAソース片}}
+[[Excel VBA]] | {{category VBAソース片}}
 ===basUtil===

@@ 1行目: / 1行目: @@
-==Excel VBA Utility==
+==[[Excel VBA Utility]]==
-[[Excel VBA]] | {{category VBAソース片}}
+[[Excel VBA]] | [[Category:VBAソース片]]
 ===basUtil===
@@ 6行目: / 6行目: @@
    ' 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 GetPrivate[[Profile]]String Lib "kernel32" Alias "GetPrivate[[Profile]]StringA" (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
+   Private Declare Function WritePrivate[[Profile]]String Lib "kernel32" Alias "WritePrivate[[Profile]]StringA" (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 = "\"
+   Public Const DI[[R]]_SEP        As String = "\"
+   '
    ' 設定を保存する
+   '
-   ' @param book    Excelブック
+   ' @param book    [[Excel]]ブック
    ' @param strKey  設定キー
    ' @param strVal  設定値
+   '
-   Public Function setAppSetting(ByRef book As Excel.Workbook, _
+   Public Function setAppSetting(ByRef book As [[Excel]].Workbook, _
                                  ByVal strKey As String, _
                                  ByVal strVal As String) As Long
-       setAppSetting = WritePrivateProfileString( _
+       setAppSetting = WritePrivate[[Profile]]String( _
                            APP_NAME, strKey, strVal, getIniFilename(book))
@@ 32行目: / 32行目: @@
    ' 設定を取得する
+   '
-   ' @param book       Excelブック
+   ' @param book       [[Excel]]ブック
    ' @param strKey     設定キー
    ' @param strDefault 対応する設定値が存在しない場合のデフォルト値
+   '
-   Public Function getAppSetting(ByRef book As Excel.Workbook, _
+   Public Function getAppSetting(ByRef book As [[Excel]].Workbook, _
                                  ByVal strKey As String, _
                                  ByVal strDefault As String) As String
@@ 43行目: / 43行目: @@
        Dim result As Long
-       result = GetPrivateProfileString( _
+       result = GetPrivate[[Profile]]String( _
                    APP_NAME, strKey, strDefault, strBuf, MAX_INI_LEN, _
                    getIniFilename(book))
@@ 53行目: / 53行目: @@
    ' 初期化ファイル名を取得する
+   '
-   ' @param book       Excelブック
+   ' @param book       [[Excel]]ブック
+   '
-   Private Function getIniFilename(ByRef book As Excel.Workbook) As String
+   Private Function getIniFilename(ByRef book As [[Excel]].Workbook) As String
-       getIniFilename = getWorkbookRerativeFilename(book, INI_EXTENT)
+       getIniFilename = getWorkbook[[R]]erativeFilename(book, INI_EXTENT)
    End Function
@@ 63行目: / 63行目: @@
    ' EXCEL ファイルのプルパス、拡張子変更文字列を返す
+   '
-   ' @param book    Excelブック
+   ' @param book    [[Excel]]ブック
    ' @param extents 拡張子
-   ' @return Excelのファイル名の拡張子を変更した文字列
+   ' @return [[Excel]]のファイル名の拡張子を変更した文字列
+   '
-   Private Function getWorkbookRerativeFilename(ByRef book As Excel.Workbook, extents As String) As String
+   Private Function getWorkbookRerativeFilename(ByRef book As [[Excel]].Workbook, extents As String) As String
        Dim chk As String
@@ 75行目: / 75行目: @@
        chk = String(Len(EXCEL_EXTENT), " ") & tmp
-       If Right$(chk, Len(EXCEL_EXTENT)) = EXCEL_EXTENT Then
+       If [[R]]ight$(chk, Len(EXCEL_EXTENT)) = EXCEL_EXTENT Then
            tmp = Left$(tmp, Len(tmp) - Len(EXCEL_EXTENT))
        End If
-       getWorkbookRerativeFilename = getPath(book.path) & tmp & extents
+       getWorkbook[[R]]erativeFilename = getPath(book.path) & tmp & extents
    End Function
@@ 97行目: / 97行目: @@
        End If
-       If Right$(result, 1) &lt;&gt; DIR_SEP Then
+       If [[R]]ight$(result, 1) &lt;&gt; DI[[R]]_SEP Then
-           result = result & DIR_SEP
+           result = result & DI[[R]]_SEP
        End If
        getPath = result
@@ 105行目: / 105行目: @@
+   '
    ' ファイルを選択する
-   ' fileFilter eg-"Microsoft Excelブック,*.xls,テキストファイル,*.txt"
+   ' fileFilter eg-"Microsoft [[Excel]]ブック,*.xls,テキストファイル,*.txt"
+   '
    Public Function chooseFile(Optional fileFilter As String, _
@@ 178行目: / 178行目: @@
    ' @return 区切文字で区切られたテキスト
+   '
-   Public Function arrayToSeparetedValueText(ByRef fields() As String, separator As String) As String
+   Public Function arrayToSeparetedValueText(By[[R]]ef fields() As String, separator As String) As String
        Dim ret As String
@@ 199行目: / 199行目: @@
    ' @param values ソート対象の文字列配列
+   '
-   Public Sub bubbleSort(ByRef values() As String)
+   Public Sub bubbleSort(By[[R]]ef values() As String)
        Dim tmp As String
@@ 243行目: / 243行目: @@
    ' @return 重複がある場合に true を返す
+   '
-   Public Function duplicatedCheck(ByRef values() As String, ByRef duplicatedItems() As String) As Boolean
+   Public Function duplicatedCheck(By[[R]]ef values() As String, By[[R]]ef duplicatedItems() As String) As Boolean
        Dim result As Boolean
        Dim i As Integer
@@ 252行目: / 252行目: @@
        dupIdx = 0
-       ReDim tmp(UBound(values))
+       [[R]]eDim tmp(UBound(values))
        For i = LBound(values) To UBound(values)
            tmp(i) = values(i)
@@ 263行目: / 263行目: @@
            If i &gt; LBound(tmp) Then
                If curVal = tmp(i) Then
-                   ReDim Preserve duplicatedItems(dupIdx)
+                   [[R]]eDim Preserve duplicatedItems(dupIdx)
                    duplicatedItems(dupIdx) = curVal
                    dupIdx = dupIdx + 1

@@ 1行目: / 1行目: @@
 ==Excel VBA Utility==
-[Excel VBA]{{category VBAソース片}}
+[[Excel VBA]]{{category VBAソース片}}
 ===basUtil===
@@ 97行目: / 97行目: @@
        End If
-       If Right$(result, 1) <> DIR_SEP Then
+       If Right$(result, 1) &lt;&gt; DIR_SEP Then
            result = result & DIR_SEP
        End If
@@ 119行目: / 119行目: @@
        If Not isBlank(Trim$(rootDir)) _
-       And ("A" <= drv And drv <= "Z") _
+       And ("A" &lt;= drv And drv &lt;= "Z") _
        And (Mid$(rootDir, 2, 1) = ":") _
        Then
@@ 208行目: / 208行目: @@
        For i = LBound(values) To UBound(values)
            For j = i + 1 To UBound(values)
-               If StrComp(values(i), values(j), vbTextCompare) > 0 Then
+               If StrComp(values(i), values(j), vbTextCompare) &gt; 0 Then
                    tmp = values(i)
                    values(i) = values(j)
@@ 261行目: / 261行目: @@
        Dim curVal As String
        For i = LBound(tmp) To UBound(tmp)
-           If i > LBound(tmp) Then
+           If i &gt; LBound(tmp) Then
                If curVal = tmp(i) Then
                    ReDim Preserve duplicatedItems(dupIdx)