'============================================================================== ' Util.bas ' ' MIT License ' ' Copyright 2020 Takashi Harano ' ' Permission is hereby granted, free of charge, to any person obtaining a copy ' of this software and associated documentation files (the "Software"), to deal ' in the Software without restriction, including without limitation the rights ' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ' copies of the Software, and to permit persons to whom the Software is ' furnished to do so, subject to the following conditions: ' ' The above copyright notice and this permission notice shall be included in all ' copies or substantial portions of the Software. ' ' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ' SOFTWARE. ' ' https://libutil.com/ ' v202106272353 '============================================================================== Option Explicit Public Const DEFAULT_LINE_SEPARATOR As String = vbLf ' StreamTypeEnum Const adTypeBinary = 1 Const adTypeText = 2 ' LineSeparatorsEnum Const adCR = 13 Const adCRLF = -1 Const adLF = 10 ' StreamWriteEnum Const adWriteChar = 0 Const adWriteLine = 1 ' SaveOptionsEnum Const adSaveCreateNotExist = 1 Const adSaveCreateOverWrite = 2 '------------------------------------------------------------------------------ '# File '------------------------------------------------------------------------------ '' ' テキストファイルを読み込んで返します。 ' Public Function ReadTextFile(path As String, Optional charset As String = "UTF-8") As String Dim buf As String With CreateObject("ADODB.Stream") .charset = charset .Open .LoadFromFile path buf = .ReadText .Close End With ReadTextFile = buf End Function '' ' テキストファイルを読み込んで改行で区切った配列として返します。 ' Public Function ReadTextFileAsArray(path As String, Optional charset As String = "UTF-8") As String() Dim txt As String txt = ReadTextFile(path, charset) ReadTextFileAsArray = TextToArray(txt) End Function '' ' テキストファイルを書き込みます。 ' Public Sub WriteTextFile(path As String, content As String, Optional charset As String = "UTF-8") With CreateObject("ADODB.Stream") .Type = adTypeText .charset = charset .LineSeparator = adLF .Open .WriteText content, adWriteChar .Position = 0 .Type = adTypeBinary .Position = 3 Dim tmpBuf() As Byte tmpBuf = .Read .Close .Open .Write tmpBuf .SaveToFile path, adSaveCreateOverWrite .Close End With End Sub '' ' ファイルが存在するかを返します。 ' Public Function FileExists(path As String) As Boolean If Dir(path) = "" Then FileExists = False Else FileExists = True End If End Function '' ' ファイル存在しない場合にTrueを返します。 ' Public Function FileNotFound(path As String) As Boolean If Dir(path) = "" Then FileNotFound = True Else FileNotFound = False End If End Function '' ' ファイルを削除します。 ' 戻り値:削除したらTrue ' Public Function DeleteFile(path As String) As Boolean DeleteFile = False If FileExists(path) Then Kill path DeleteFile = True End If End Function '' ' フォルダを選択します。 ' 選択ダイアログを表示、選択するとそのパスを返します。 ' SelectFolderPath("A1") 'A1セルにパス文字列を設定します。 ' Public Function SelectFolderPath(Optional outCell As String = "", Optional ws As Worksheet = Nothing) If ws Is Nothing Then Set ws = ActiveSheet End If Dim path As String path = "" With Application.FileDialog(msoFileDialogFolderPicker) If .Show = True Then path = .SelectedItems(1) End If End With If path <> "" And outCell <> "" Then ws.Range(outCell).value = path End If SelectFolderPath = path End Function '' ' ファイルパスを選択します。 ' 選択ダイアログを表示、選択するとそのパスを返します。 ' title:="ダイアログタイトル" ' fileFilter:="ファイル種別フィルター" ' outCell:="A1" A1セルにパス文字列を設定します。 ' Public Function SelectFilePath(Optional title As String = "", _ Optional fileFilter As String = "All Files (*.*),*.*", _ Optional outCell As String = "", _ Optional ws As Worksheet = Nothing) If ws Is Nothing Then Set ws = ActiveSheet End If Dim path As String path = Application.GetOpenFilename(fileFilter, , title) If path = "False" Then path = "" End If If path <> "" And outCell <> "" Then ws.Range(outCell).value = path End If SelectFilePath = path End Function '' ' パスからファイル名の部分を返します。 ' "C:\dir\file.txt" -> "bar.txt" ' "file.txt" -> "bar.txt" ' Public Function GetFileName(path) As String Dim pos As Long pos = InStrRev(path, "\") GetFileName = Mid(path, pos + 1) End Function '' ' パスから拡張子を返します。 ' "C:\dir\file.txt" -> "txt" ' "file.txt" -> "txt" ' Public Function GetFileExtension(path) As String Dim fileName As String Dim pos As Long fileName = GetFileName(path) pos = InStrRev(fileName, ".") GetFileExtension = Mid(fileName, pos + 1) End Function '' ' 指定されたフォルダを親パス含めて生成します。 ' ' 絶対: "C:\a\b\c" ' 相対: "a\b\c" ' Public Sub MkDirs(path As String) Dim i As Long Dim depth As Long Dim targetPath As String Dim dirs() As String dirs = Split(path, "\") depth = UBound(dirs) targetPath = "" For i = 0 To depth targetPath = targetPath & dirs(i) & "\" If Dir(targetPath, vbDirectory) = "" Then MkDir (targetPath) End If Next i End Sub '------------------------------------------------------------------------------ '# Workbook '------------------------------------------------------------------------------ '' ' ExcelのBookが開いているか返します。 ' Public Function IsBookOpened(path) As Boolean IsBookOpened = False If path = "" Then Exit Function End If On Error Resume Next Open path For Append As #1 Close #1 If Err.Number > 0 Then IsBookOpened = True End If End Function '' ' ExcelのBookを開きます。 ' ' Dim wb As Workbook ' Set wb = OpenBook("C:\Book1.xlsx") ' Public Function OpenBook(path) As Workbook Set OpenBook = Nothing On Error GoTo ErrHandler If IsBookOpened(path) Then Dim fileName As String fileName = GetFileName(path) Set OpenBook = Workbooks(fileName) Else Set OpenBook = Workbooks.Open(path) End If ErrHandler: End Function '' ' ExcelのBookを閉じます。 ' Public Function CloseBook(path) If path = "" Or IsBookOpened(path) = False Then CloseBook = False Exit Function End If Dim fileName As String fileName = GetFileName(path) Workbooks(fileName).Close CloseBook = True End Function '------------------------------------------------------------------------------ '# Sheet '------------------------------------------------------------------------------ '' ' 指定された名前のシートが存在するかを返します。 ' Function SheetExists(name As String, Optional wb As Workbook = Nothing) If wb Is Nothing Then Set wb = ActiveWorkbook End If Dim ws As Worksheet For Each ws In wb.Worksheets If ws.name = name Then SheetExists = True Exit Function End If Next ws SheetExists = False End Function '' ' 指定された名前のシートが存在しない場合にTrueを返します。 ' Function SheetNotFound(name As String, Optional wb As Workbook = Nothing) SheetNotFound = Not SheetExists(name, wb) End Function '' ' 指定されたシートの先頭行を返します。 ' Public Function GetFirstRowOfSheet(Optional sheetName As String = "", Optional ws As Worksheet = Nothing) As Long If ws Is Nothing Then If sheetName = "" Then Set ws = ActiveSheet Else Set ws = Sheets(sheetName) End If End If Dim usedRng As Range Dim firstRow As Range Set usedRng = ws.UsedRange Set firstRow = usedRng.rows(1).EntireRow GetFirstRowOfSheet = firstRow.row End Function '' ' 指定されたシートの最終行を返します。 ' Public Function GetLastRowOfSheet(Optional sheetName As String = "", Optional ws As Worksheet = Nothing) As Long If ws Is Nothing Then If sheetName = "" Then Set ws = ActiveSheet Else Set ws = Sheets(sheetName) End If End If Dim usedRng As Range Dim lastRow As Range Set usedRng = ws.UsedRange Set lastRow = usedRng.rows(usedRng.rows.count).EntireRow GetLastRowOfSheet = lastRow.row End Function '' ' 指定されたシートの先頭列を返します。(A=1, B=2, ...) ' Public Function GetFirstColOfSheet(Optional sheetName As String = "", Optional ws As Worksheet = Nothing) As Long If ws Is Nothing Then If sheetName = "" Then Set ws = ActiveSheet Else Set ws = Sheets(sheetName) End If End If Dim usedRng As Range Dim firstCol As Range Set usedRng = ws.UsedRange Set firstCol = usedRng.Columns(1).EntireColumn GetFirstColOfSheet = firstCol.Column End Function '' ' 指定されたシートの最終列を返します。(A=1, B=2, ...) ' Public Function GetLastColOfSheet(Optional sheetName As String = "", Optional ws As Worksheet = Nothing) As Long If ws Is Nothing Then If sheetName = "" Then Set ws = ActiveSheet Else Set ws = Sheets(sheetName) End If End If Dim usedRng As Range Dim lastCol As Range Set usedRng = ws.UsedRange Set lastCol = usedRng.Columns(usedRng.Columns.count).EntireColumn GetLastColOfSheet = lastCol.Column End Function '' ' 指定された列の先頭行を返します。 ' Public Function GetFirstRowOfCol(col As String, Optional ws As Worksheet = Nothing) As Long If ws Is Nothing Then Set ws = ActiveSheet End If Dim n As Long Dim row As Long n = XlsColA2N(col) If ws.Cells(1, n).value <> "" Then GetFirstRowOfCol = 1 Exit Function End If row = ws.Cells(1, n).End(xlDown).row If row = ws.rows.count And ws.Cells(ws.rows.count, n).value = "" Then row = -1 End If GetFirstRowOfCol = row End Function '' ' 指定された列の最終行を返します。 ' Public Function GetLastRowOfCol(col As String, Optional ws As Worksheet = Nothing) As Long If ws Is Nothing Then Set ws = ActiveSheet End If Dim n As Long Dim row As Long n = XlsColA2N(col) row = ws.Cells(ws.rows.count, n).End(xlUp).row GetLastRowOfCol = row End Function '' ' 指定された行の先頭列を返します。("A", "B", ...) ' Public Function GetFirstColOfRow(row As Long, Optional ws As Worksheet = Nothing) As String If ws Is Nothing Then Set ws = ActiveSheet End If If ws.Cells(row, 1).value <> "" Then GetFirstColOfRow = "A" Exit Function End If Dim n As Long Dim col As String n = ws.Cells(row, 1).End(xlToRight).Column If n = ws.Columns.count And ws.Cells(row, ws.Columns.count).value = "" Then col = "" Else col = XlsColN2A(n) End If GetFirstColOfRow = col End Function '' ' 指定された行の最終列を返します。("A", "B", ...) ' Public Function GetLastColOfRow(row As Long, Optional ws As Worksheet = Nothing) As String If ws Is Nothing Then Set ws = ActiveSheet End If Dim n As Long Dim col As String n = ws.Cells(row, ws.Columns.count).End(xlToLeft).Column col = XlsColN2A(n) GetLastColOfRow = col End Function '' ' 指定されたセルに計算式が存在するかを返します。 ' Public Function HasFormula(ref As String, Optional ws As Worksheet = Nothing) As Boolean If ws Is Nothing Then Set ws = ActiveSheet End If HasFormula = ws.Range(ref).HasFormula End Function '' ' シートの表示位置を左上に設定します。 ' Public Sub ScrollToUpperLeft(Optional ws As Worksheet = Nothing) If ws Is Nothing Then Set ws = ActiveSheet End If ws.Activate ActiveWindow.ScrollColumn = 1 ActiveWindow.ScrollRow = 1 End Sub '' ' シートの表示位置をA1に設定します。 ' Public Sub ScrollToA1Cell(Optional ws As Worksheet = Nothing) If ws Is Nothing Then Set ws = ActiveSheet End If ws.Activate Application.GoTo Reference:=Cells(1, 1), Scroll:=True End Sub '' ' ブック内のすべての表示位置をA1に戻します。 ' Public Sub ResetAllSheetsToA1(Optional wb As Workbook = Nothing) If wb Is Nothing Then Set wb = ActiveWorkbook End If Dim ws As Worksheet Dim i For i = wb.Sheets.count To 1 Step -1 Set ws = wb.Sheets(i) ws.Activate Application.GoTo Reference:=ws.Cells(1, 1), Scroll:=True Next i End Sub '------------------------------------------------------------------------------ '# セル値 '------------------------------------------------------------------------------ '' ' 指定されたセルの値を返します。(シート名指定可能Rangeラッパー) ' GetCellValue("A1") ' GetCellValue("Sheet1!A1") ' Public Function GetCellValue(ref As String, Optional ws As Worksheet = Nothing) As Variant If ws Is Nothing Then Dim refPrts As Variant refPrts = Split(ref, "!") If UBound(refPrts) = 0 Then Set ws = ActiveSheet Else Dim sheetName As String sheetName = refPrts(0) Set ws = Sheets(sheetName) ref = refPrts(1) End If End If GetCellValue = ws.Range(ref).value End Function '' ' 指定されたセルの値を設定します。(シート名指定可能Rangeラッパー) ' SetCellValue("A1", "abc") ' SetCellValue("Sheet1!A1", "abc") ' Public Sub SetCellValue(ref As String, val As Variant, Optional ws As Worksheet = Nothing) If ws Is Nothing Then Dim refPrts As Variant refPrts = Split(ref, "!") If UBound(refPrts) = 0 Then Set ws = ActiveSheet Else Dim sheetName As String sheetName = refPrts(0) Set ws = Sheets(sheetName) ref = refPrts(1) End If End If ws.Range(ref).value = val End Sub '' ' シートの値をA1から存在する範囲全て取得して返します。 ' Public Function GetSheetValues(Optional sheetName As String = "", Optional ws As Worksheet = Nothing) As Variant If ws Is Nothing Then If sheetName = "" Then Set ws = ActiveSheet Else Set ws = Sheets(sheetName) End If End If Dim lastRowN As Long Dim lastColN As Long Dim lastColA As String lastRowN = GetLastRowOfSheet(sheetName, ws) lastColN = GetLastColOfSheet(sheetName, ws) lastColA = XlsColN2A(lastColN) Dim addr As String addr = "A1:" & lastColA & lastRowN Dim vals As Variant vals = GetRangeValues(addr, ws:=ws) GetSheetValues = vals End Function '' ' 指定されたセル範囲の値を2次元配列で返します。 ' ' GetRangeValues("A1:B2") ' GetRangeValues("Sheet1!A1:B2") ' -> ret(1, 1) = A1 ' ret(1, 2) = B1 ' ' GetRangeValues("A1:B2", transpose=True) ' -> ret(1, 1) = A1 ' ret(1, 2) = A2 ' ' GetRangeValues("A1:B2", idxOrigin=0) ' -> ret(0, 0) = A1 ' ret(0, 1) = B1 ' ' GetRangeValues("A1:B2", transpose=True, idxOrigin=0) ' -> ret(0, 0) = A1 ' ret(0, 1) = A2 ' Public Function GetRangeValues(refs As String, _ Optional transpose As Boolean = False, _ Optional idxOrigin As Long = 1, _ Optional ws As Worksheet = Nothing) As Variant If ws Is Nothing Then Dim refsPrts As Variant refsPrts = Split(refs, "!") If UBound(refsPrts) = 0 Then Set ws = ActiveSheet Else Dim sheetName As String sheetName = refsPrts(0) Set ws = Sheets(sheetName) refs = refsPrts(1) End If End If Dim rangeVals As Variant rangeVals = ws.Range(refs) If Not IsMultiRange(refs) Then rangeVals = SingleValueToArray(rangeVals) End If If transpose = False And idxOrigin = 1 Then GetRangeValues = rangeVals Exit Function End If Dim x As Long Dim y As Long Dim d1 As Long Dim d2 As Long Dim d1Max As Long Dim d2Max As Long Dim rowLen As Long Dim colLen As Long rowLen = UBound(rangeVals, 1) colLen = UBound(rangeVals, 2) If transpose Then d1Max = colLen d2Max = rowLen Else d1Max = rowLen d2Max = colLen End If Dim adj As Long If idxOrigin <= 1 Then adj = (1 - idxOrigin) * (-1) Else adj = idxOrigin - 1 End If d1Max = d1Max + adj d2Max = d2Max + adj Dim ret As Variant ReDim ret(idxOrigin To d1Max, idxOrigin To d2Max) d1 = idxOrigin d2 = idxOrigin For x = 1 To colLen If transpose Then d2 = idxOrigin Else d1 = idxOrigin End If For y = 1 To rowLen ret(d1, d2) = rangeVals(y, x) If transpose Then d2 = d2 + 1 Else d1 = d1 + 1 End If Next y If transpose Then d1 = d1 + 1 Else d2 = d2 + 1 End If Next x GetRangeValues = ret End Function '' ' 指定されたセル範囲に2次元配列の値を展開します。 ' ' SetRangeValues("A1:B2", values, transpose) ' -> 範囲かvaluesの範囲の小さい範囲に展開 ' ' SetRangeValues("A1", values, transpose) ' -> A1を起点にvaluesを全展開 ' ' Optional ' transpose=False : [行][列] ' transpose=True : [列][行] ' Public Sub SetRangeValues(refs As String, values As Variant, _ Optional transpose As Boolean = False, _ Optional ws As Worksheet = Nothing) If ws Is Nothing Then Dim refsPrts As Variant refsPrts = Split(refs, "!") If UBound(refsPrts) = 0 Then Set ws = ActiveSheet Else Dim sheetName As String sheetName = refsPrts(0) Set ws = Sheets(sheetName) refs = refsPrts(1) End If End If Dim refRowLen As Long Dim refColLen As Long Dim valRowOrigin As Long Dim valColOrigin As Long Dim valRowMax As Long Dim valColMax As Long Dim valRowLen As Long Dim valColLen As Long Dim stColA As String Dim stRow As Long Dim edColA As String Dim edRow As Long Dim rangeRowMax As Long Dim rangeColMax As Long rangeRowMax = -1 rangeColMax = -1 refRowLen = CountRowRange(refs) refColLen = CountColRange(refs) If transpose Then valRowOrigin = LBound(values, 2) valColOrigin = LBound(values, 1) valRowMax = UBound(values, 2) valColMax = UBound(values, 1) Else valRowOrigin = LBound(values, 1) valColOrigin = LBound(values, 2) valRowMax = UBound(values, 1) valColMax = UBound(values, 2) End If valRowLen = valRowMax - valRowOrigin + 1 valColLen = valColMax - valColOrigin + 1 Dim targetRefs As String targetRefs = refs If IsMultiRange(refs) Then Dim wkRefs As Variant Dim stRef As String Dim edRef As String wkRefs = Split(refs, ":") stRef = wkRefs(0) edRef = wkRefs(1) stColA = GetCellRefA(stRef) stRow = GetCellRefN(stRef) edColA = GetCellRefA(edRef) edRow = GetCellRefN(edRef) If refRowLen > valRowLen Then edRow = stRow + valRowLen - 1 End If If refColLen > valColLen Then edColA = RelativeXlsColA(stColA, valColLen - 1) End If targetRefs = stColA & stRow & ":" & edColA & edRow Else stColA = GetCellRefA(refs) stRow = GetCellRefN(refs) edColA = RelativeXlsColA(stColA, valColLen - 1) edRow = stRow + valRowLen - 1 targetRefs = refs & ":" & edColA & edRow refRowLen = valRowLen refColLen = valColLen End If Dim rowLen As Long rowLen = refRowLen If rowLen > valRowLen Then rowLen = valRowLen End If Dim colLen As Long colLen = refColLen If colLen > valColLen Then colLen = valColLen End If If rangeRowMax = -1 Then Dim adjR As Long If valRowOrigin <= 1 Then adjR = 1 - valRowOrigin Else adjR = valRowOrigin End If rangeRowMax = rowLen + adjR End If If rangeColMax = -1 Then Dim adjC As Long If valColOrigin <= 1 Then adjC = 1 - valColOrigin Else adjC = valColOrigin End If rangeColMax = colLen + adjC End If Dim rangeVals As Variant ReDim rangeVals(1 To rangeRowMax, 1 To rangeColMax) Dim refRowIdx As Long Dim refColIdx As Long Dim valRowIdx As Long Dim valColIdx As Long Dim i As Long Dim j As Long refRowIdx = 1 valRowIdx = valRowOrigin For i = 1 To rowLen refColIdx = 1 valColIdx = valColOrigin For j = 1 To colLen Dim val As Variant If transpose Then val = values(valColIdx, valRowIdx) Else val = values(valRowIdx, valColIdx) End If rangeVals(refRowIdx, refColIdx) = val valColIdx = valColIdx + 1 refColIdx = refColIdx + 1 Next j valRowIdx = valRowIdx + 1 refRowIdx = refRowIdx + 1 Next i ws.Range(targetRefs) = rangeVals End Sub '' ' セル範囲内の値を1次元配列に格納します。(行方向→) ' ' RowToArray("A1:B3") ' RowToArray("Sheet1!A1:B3") ' -> [A1, B1, A2, B2, A3, B3] ' Public Function RowToArray(refs As String, Optional ws As Worksheet = Nothing) As Variant If ws Is Nothing Then Dim refsPrts As Variant refsPrts = Split(refs, "!") If UBound(refsPrts) = 0 Then Set ws = ActiveSheet Else Dim sheetName As String sheetName = refsPrts(0) Set ws = Sheets(sheetName) refs = refsPrts(1) End If End If Dim rangeVals As Variant Dim rowLen As Long Dim colLen As Long rangeVals = ws.Range(refs) Dim arr As Variant If Not IsMultiRange(refs) Then ReDim arr(0) arr(0) = rangeVals RowToArray = arr Exit Function End If rowLen = UBound(rangeVals, 1) colLen = UBound(rangeVals, 2) ReDim arr(colLen * rowLen - 1) Dim i As Long Dim j As Long Dim cnt As Long cnt = 0 For i = 1 To rowLen For j = 1 To colLen arr(cnt) = rangeVals(i, j) cnt = cnt + 1 Next j Next i RowToArray = arr End Function '' ' セル範囲内の値を1次元配列に格納します。(列方向↓) ' ' ColToArray("A1:B3") ' ColToArray("Sheet1!A1:B3") ' -> [A1, A2, A3, B1, B2, B3] ' Public Function ColToArray(refs As String, Optional ws As Worksheet = Nothing) As Variant If ws Is Nothing Then Dim refsPrts As Variant refsPrts = Split(refs, "!") If UBound(refsPrts) = 0 Then Set ws = ActiveSheet Else Dim sheetName As String sheetName = refsPrts(0) Set ws = Sheets(sheetName) refs = refsPrts(1) End If End If Dim rangeVals As Variant Dim rowLen As Long Dim colLen As Long rangeVals = ws.Range(refs) Dim arr As Variant If Not IsMultiRange(refs) Then ReDim arr(0) arr(0) = rangeVals ColToArray = arr Exit Function End If rowLen = UBound(rangeVals, 1) colLen = UBound(rangeVals, 2) ReDim arr(colLen * rowLen - 1) Dim i As Long Dim j As Long Dim cnt As Long cnt = 0 For i = 1 To colLen For j = 1 To rowLen arr(cnt) = rangeVals(j, i) cnt = cnt + 1 Next j Next i ColToArray = arr End Function '' ' 1次元配列の値を行→に展開します。 ' ' ArrayToRow(arr, "A1") ' ArrayToRow(arr, "Sheet1!A1") ' A B C ' 1 arr(0) arr(1) arr(2) ... ' 2 ' Public Sub ArrayToRow(arr As Variant, targetStartCell As String, Optional ws As Worksheet = Nothing) If IsEmptyArray(arr) Then Exit Sub End If If ws Is Nothing Then Dim refPrts As Variant refPrts = Split(targetStartCell, "!") If UBound(refPrts) = 0 Then Set ws = ActiveSheet Else Dim sheetName As String sheetName = refPrts(0) Set ws = Sheets(sheetName) targetStartCell = refPrts(1) End If End If Dim arrLastIdx As Long arrLastIdx = UBound(arr) Dim rangeArr As Variant ReDim rangeArr(1, arrLastIdx) Dim i As Long For i = 0 To arrLastIdx rangeArr(0, i) = arr(i) Next i Dim targetEndCell As String targetEndCell = RelativeCellAddr(targetStartCell, arrLastIdx, 0) Dim rangeAddr As String rangeAddr = targetStartCell & ":" & targetEndCell ws.Range(rangeAddr) = rangeArr End Sub '' ' 1次元配列の値を列↓に展開します。 ' ' ArrayToCol(arr, "A1") ' ArrayToCol(arr, "Sheet1!A1") ' A B C ' 1 arr(0) ' 2 arr(1) ' 3 arr(2) ' : ' Public Sub ArrayToCol(arr As Variant, targetStartCell As String, Optional ws As Worksheet = Nothing) If IsEmptyArray(arr) Then Exit Sub End If If ws Is Nothing Then Dim refPrts As Variant refPrts = Split(targetStartCell, "!") If UBound(refPrts) = 0 Then Set ws = ActiveSheet Else Dim sheetName As String sheetName = refPrts(0) Set ws = Sheets(sheetName) targetStartCell = refPrts(1) End If End If Dim arrLastIdx As Long arrLastIdx = UBound(arr) Dim rangeArr As Variant ReDim rangeArr(arrLastIdx, 1) Dim i As Long For i = 0 To arrLastIdx rangeArr(i, 0) = arr(i) Next i Dim targetEndCell As String targetEndCell = RelativeCellAddr(targetStartCell, 0, arrLastIdx) Dim rangeAddr As String rangeAddr = targetStartCell & ":" & targetEndCell ws.Range(rangeAddr) = rangeArr End Sub '' ' 指定された範囲の列方向↓の値を行方向→に展開します。 ' ' ColToRow("A", "B1") ' ColToRow("A1:A3", "B1") ' ColToRow("Sheet1!A1:A3", "Sheet2!B1") ' Public Sub ColToRow(fmAddr As String, toAddr As String) Dim sheetName As String sheetName = "" Dim pos As Long pos = InStr(fmAddr, "!") If pos > 0 Then sheetName = Left(fmAddr, pos - 1) fmAddr = Mid(fmAddr, pos + 1) End If Dim ws As Worksheet Set ws = Nothing If sheetName <> "" Then Set ws = Sheets(sheetName) End If If IsOnlyColName(fmAddr) Then Dim fmCol As String Dim a() As String a = SplitRefAddrs(fmAddr) fmCol = a(1) Dim firstRow As Long Dim lastRow As Long firstRow = GetFirstRowOfCol(fmCol, ws) lastRow = GetLastRowOfCol(fmCol, ws) fmAddr = fmCol & firstRow & ":" & fmCol & lastRow End If Dim arr As Variant arr = ColToArray(fmAddr, ws) Call ArrayToRow(arr, toAddr) End Sub '' ' 指定された範囲の行方向→の値を列方向↓に展開します。 ' ' RowToCol("1", "A2") ' RowToCol("A1:C1", "A2") ' RowToCol("Sheet1!A1:C1", "Sheet2!A2") ' Public Sub RowToCol(fmAddr As String, toAddr As String) Dim sheetName As String sheetName = "" Dim pos As Long pos = InStr(fmAddr, "!") If pos > 0 Then sheetName = Left(fmAddr, pos - 1) fmAddr = Mid(fmAddr, pos + 1) End If Dim ws As Worksheet Set ws = Nothing If sheetName <> "" Then Set ws = Sheets(sheetName) End If If IsOnlyRowNumber(fmAddr) Then Dim fmRow As Long Dim a() As String a = SplitRefAddrs(fmAddr) fmRow = a(2) Dim firstCol As String Dim lastCol As String firstCol = GetFirstColOfRow(fmRow, ws) lastCol = GetLastColOfRow(fmRow, ws) fmAddr = firstCol & fmRow & ":" & lastCol & fmRow End If Dim arr As Variant arr = RowToArray(fmAddr, ws) Call ArrayToCol(arr, toAddr) End Sub '' ' 選択されている範囲を指定されたセルを先頭に行方向→に展開します。 ' Public Sub SelectionToRow(dest As String) Dim vals As Variant vals = GetSelectedValues() Call ArrayToRow(vals, dest) End Sub '' ' 選択されている範囲を指定されたセルを先頭に列方向↓に展開します。 ' Public Sub SelectionToCol(dest As String) Dim vals As Variant vals = GetSelectedValues() Call ArrayToCol(vals, dest) End Sub '' ' 選択されている範囲の値を1次元配列として返します。 ' Public Function GetSelectedValues() As Variant Dim cnt As Long Dim i As Long cnt = Selection.count Dim vals As Variant ReDim vals(cnt) For i = 1 To cnt vals(i - 1) = Selection(i) Next i GetSelectedValues = vals End Function '' ' 指定された列範囲の値を重複要素のないSetコレクションに変換して返します。 ' ExtractUniqueValues("A1:B20") ' ExtractUniqueValues("Sheet1!A1:B20") ' Public Function ExtractUniqueValues(refs As String, Optional ws As Worksheet = Nothing) As Variant Dim arr As Variant arr = ColToArray(refs) ExtractUniqueValues = Array2Set(arr) End Function '' ' 指定された列範囲の値を重複要素のないSetコレクションに変換し、指定されたセルを起点に列方向↓に表示します。 ' Call PrintUniqueValues("A1:B20", "B1") ' Call PrintUniqueValues("A:A", "B1") ' Public Sub PrintUniqueValues(refs As String, outStartCellAddr As String, Optional ws As Worksheet = Nothing) If ws Is Nothing Then Set ws = ActiveSheet End If Dim s As Variant s = ExtractUniqueValues(refs) Call ArrayToCol(s, outStartCellAddr, ws) End Sub '' ' 選択されている範囲の値を重複要素のないSetコレクションに変換し、指定されたセルを起点に列方向↓に表示します。 ' Public Sub SelectionToUniqueValues(dest As String, Optional ws As Worksheet = Nothing) If ws Is Nothing Then Set ws = ActiveSheet End If Dim vals As Variant vals = GetSelectedValues() Dim s As Variant s = Array2Set(vals) Call ArrayToCol(s, dest, ws) End Sub '' ' 単一の値を2次元配列に格納します。 ' Private Function SingleValueToArray(value As Variant) Dim arr As Variant ReDim arr(1 To 1, 1 To 1) arr(1, 1) = value SingleValueToArray = arr End Function '' ' シート全体をクリアします。 ' Public Function ClearSheet(Optional sheetName As String = "", Optional ws As Worksheet = Nothing) As Long If ws Is Nothing Then If sheetName = "" Then Set ws = ActiveSheet Else Set ws = Sheets(sheetName) End If End If ws.Cells.clear End Function '------------------------------------------------------------------------------ '# 配列操作 '------------------------------------------------------------------------------ '' ' 配列に要素をpushします。 ' Public Sub ArrayPush(ByRef arr As Variant, val As Variant) On Error GoTo ArrInit ReDim Preserve arr(UBound(arr) + 1) arr(UBound(arr)) = val Exit Sub ArrInit: ReDim arr(0) arr(0) = val End Sub '' ' 配列のサイズを返します。 ' Public Function GetArraySize(ByRef arr As Variant, Optional dimension As Long = 1) As Long GetArraySize = -1 On Error Resume Next If IsEmptyArray(arr) Then GetArraySize = 0 Else GetArraySize = UBound(arr, dimension) - LBound(arr, dimension) + 1 End If On Error GoTo 0 End Function '' ' 配列の次元数を返します。 ' Public Function GetArrayDimensions(ByRef arr As Variant) As Long Dim i As Long Dim n As Long i = 0 n = 0 On Error Resume Next Do While Err.Number = 0 i = i + 1 n = UBound(arr, i) Loop On Error GoTo 0 GetArrayDimensions = i - 1 End Function '' ' 配列が空であるかを返します。 ' Public Function IsEmptyArray(arr As Variant) As Boolean IsEmptyArray = False Dim i As Long On Error GoTo ErrHandler i = UBound(arr) Exit Function ErrHandler: IsEmptyArray = True End Function '' ' 配列を重複要素のないSetコレクションに変換して返します。 ' Public Function Array2Set(ByRef arr As Variant) As Variant Dim dic As Object Set dic = CreateObject("Scripting.Dictionary") Dim val As Variant Dim i As Long For i = 0 To UBound(arr) val = arr(i) If dic.Exists(val) Then dic.Item(val) = dic.Item(val) + 1 Else dic.Item(val) = 1 End If Next Array2Set = dic.Keys() End Function '' ' テキストを改行で区切って配列として返します。 ' Public Function TextToArray(txt As String) As String() txt = ReplaceLineSeparator(txt, vbLf) Dim arr() As String arr = Split(txt, vbLf) If arr(UBound(arr)) = "" Then ReDim Preserve arr(UBound(arr) - 1) End If TextToArray = arr End Function '------------------------------------------------------------------------------ '# 文字列操作 '------------------------------------------------------------------------------ '' ' 文字列のパターンマッチを検査します。 ' ("ABC123", "\d") -> True ' ("ABC123", "abc") -> False ' ("ABC123", "abc", True) -> True ' ("A(B)", "A(B)", escMeta:=True) -> True ' ("A(B)", "A(B)", escMeta:=False) -> False ' Public Function Match(target As String, pattern As String, Optional ignoreCase As Boolean = False, Optional escMeta As Boolean = False) As Boolean If escMeta Then pattern = EscapeMetaChars(pattern) End If Dim regexp As Object Set regexp = CreateObject("VBScript.RegExp") With regexp .pattern = pattern .ignoreCase = ignoreCase .Global = True End With Match = regexp.Test(target) End Function '' ' 文字列のパターンにマッチした部分を抜き出します。 ' ("abc123xyz", ".+?(\d+).*") -> "123" ' Public Function GetPattern(target As String, pattern As String) As String Dim regexp As Object Set regexp = CreateObject("VBScript.RegExp") With regexp .pattern = pattern .ignoreCase = False .Global = True End With Dim result As String result = "" Dim matches As Variant Set matches = regexp.Execute(target) If matches.count > 0 Then Dim m As Variant Set m = matches(0) result = m.SubMatches(0) End If GetPattern = result End Function '' ' 正規表現のメタ文字をエスケープして返します。 ' Public Function EscapeMetaChars(str As String) As String str = Replace(str, "\", "\\") str = Replace(str, "^", "\^") str = Replace(str, "$", "\$") str = Replace(str, "(", "\(") str = Replace(str, ")", "\)") str = Replace(str, "[", "\[") str = Replace(str, "]", "\]") str = Replace(str, ".", "\.") str = Replace(str, "*", "\*") str = Replace(str, "+", "\+") str = Replace(str, "?", "\?") str = Replace(str, "|", "\|") str = Replace(str, "{", "\{") str = Replace(str, "}", "\}") EscapeMetaChars = str End Function '' ' 改行コードを変換して返します。 ' Function ReplaceLineSeparator(text As String, separator As String) As String Dim newText As String newText = Replace(text, vbCrLf, vbLf) newText = Replace(text, vbCr, vbLf) newText = Replace(text, vbLf, separator) ReplaceLineSeparator = newText End Function '' ' 文字列の長さを幅でカウントします。 ' 半角=1/全角=2 ' Public Function LenW(str As String) As Long Dim ch As String Dim cd As Integer Dim cnt As Long Dim i As Long cnt = 0 For i = 1 To Len(str) ch = Mid(str, i, 1) cd = Asc(ch) If cd >= 0 And cd <= 255 Then cnt = cnt + 1 Else cnt = cnt + 2 End If Next LenW = cnt End Function '' ' リスト内にある文字列の最長の文字数を返します。 ' ' textList ' 文字列のリスト ' byWidth ' 文字数ではなく文字幅(半角=1/全角=2)で扱います。 ' Public Function CountLongestLen(textList() As String, Optional byWidth As Boolean = True) Dim longestLen As Long Dim i As Long Dim textLen As Long Dim text As String longestLen = 0 For i = 0 To UBound(textList) text = textList(i) If byWidth Then textLen = LenW(text) Else textLen = Len(text) End If If textLen > longestLen Then longestLen = textLen End If Next CountLongestLen = longestLen End Function '' ' 指定された文字列でパディングします。 ' ' str ' 元の文字列 ' padding ' パディング用文字列 ' totalLen ' パディング後のトータル文字数(半角=1/全角=2でカウント) ' direction ' パディング位置 ' "L" = Pad to the Left ' "R" = Pad to the Right ' byWidth ' 文字数ではなく文字幅(半角=1/全角=2)で扱います。 ' Public Function PadString(str As String, padding As String, totalLen As Long, direction As String, Optional byWidth As Boolean = True) Dim ret As String Dim strLen As Long If byWidth Then strLen = LenW(str) Else strLen = Len(str) End If ret = str If strLen < totalLen Then Dim n As Long n = totalLen - strLen Dim pad As String Dim i As Long pad = String(n, padding) If direction = "L" Then ret = pad & str Else ret = str & pad End If End If PadString = ret End Function '' ' 文字列を1文字ずつに分解した配列にして返します。 ' Public Function String2Array(str As String) As String() Dim strLen As Long strLen = Len(str) Dim arr() As String ReDim arr(strLen) Dim i As Long For i = 0 To strLen arr(i) = Mid(str, i + 1, 1) Next i String2Array = arr End Function '' ' 指定された文字集合で指定された文字列が何番目に出現するかを返します。 ' ("ABC", "A") -> 1 ' ("ABC", "B") -> 2 ' ("ABC", "AA") -> 4 ' Public Function StrPIndex(tbl As String, ptn As String) As Long Dim ptnLen As Long Dim rdx As Long Dim idx As Long Dim i As Long ptnLen = Len(ptn) rdx = Len(tbl) idx = 0 Dim d As Long Dim c As String Dim v As Long Dim n As Long For i = 0 To (ptnLen - 1) d = ptnLen - i c = Mid(ptn, d, 1) v = InStr(tbl, c) If v = 0 Then StrPIndex = 0 Exit Function End If n = v * (rdx ^ i) idx = idx + n Next StrPIndex = idx End Function '' ' 文字集合を順列で並べた場合の指定されたインデックスに値する文字列を返します。 ' ("ABC", 1) -> "A" ' ("ABC", 2) -> "B" ' ("ABC", 4) -> "AA" ' Public Function StrP(strTbl As String, idx As Long) As String If idx < 1 Then StrP = "" Exit Function End If Dim tbl() As String tbl = String2Array(strTbl) Dim tbllen As Long tbllen = Len(strTbl) Dim a() As Long Call ArrayPush(a, -1) Dim i As Long For i = 0 To idx - 1 Dim j As Long j = 0 Dim carryFlag As Boolean carryFlag = True Dim aLen As Long aLen = UBound(a) + 1 Do While j < aLen If carryFlag = True Then a(j) = a(j) + 1 If a(j) > (tbllen - 1) Then a(j) = 0 If (aLen <= j + 1) Then Call ArrayPush(a, -1) aLen = UBound(a) + 1 End If Else carryFlag = False End If End If j = j + 1 Loop Next Dim s As String s = "" For i = UBound(a) To 0 Step -1 s = s & tbl(a(i)) Next StrP = s End Function '------------------------------------------------------------------------------ '# セル参照アドレス '------------------------------------------------------------------------------ '' ' セル参照の英字部分を返します。 ' GetCellRefA("A1") -> "A" ' GetCellRefA("$A$1") -> "A" ' Public Function GetCellRefA(ref As String) As String Dim reg Set reg = CreateObject("VBScript.RegExp") With reg .pattern = "\$" .ignoreCase = True .Global = True End With Dim a As String a = reg.Replace(ref, "") reg.pattern = "\d+$" a = reg.Replace(a, "") GetCellRefA = a End Function '' ' セル参照の数字部分を返します。 ' GetCellRefA("A1") -> 1 ' GetCellRefA("$A$1") -> 1 ' GetCellRefA("A") -> 0 ' Public Function GetCellRefN(ref As String) As Long Dim reg Set reg = CreateObject("VBScript.RegExp") With reg .pattern = "\$" .ignoreCase = True .Global = True End With Dim a As String a = reg.Replace(ref, "") reg.pattern = "^[A-Za-z]+" a = reg.Replace(a, "") If a = "" Then a = "0" End If GetCellRefN = a End Function '' ' セル番号をセル名に変換します。 ' 1 -> "A" ' 2 -> "B" ' 26 -> "Z" ' 27 -> "AA" ' Public Function XlsColN2A(index As Long) As String XlsColN2A = StrP("ABCDEFGHIJKLMNOPQRSTUVWXYZ", index) End Function '' ' セル名をセル番号に変換します。 ' "A" -> 1 ' "B" -> 2 ' "Z" -> 26 ' "AA" -> 27 ' Public Function XlsColA2N(col As String) As Long XlsColA2N = StrPIndex("ABCDEFGHIJKLMNOPQRSTUVWXYZ", col) End Function '' ' セル名からのオフセットの位置にあるセル名を返します。 ' "A", 1 -> "B" ' "B", -1 -> "A" ' Public Function RelativeXlsColA(col As String, offset As Long) As String Dim n As Long n = XlsColA2N(col) + offset RelativeXlsColA = XlsColN2A(n) End Function '' ' セルアドレスからのオフセットの位置にあるアドレスを返します。 ' "A1", 1, 2 -> "B3" ' "B3", -1. -2 -> "A1" ' Public Function RelativeCellAddr(orgAddr As String, colOffset As Long, rowOffset) As String Dim a As String Dim n As Long a = GetCellRefA(orgAddr) n = GetCellRefN(orgAddr) Dim targetA As String Dim targetN As Long targetA = RelativeXlsColA(a, colOffset) targetN = n + rowOffset If targetA = "" Or targetN = 0 Then RelativeCellAddr = "" Else RelativeCellAddr = targetA & targetN End If End Function '' ' セル参照範囲に含まれる行数を返します。 ' CountRowRange("A1:B3") -> 3 ' CountRowRange("A1") -> 1 ' Public Function CountRowRange(refs As String) As Long Dim wkRefs As Variant Dim stRef As String Dim edRef As String Dim stN As String Dim edN As String wkRefs = Split(refs, ":") If UBound(wkRefs) < 1 Then CountRowRange = 1 Exit Function End If stRef = wkRefs(0) edRef = wkRefs(1) stN = GetCellRefN(stRef) edN = GetCellRefN(edRef) If stN > edN Then Dim tmp As String tmp = stN stN = edN edN = tmp End If Dim count As Long count = edN - stN + 1 CountRowRange = count End Function '' ' セル参照範囲に含まれる列数を返します。 ' CountColRange("A1:B3") -> 2 ' CountColRange("A1") -> 1 ' Public Function CountColRange(refs As String) As Long Dim wkRefs As Variant Dim stRef As String Dim edRef As String Dim stA As String Dim stColIdx As Long Dim edA As String Dim edColIdx As Long wkRefs = Split(refs, ":") If UBound(wkRefs) < 1 Then CountColRange = 1 Exit Function End If stRef = wkRefs(0) edRef = wkRefs(1) stA = GetCellRefA(stRef) edA = GetCellRefA(edRef) stColIdx = XlsColA2N(stA) edColIdx = XlsColA2N(edA) If stColIdx > edColIdx Then Dim tmp As String tmp = stColIdx stColIdx = edColIdx edColIdx = tmp End If Dim count As Long count = edColIdx - stColIdx + 1 CountColRange = count End Function '' ' セル参照が複数セルであるかを返します。 ' "A1" -> False ' "A1:A1" -> False ' "A1:B2" -> True ' "A:A" -> True ' "1:1" -> True ' Public Function IsMultiRange(refs As String) As Boolean IsMultiRange = False Dim wkRefs As Variant Dim stRef As String Dim edRef As String Dim stA As String Dim stN As Long Dim edA As String Dim edN As Long wkRefs = Split(refs, ":") If UBound(wkRefs) < 1 Then Exit Function End If stRef = wkRefs(0) edRef = wkRefs(1) stA = GetCellRefA(stRef) stN = GetCellRefN(stRef) edA = GetCellRefA(edRef) edN = GetCellRefN(edRef) If stRef <> edRef Or stA = "" Or edA = "" Or stN = 0 Or edN = 0 Then IsMultiRange = True End If End Function '' ' セル参照アドレスをパーツに分解します。 ' ' "Sheet1!A1:B2" ' -> (0) "Sheet1" ' (1) "A" ' (2) "1" ' (3) "B" ' (4) "2" ' ' "A:2" -> (0)"", (1)"A", (2)"0", (3)"", (4)"2" Public Function SplitRefAddrs(refs) As String() Dim sheetName As String Dim wkRefs As Variant Dim stRef As String Dim edRef As String Dim stA As String Dim stN As String Dim edA As String Dim edN As String sheetName = "" Dim pos As Long pos = InStr(refs, "!") If pos > 0 Then sheetName = Left(refs, pos - 1) refs = Mid(refs, pos + 1) End If wkRefs = Split(refs, ":") stRef = wkRefs(0) edRef = "" If UBound(wkRefs) >= 1 Then edRef = wkRefs(1) End If stA = GetCellRefA(stRef) stN = GetCellRefN(stRef) edA = GetCellRefA(edRef) edN = GetCellRefN(edRef) Dim addrParts(4) As String addrParts(0) = sheetName addrParts(1) = stA addrParts(2) = stN addrParts(3) = edA addrParts(4) = edN SplitRefAddrs = addrParts End Function '' ' セル参照アドレスが行番号だけであるかを返します。 ' ' "1" -> True ' "A" -> False ' "A1" -> False ' "A1:B2" -> False ' Public Function IsOnlyRowNumber(refs As String) As Boolean IsOnlyRowNumber = False Dim a() As String a = SplitRefAddrs(refs) If a(1) = "" And a(2) <> "0" And a(3) = "" And a(4) = "0" Then IsOnlyRowNumber = True End If End Function '' ' セル参照アドレスが列名だけであるかを返します。 ' ' "A" -> True ' "A1" -> False ' "A1:B2" -> False ' "1" -> False ' Public Function IsOnlyColName(refs As String) As Boolean IsOnlyColName = False Dim a() As String a = SplitRefAddrs(refs) If a(1) <> "" And a(2) = "0" And a(3) = "" And a(4) = "0" Then IsOnlyColName = True End If End Function '------------------------------------------------------------------------------ '# Date Time '------------------------------------------------------------------------------ '' ' Unix time (秒) を返します。 ' Public Function GetUnixTime() As Long Dim offset As Long offset = GetLocalTimeZoneOffset() GetUnixTime = DateDiff("s", #1/1/1970#, Now()) - offset * 60 End Function '' ' ローカルタイムゾーン情報を返します。 ' Public Function GetTimeZoneInfo() As Object Dim locator As Object Dim service As Object 'SWbemServices Dim tzSet As Object Set locator = CreateObject("WbemScripting.SWbemLocator") Set service = locator.ConnectServer() Set tzSet = service.ExecQuery("Select * From Win32_TimeZone") Set GetTimeZoneInfo = tzSet End Function '' ' ローカルタイムゾーンのオフセットを分で返します。 ' Public Function GetLocalTimeZoneOffset() As Long Dim tzSet As Object Dim tz As Object Set tzSet = GetTimeZoneInfo() GetLocalTimeZoneOffset = 0 For Each tz In tzSet GetLocalTimeZoneOffset = tz.Bias Exit For Next End Function '' ' ローカルタイムゾーン名を返します。 ' Public Function GetLocalTimeZoneName() As String Dim tzSet As Object Dim tz As Object Set tzSet = GetTimeZoneInfo() GetLocalTimeZoneName = "" For Each tz In tzSet GetLocalTimeZoneName = tz.StandardName Exit For Next End Function '------------------------------------------------------------------------------ '# Clipboard '------------------------------------------------------------------------------ '' ' クリップボードの値を取得します。 ' 画像等テキストでないものが入っている場合は空文字を返します。 ' Public Function GetClipboard() As String GetClipboard = "" With CreateObject("Forms.TextBox.1") .MultiLine = True If .CanPaste Then .Paste GetClipboard = .text End If End With End Function '' ' クリップボードにテキストを設定します。 ' Public Sub SetClipboard(text As String) With CreateObject("Forms.TextBox.1") .MultiLine = True .text = text .SelStart = 0 .SelLength = .TextLength .Copy End With End Sub '' ' クリップボードが持っている値の形式を返します。 ' https://docs.microsoft.com/ja-jp/office/vba/api/excel.xlclipboardformat ' Public Function GetClipboardFormat() As Long Dim fmt As Variant fmt = Application.ClipboardFormats GetClipboardFormat = fmt(1) End Function '' ' クリップボードが値を持っているかを返します。 ' Public Function HasClipboardValue() As Boolean HasClipboardValue = True If GetClipboardFormat() = -1 Then HasClipboardValue = False End If End Function '------------------------------------------------------------------------------ '# HTTP '------------------------------------------------------------------------------ Public Function HttpRequest(url As String, Optional method As String = "GET", Optional data As String = "") As Object Dim q As String If method = "GET" And data <> "" Then q = "?" & data url = url & q End If Dim httpReq As Object Set httpReq = CreateObject("MSXML2.XMLHTTP") httpReq.Open method, url httpReq.setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT" If method = "POST" And data <> "" Then httpReq.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" httpReq.Send data Else httpReq.Send End If Do While httpReq.readyState < 4 DoEvents Loop Set HttpRequest = httpReq End Function '------------------------------------------------------------------------------ '# Debug '------------------------------------------------------------------------------ '' ' イミディエイトウィンドウにログ出力します。 ' Public Sub DbgLog(v As Variant, Optional dumpBytes As Boolean = False) Dim t As String t = "[" & Format(Now, "yyyy-mm-dd hh:mm:ss") & "] " Dim s As String Dim i As Long Dim vType As Integer Dim arrSize As Long vType = VarType(v) arrSize = -1 On Error Resume Next If IsEmptyArray(v) Then arrSize = 0 Else arrSize = UBound(v) - LBound(v) + 1 End If On Error GoTo 0 If arrSize > 0 Then ' Array Dump For i = LBound(v) To UBound(v) Debug.Print t & "(" & i & ") = " & v(i) Next i Else If vType = 9 Then s = "Nothing" Else s = v End If If dumpBytes Then ' String Byte Array Dump Dim h As String Dim b() As Byte b = s s = "" For i = 0 To UBound(b) If i > 0 Then s = s & " " End If h = Hex(b(i)) If Len(h) = 1 Then s = s & "0" End If s = s & h Next End If Debug.Print t & s End If End Sub