ModuleUtility

ModuleUtility.bas

Attribute VB_Name = "ModuleUtility"
Option Explicit

'=== 参照設定で有効にしておく項目 ===
'Microsoft Scripting Runtime
' FileSystemObject
'
'ストリーミング関係（UTF-8なcsvを出力や読み込みなど）
'Microsoft ActiveX Data Objects x.x Library
'  ADODB.stream
'
'HTTP通信(モジュール違いなだけで出来る事は同じか？)
'Microsoft XML v6.0
'Microsoft WinHTTP Services, version 5.1
'
'Outlook起動
'Microsoft Outlook 16.0 Object Library
'
'外部コマンドを実行 (WshShell)
'Windows Script Host Object Model
' === ここまで ===

' 指定されたモジュール、クラス類が存在するか確認する
Function ExistsVBComponent(ByVal component As String) As Boolean
    Dim ws As Worksheet
    Dim flag As Boolean
    Dim vbo As Object
    
    flag = False

    For Each vbo In ActiveWorkbook.VBProject.VBComponents
        If (vbo.Type = 1 Or vbo.Type = 2) And vbo.Name = component Then
            flag = True
            Exit For
        End If
    Next
    ExistsVBComponent = flag
End Function


' 指定されたワークシート名が存在するか確認する
Function ExistsWorksheet(ByVal sheet As String) As Boolean
    Dim ws As Worksheet
    Dim flag As Boolean
    flag = False
    For Each ws In Worksheets
        If ws.Name = sheet Then flag = True
    Next ws
    ExistsWorksheet = flag
End Function
    

Function GetAnyMonth(Optional ByVal i As Long = -1) As Date
    Dim d As Date

    d = DateAdd("m", i, Date)
    GetAnyMonth = d
End Function

Function GetLastMonthLastDay() As Date
    Dim d As Date

    d = Date
    GetLastMonthLastDay = DateSerial(Year(d), Month(d), 0)
End Function

Function GetLastMonthFirstDay() As Date
    Dim d As Date

    d = GetAnyMonth()
    GetLastMonthFirstDay = DateSerial(Year(d), Month(d), 1)
End Function

Function GetBusinessYear() As Long
    Dim y As Long
    Dim d As Date
    
    d = Date
    If Month(d) <= 3 Then
        y = Year(d) - 1
    Else
        y = Year(d)
    End If
    GetBusinessYear = y
End Function

' 指定したURLコンテンツを取得する
Function GetURL(ByVal url As String) As String
    GetURL = StrConv(GetURL_Raw(url), vbUnicode)
End Function

' 指定したURLコンテンツを取得する（byte版）
Function GetURL_Raw(ByVal url As String) As Byte()
    'Dim content As String
    Dim b() As Byte
    Dim httpReq As New MSXML2.ServerXMLHTTP60
    
    'Set httpReq = CreateObject("MSXML2.ServerXMLHTTP")
    httpReq.Open "GET", url, False
    httpReq.Send
    ' readyState=4で読み込みが完了
    Do While httpReq.readyState <> 4
        DoEvents
        httpReq.waitForResponse (1)
    Loop
    
    If httpReq.Status = 200 Then
        'content = httpObj.responseText ' レスポンスの文字コードがShift_JIS(MS932)の時はこちらを使う。
        'content = StrConv(httpReq.responseBody, vbUnicode)
        b = httpReq.responseBody
    Else
        Err.Raise number:=1000 + httpReq.Status, Description:=httpReq.statusText
    End If
    
    Set httpReq = Nothing
    GetURL_Raw = b
End Function



' 指定したシート・列の最終行のセルを取得
Function GetLastRow(ByVal sheet As String, Optional ByVal column As Long = 1) As Range
    Dim ws As Worksheet
    Dim rng As Range
  
    If Not ExistsWorksheet(sheet) Then
        Exit Function
    End If

    Set ws = Worksheets(sheet)
    Set GetLastRow = ws.Cells(Rows.Count, column).End(xlUp)
End Function

' 指定したシート・行の最終列のセルを取得
Function GetLastColumn(ByVal sheet As String, Optional ByVal row As Long = 1) As Range
    Dim ws As Worksheet
    Dim rng As Range
  
    If Not ExistsWorksheet(sheet) Then
        Exit Function
    End If

  Set ws = Worksheets(sheet)
  
  ' 最終列を取得する
  Set GetLastColumn = ws.Cells(row, columns.Count).End(xlToLeft)
End Function

' 簡易版slack通知
Function NotifySlack(ByVal slackURL As String, ByVal title As String, ByVal username As String, ByVal message As String, Optional ByVal icon_emoji As String = ":ghost:", Optional color As String = "#2EB886") As Boolean
    ' payload生成用
    Dim jsonData As New Dictionary
    Dim attachments As New Collection
    Dim attachmentData As New Dictionary
    Dim attachmentBlocks As New Collection
    Dim attachmentBlockData As New Dictionary
    Dim attachmentBlockTextData As New Dictionary
    Dim jsonPayload As String
    
    ' slack通知用
    Dim httpReq As New MSXML2.ServerXMLHTTP60
    Dim content As String
    
    If Not ExistsVBComponent("JsonConverter") Then
        Err.Raise number:=900, Description:="JsonConverterが存在しません。https://github.com/VBA-tools/VBA-JSON をインポートしてください"
        Exit Function
    End If
    
    Call attachmentBlockTextData.Add("type", "mrkdwn")
    Call attachmentBlockTextData.Add("text", message)
    
    Call attachmentBlockData.Add("type", "section")
    Call attachmentBlockData.Add("text", attachmentBlockTextData)
    
    Call attachmentBlocks.Add(attachmentBlockData)
    
    Call attachmentData.Add("color", color)
    Call attachmentData.Add("blocks", attachmentBlocks)
    
    Call attachments.Add(attachmentData)
  
    Call jsonData.Add("text", title)
    Call jsonData.Add("username", username)
    Call jsonData.Add("icon_emoji", icon_emoji)
    Call jsonData.Add("blocks", New Collection)
    
    Call jsonData.Add("attachments", attachments)
    
    jsonPayload = JsonConverter.ConvertToJson(jsonData)
    Debug.Print jsonPayload
    
    httpReq.Open "POST", slackURL, False
    httpReq.setRequestHeader "Content-type", "application/json"
    httpReq.Send (jsonPayload)
    Do While httpReq.readyState <> 4
        DoEvents
        httpReq.waitForResponse (1)
    Loop
    If httpReq.Status = 200 Then
        content = StrConv(httpReq.responseBody, vbUnicode)
    Else
        Err.Raise number:=1000 + httpReq.Status, Description:=httpReq.statusText
    End If

    NotifySlack = True
End Function

' ワークブックと同じフォルダに移動する
Function InitialWorkbookDir()
    ChDrive ThisWorkbook.path
    ChDir ThisWorkbook.path
End Function

' 指定されたCSVファイルを所定シートに取り込む
Function ReadCSV(ByVal csv As String, ByVal sheet As String) As Boolean
    Dim flag As Boolean
    Dim ws As Worksheet
    
    If ExistsWorksheet(sheet) Then
        Set ws = Worksheets(sheet)
        ws.Select
        ws.Activate
    Else
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = sheet
        Set ws = ActiveSheet
    End If
    ws.Cells.Clear
    
    If Dir(csv) <> "" Then
        Workbooks.Open Filename:=csv
        ActiveSheet.Cells.Copy ThisWorkbook.ActiveSheet.Cells
        ActiveWorkbook.Close SaveChanges:=False
        flag = True
    Else
        Err.Raise number:=900, Description:=csv & "が存在しません"
    End If
    
    ReadCSV = flag
End Function

' 指定されたCSVファイルを所定シートに取り込む
Function ReadCSV_v2(ByVal csv As String, ByVal sheet As String) As Boolean
    Dim flag As Boolean
    Dim ws As Worksheet
    
    If ExistsWorksheet(sheet) Then
        Set ws = Worksheets(sheet)
        ws.Select
        ws.Activate
    Else
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = sheet
        Set ws = ActiveSheet
    End If
    ws.Cells.Clear
    
    If Dir(csv) <> "" Then
        With ActiveSheet.QueryTables.Add(Connection:="text;" & csv, Destination:=Range("A1"))
'　　　　.Name = "temp"
'　　　　.FieldNames = True
'　　　　.RowNumbers = False
'　　　　.FillAdjacentFormulas = False
'　　　　.PreserveFormatting = True
'　　　　.RefreshOnFileOpen = False
'　　　　.RefreshStyle = xlInsertDeleteCells
'　　　　.SavePassword = False
'　　　　.SaveData = True
'　　　　.AdjustColumnWidth = True
'　　　　.RefreshPeriod = 0
'　　　　.TextFilePromptOnRefresh = False
        .TextFilePlatform = 932 'Shift_Jis.
'        .TextFilePlatform = 65001 'UTF8
'　　　　.TextFileStartRow = 1
'　　　　.TextFileParseType = xlDelimited
'　　　　.TextFileTextQualifier = xlTextQualifierDoubleQuote
'　　　　.TextFileConsecutiveDelimiter = False
'　　　　.TextFileTabDelimiter = False
'　　　　.TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
'　　　　.TextFileSpaceDelimiter = False
'　　　　.TextFileColumnDataTypes = Array(1, 1, 1)
'　　　　.TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False

        .Delete
        End With
        
        flag = True
    Else
        Err.Raise number:=900, Description:=csv & "が存在しません"
    End If
    
    ReadCSV_v2 = flag
End Function

Function ReadCSV_FromURL(ByVal url As String, ByVal sheet As String) As Boolean

    Dim path As String
    Dim fso As New Scripting.FileSystemObject
    path = fso.GetSpecialFolder(2) & "\" & fso.GetTempName & ".csv"

    URLDownloadToFile url:=url, path:=path
    
    ReadCSV csv:=path, sheet:=sheet
    
    If Dir(path) <> "" Then
        Kill (path)
    End If
    
    'fso = Nothing
    ReadCSV_FromURL = True
End Function

' Outlookでメール送信を行う
Function SendMail(ByVal subject As String, ByVal toAddr As String, ByVal body As String, Optional ByVal ccAddr As String = "", Optional ByVal sendMode As Long = 0, Optional ByVal closeFlag As Long = 0)
    Dim olApp As New Outlook.Application
    Dim myNameSpace As Outlook.Namespace
    Dim myFolder As Outlook.Folder
    Dim item As Outlook.MailItem
    
    Set myNameSpace = olApp.GetNamespace("MAPI")
    
    '作業フォルダーの指定(.GetDefaultFolder) と 表示(.Display)
    Set myFolder = myNameSpace.GetDefaultFolder(6) '規定のフォルダー olFolderInbox=6 指定
    myFolder.Display
    '通常サイズ olNormalWindow=2 で表示(ほかに olMaximized=0,olMinimized=1)
    olApp.ActiveWindow.WindowState = 2   'olNormalWindow=2 を セット

    ' メール送信実施
    Set item = olApp.CreateItem(0)
    item.Display
    item.subject = subject
    item.To = toAddr
    If ccAddr <> "" Then
        item.cc = ccAddr
    End If
    item.body = body

    '動作
    If sendMode = 0 Then
        ' 保存・下書き
        item.Save
    ElseIf sendMode = 1 Then
        ' 送信する
        item.Send
    End If
    
    If closeFlag = 1 Then
        Application.Wait Now() + TimeValue("00:00:03")
        ' ウィンドウを全て閉じる
        Do While olApp.Inspectors.Count > 0
            olApp.Inspectors(1).Close olSave
        Loop
        olApp.Quit
    End If
    
    SendMail = True
End Function

Function URLDownloadToFile(ByVal url As String, ByVal path As String) As Boolean
    Dim bytes() As Byte
    Dim stream As New ADODB.stream
    
    bytes = GetURL_Raw(url)

    With stream
        .Open
        .Type = adTypeBinary
        .Write bytes
        .SaveToFile path, adSaveCreateOverWrite
        .Close
    End With

    URLDownloadToFile = True
End Function


' URLエンコード
Function URLEncode_UTF8(ByVal text As String) As String
    Dim stream As New ADODB.stream
    Dim bin, number
    With stream
        .Open
        .Type = adTypeText
        .Charset = "UTF-8"
        .WriteText text
        .Position = 0
        .Type = adTypeBinary
        .Position = 3
        bin = .Read
        .Close
    End With
    For Each number In bin
        URLEncode_UTF8 = URLEncode_UTF8 & "%" & Hex(number)
    Next
End Function

' URLデコード
Function URLDecode_UTF8(ByVal text As String) As String
    Dim stream As New ADODB.stream
    Dim size As Long
    Dim i As Long
    Dim bytes() As Byte

    If Len(text) = 0 Then
        URLDecode_UTF8 = ""
        Exit Function
    Else
        size = Len(text) / 3
        ReDim bytes(0 To size - 1)
    End If
    
    For i = 0 To size - 1
        bytes(i) = Val("&H" & Mid(text, (i * 3) + 2, 2))
        'Debug.Print Val("&H" & Mid(text, (i * 3) + 2, 2))
    Next i
    
    With stream
        .Open
        .Type = adTypeBinary
        .Position = 0
        .SetEOS
        .Write bytes
    End With
  
    ' 読み込みなおす
    With stream
        .Position = 0
        .Type = adTypeText
        .Charset = "UTF-8"
        URLDecode_UTF8 = .ReadText
        .Close
    End With

    Set stream = Nothing
End Function

Function WriteCSV(ByVal csv As String, ByVal sheet As String) As Boolean
    Dim i As Long
    Dim j As Long
    Dim ws As Worksheet
    
    Set ws = ThisWorkbook.Worksheets(sheet)
    
    If ExistsWorksheet(sheet) Then
        Set ws = Worksheets(sheet)
        ws.Select
        ws.Activate
    Else
        Err.Raise number:=900, Description:=sheet & "が存在しません"
    End If
    

    Open csv For Output As #1
    ' 行
    i = 1
    Do While ws.Cells(i, 1).Value <> ""
    
        ' 列
        j = 1
        Do While ws.Cells(i, j + 1).Value <> ""

            Print #1, ws.Cells(i, j).Value & ",";
            j = j + 1
        Loop
        Print #1, ws.Cells(i, j).Value & vbLf;
        i = i + 1
    Loop
    Close #1
    
    WriteCSV = True
End Function

Function WriteCSV_UTF8(ByVal csv As String, ByVal sheet As String, Optional ByVal deleteBOM As Boolean = True) As Boolean
    Dim i As Long
    Dim j As Long
    Dim line As String
    Dim outStream As Object
    Dim csvStream As Object
    Dim ws As Worksheet
    
    Set ws = ThisWorkbook.Worksheets(sheet)
    
    If ExistsWorksheet(sheet) Then
        Set ws = Worksheets(sheet)
        ws.Select
        ws.Activate
    Else
        Err.Raise number:=900, Description:=sheet & "が存在しません"
    End If
    
    
    Set outStream = New ADODB.stream
    
    With outStream
        .Type = adTypeText
        .Charset = "UTF-8"
        .LineSeparator = adLF
    End With
    outStream.Open

    ' 行
    i = 1
    Do While ws.Cells(i, 1).Value <> ""
        line = ""
        ' 列
        j = 1
        Do While ws.Cells(i, j + 1).Value <> ""

            line = line & ws.Cells(i, j).Value & ","
            j = j + 1
        Loop
        line = line & ws.Cells(i, j).Value
        outStream.WriteText line, adWriteLine
        i = i + 1
    Loop

    
    If deleteBOM Then
        ' 先頭のBOMを削除
        'BOM の分 3 バイトをスキップ
        outStream.Position = 0
        outStream.Type = adTypeBinary
        outStream.Position = 3
    
        'コピー用のストリーム
        Set csvStream = New ADODB.stream
        csvStream.Type = adTypeBinary
        csvStream.Mode = 3
        csvStream.Open

        'BOM の後からデータをコピー
        outStream.CopyTo csvStream
    
        ' 保存
        csvStream.SaveToFile csv, adSaveCreateOverWrite
        csvStream.Close
        Set csvStream = Nothing
    Else
        ' そのまま保存するとBOM付きで保存される
        outStream.SaveToFile csv, adSaveCreateOverWrite
    End If
    outStream.Close
    Set outStream = Nothing
    WriteCSV_UTF8 = True
End Function