<commit_before>Attribute VB_Name = "Y_IO_utiliy"
'Y_IO_utility
'Copyright (c) 2016 mmYYmmdd
Option Explicit

'*********************************************************************************
'   IO֘A[eBeB
'*********************************************************************************
'   Function    sheet2m             ExcelV[g̃Z͈͂z擾
'   Sub         m2sheet             zExcelV[g̃Z͈͂Ƀy[Xg
'   Function    getRangeMatrix      ExcelV[g̃Z͈͂RangeIuWFNg̔z擾
'   Function    getInterior         IuWFNgInteriorvpeB擾
'   Function    push_back_l         vh_stdVecɒlpush_backt@N^ij
'   Function    push_back_r         vh_stdVecɒlpush_backt@N^iEj
'   Function    textFile2m          eLXgt@C̔zǂݍ
'   Function    mapTextFile         eLXgt@C̍sPʂł̏
'   Function    m2textFile          z̃eLXgt@C
'   Function    getURLText          URLŎw肳ꂽeLXg̔zǂݍ
'   Function    urlEncode           URLGR[h
'   Function    urlDecode           URLfR[h
'   Sub         m2Clip              zi2ȉjNbv{[hɓ]
'   Function    HTMLDocFromText     HTMLeLXgHTMLDocumentIuWFNg
'   Function    getTagsFromHTML     HTMLeLXg̃^Oo
'   (Function p_getTitleFromHTMLAnchor)
'   Function    wTable2m            Word̃e[uz擾
'   Function    downloadFiles       URLŎw肵t@C̃_E[h
'   Function    encodeBase64        t@CBase64GR[hibinary -> textj
'   Function    decodeBase64        t@CBase64fR[hitext -> binaryj
'   Function    str2Base64          Base64GR[h
'*********************************************************************************

Public Declare PtrSafe Function textfile2array Lib "mapM.dll" _
                                    (ByRef fileName As Variant, _
                                ByVal codepage As Long, _
                            ByVal head_n As Long, _
                        ByVal head_cut As Long, _
                    ByVal toAarry As Boolean) As Variant

Public Declare PtrSafe Function textfile_for_each Lib "mapM.dll" _
                                    (ByRef fun As Variant, _
                                ByRef fileName As Variant, _
                            ByVal codepage As Long, _
                        ByVal head_n As Long, _
                    ByVal head_cut As Long) As Long

Public Declare PtrSafe Function array2textfile Lib "mapM.dll" _
                                        (ByRef m As Variant, _
                                    ByRef fileName As Variant, _
                                ByVal codepage As Long, _
                            ByVal append As Boolean, _
                        ByVal CrLf As Boolean) As Long
                                    
' ExcelV[g̃Z͈͂z擾il̂݁j
' vec = TrueF1z
' vec = FaleF2ziftHgj
' LBound = 0 ̔zƂȂ
Public Function sheet2m(ByVal r As Object, Optional ByVal vec As Boolean = False) As Variant
    If StrConv(Application.name, vbLowerCase) Like "*excel*" And TypeName(r) = "Range" Then
        If r.cells.Count = 1 Then
            sheet2m = makeM(1, 1, r.value)
        Else
            sheet2m = r.value
        End If
        If vec Then sheet2m = vector(sheet2m)
        changeLBound sheet2m, 0
    End If
End Function

' zExcelV[g̃Z͈͂Ƀy[XgĩZwj
' vertical = TrueF1zcɃy[Xg
Public Sub m2sheet(ByRef matrix As Variant, _
                   ByVal r As Object, _
                   Optional ByVal vertical As Boolean = False)
    If StrConv(Application.name, vbLowerCase) Like "*excel*" And TypeName(r) = "Range" And 0 < sizeof(matrix) Then
        Select Case Dimension(matrix)
        Case 0:
            r.value = matrix
        Case 1:
            If vertical Then
                r.Resize(sizeof(matrix), 1).value = transpose(matrix)
            Else
                r.Resize(1, sizeof(matrix)).value = matrix
            End If
        Case 2:
            r.Resize(rowSize(matrix), colSize(matrix)).value = matrix
        End Select
    End If
End Sub

' ExcelV[g̃Z͈͂RangeIuWFNg̔z擾
Public Function getRangeMatrix(ByVal r As Object) As Variant
    If StrConv(Application.name, vbLowerCase) Like "*excel*" And TypeName(r) = "Range" Then
        Dim i As Long, j As Long, ret As Variant
        With r
            ret = makeM(.rows.Count, .Columns.Count)
            For i = 0 To rowSize(ret) - 1 Step 1
                For j = 0 To colSize(ret) - 1 Step 1
                    Set ret(i, j) = .cells(i + 1, j + 1)
                Next j
            Next i
        End With
    swapVariant getRangeMatrix, ret
    End If
End Function

' IuWFNgInteriorvpeB擾
Public Function getInterior(ByRef Ob As Variant, ByRef dummuy As Variant) As Variant
    Set getInterior = Ob.Interior
End Function
    Public Function p_getInterior(Optional ByRef firstParam As Variant, Optional ByRef secondParam As Variant) As Variant
        p_getInterior = make_funPointer(AddressOf getInterior, firstParam, secondParam)
    End Function

' vh_stdVecɒlpush_backt@N^ij
Public Function push_back_l(ByRef v As Variant, ByRef x As Variant) As Variant
    Set push_back_l = v.push_back(x)
End Function
    Function p_push_back_l(Optional ByRef firstParam As Variant, Optional ByRef secondParam As Variant) As Variant
        p_push_back_l = make_funPointer(AddressOf push_back_l, firstParam, secondParam)
    End Function

' vh_stdVecɒlpush_backt@N^iEj
Public Function push_back_r(ByRef x As Variant, ByRef v As Variant) As Variant
    Set push_back_r = v.push_back(x)
End Function
    Function p_push_back_r(Optional ByRef firstParam As Variant, Optional ByRef secondParam As Variant) As Variant
        p_push_back_r = make_funPointer(AddressOf push_back_r, firstParam, secondParam)
    End Function

'---------------------------------------------------------------
        ' ϊpR[hy[WiPrivateIȊ֐j
        Function getCodePage(ByVal cp As String) As Long
            Select Case StrConv(cp, vbUpperCase + vbNarrow)
            Case "UTF-16", "UTF16", "UTF-16-LE", "UTF16-LE":
                                                getCodePage = 1200
            Case "UTF-8", "UTF8":               getCodePage = 65001
            Case "UTF-8N", "UTF8N":             getCodePage = -65001
            Case "UTF-7", "UTF7":               getCodePage = 65000
            Case "ANSI":                        getCodePage = 1252  'ANSI(1252)
            Case "SJIS", "S-JIS", "SHIFT-JIS":  getCodePage = 932
            Case "MAC":                         getCodePage = 2
            Case "OEM":                         getCodePage = 1
            Case "SYMBOL", "SYMBOL42":          getCodePage = 42
            Case Else
                If IsNumeric(cp) Then getCodePage = CLng(cp) Else getCodePage = 65001
            End Select
        End Function
'---------------------------------------------------------------

' eLXgt@C̔zǂݍ
' codepage : W̖
' head_n   : ǂݐ擪sw
' head_cut : 擪XLbvsw
' to_Array = False ̎̓eLXgŜЂƂ̕ŕԂ
Public Function textFile2m(ByVal fileName As String, _
                        ByVal codepage As String, _
                        Optional ByVal head_n As Long = -1, _
                        Optional ByVal head_cut As Long = 0, _
                        Optional ByVal to_Array As Boolean = True) As Variant
    textFile2m = textfile2array(fileName, _
                            getCodePage(codepage), _
                        head_n, _
                    head_cut, _
                to_Array)
End Function

' eLXgt@C̍sPʂł̏
' fn       : VBAHaskell̊֐iLȊ֐łȂ΍sԂj
' codepage : W̖
' head_n   : 擪sw
' head_cut : 擪XLbvsw
' ߂l   : s
Public Function mapTextFile(ByRef fn As Variant, _
                            ByVal fileName As String, _
                            ByVal codepage As String, _
                            Optional ByVal head_n As Long = -1, _
                            Optional ByVal head_cut As Long = 0) As Long
    mapTextFile = textfile_for_each(fn, _
                                fileName, _
                            getCodePage(codepage), _
                        head_n, _
                    head_cut)
End Function

' z̃eLXgt@C
Public Function m2textFile(ByRef data As Variant, _
                           ByVal fileName As String, _
                           ByVal codepage As String, _
                           Optional ByVal append As Boolean = False, _
                           Optional ByVal CrLf As Boolean = True) As Long
    Dim codepage_ As Long
    codepage_ = getCodePage(codepage)
    If IsArray(data) Then
        m2textFile = array2textfile(data, fileName, codepage_, append, CrLf)
    Else
        m2textFile = array2textfile(Array(data), fileName, codepage_, append, CrLf)
    End If
End Function

' URLŎw肳ꂽeLXg̔zǂݍ
' head_n : ǂݐ擪sw
Public Function getURLText(ByVal URL As String, _
                           ByVal line_end As String, _
                           Optional ByVal Charset As String = "_autodetect_all", _
                           Optional ByVal head_n As Long = -1, _
                           Optional ByVal userName As String = "", _
                           Optional ByVal passWord As String = "") As Variant
    Dim http As Object: Set http = CreateObject("MSXML2.XMLHTTP")
    On Error GoTo closeObjects
    With http
        If 0 < Len(userName) And 0 < Len(passWord) Then
                .Open "GET", URL, False, userName, passWord
        Else
            .Open "GET", URL, False
        End If
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "Cache-Control", "no-cache"
        .Send
    End With
    Dim ado As Object:  Set ado = CreateObject("ADODB.Stream")
    Dim i As Long
    Dim lineS As String
    With ado
        .Open
        .Position = 0
        .Type = 1       'ADODB.Stream.adTypeBinary
        .Write http.responseBody
        .Position = 0
        .Type = 2       'ADODB.Stream.adTypeText
        .Charset = Charset
        If 0 < head_n Then
            .LineSeparator = IIf(line_end = vbCr, Asc(vbCr), IIf(line_end = vbLf, Asc(vbLf), -1))
            For i = 1 To head_n
                lineS = .ReadText(-2)   'adReadLine
                getURLText = getURLText & lineS & IIf(i = head_n, "", line_end)
            Next i
        Else
            getURLText = .ReadText
        End If
    End With
closeObjects:
    If Not ado Is Nothing Then ado.Close
    Set ado = Nothing
    Set http = Nothing
    If 0 < Len(line_end) And VarType(getURLText) = vbString Then
        getURLText = Split(getURLText, line_end)
    End If
End Function

' URLGR[hiQlj
Public Function urlEncode(ByVal s As String) As String
    Dim ado As Object
    Dim tmp As Variant
    tmp = mapF(p_mid(s), zip(iota(1, Len(s)), repeat(1, Len(s))))
    Set ado = CreateObject("ADODB.Stream")
    ado.Charset = "UTF-8"
    tmp = mapF(p_urlEncode_1(, ado), tmp)
    Set ado = Nothing
    urlEncode = Join(tmp, "")
End Function

' URLfR[hiQlj
Public Function urlDecode(ByVal s As String) As String
    If s Like "*%??%??%??*" Then
        Dim begin As Long, theNext As Long
        begin = 1
        Dim ado As Object
        Set ado = CreateObject("ADODB.Stream")
        Do While begin <= Len(s) And Mid(s, begin) Like "*%??%??%??*"
            If Mid(s, begin, 9) Like "*%??%??%??*" Then
                urlDecode = urlDecode & urlDecode_imple(Mid(s, begin, 9), ado)
                begin = begin + 9
            Else
                theNext = InStr(begin + 1, s, "%")
                If 0 < theNext Then
                    urlDecode = urlDecode & Mid(s, begin, theNext - begin)
                    begin = theNext
                Else
                    urlDecode = urlDecode & Mid(s, begin)
                    begin = Len(s) + 1
                End If
            End If
        Loop
        Set ado = Nothing
        If begin < Len(s) Then
            urlDecode = urlDecode & Mid(s, begin)
        End If
    Else
        urlDecode = s
    End If
End Function

    Private Function isKanaKanji(ByVal s As String) As Boolean
        isKanaKanji = False
        If 0 < Len(s) Then
            If Left(s, 1) Like "[-]" Then
                isKanaKanji = True
            ElseIf Asc(Left(s, 1)) < 0 Then
                isKanaKanji = True
            End If
        End If
    End Function

    ' http://stabucky.com/wp/archives/4237
    Private Function urlEncode_1(ByRef s As Variant, ByRef adodbStream As Variant) As Variant
        Dim chars() As Byte
        If isKanaKanji(s) Then
            With adodbStream
                .Open
                .Type = 2       'ADODB.Stream.adTypeText
                .Position = 0
                .WriteText Left(s, 1)
                .Position = 0
                .Type = 1       'ADODB.Stream.adTypeBinary
                .Position = 3
                chars = .Read
                .Close
                urlEncode_1 = "%" & Hex(chars(0)) & "%" & Hex(chars(1)) & "%" & Hex(chars(2))
            End With
        Else
            urlEncode_1 = s
        End If
    End Function
    Private Function p_urlEncode_1(Optional ByRef firstParam As Variant, Optional ByRef secondParam As Variant) As Variant
        p_urlEncode_1 = make_funPointer(AddressOf urlEncode_1, firstParam, secondParam)
    End Function


    Private Function urlDecode_imple(ByVal code As String, ByRef adodbStream As Object) As String
        Dim chars(0 To 2) As Byte
        chars(0) = CLng("&H" & Mid(code, 2, 2))
        chars(1) = CLng("&H" & Mid(code, 5, 2))
        chars(2) = CLng("&H" & Mid(code, 8, 2))
        With adodbStream
            .Open
            .Type = 1       'ADODB.Stream.adTypeBinary
            .Position = 0
            .Write chars
            .Position = 0
            .Type = 2       'ADODB.Stream.adTypeText
            .Charset = "UTF-8"
            urlDecode_imple = .ReadText
            .Close
        End With
    End Function

' zi2ȉjNbv{[hɓ]
Public Sub m2Clip(ByRef data As Variant)
    Dim s As String
    Select Case Dimension(data)
    Case 0
        s = CStr_(data) & vbCrLf
    Case 1
        s = Join(mapF(p_CStr, data), vbTab) & vbCrLf
    Case 2
        Dim tmp As Variant
        tmp = zipC(mapF(p_CStr, data))
        tmp = mapF(p_join(, vbTab), tmp)
        s = Join(tmp, vbCrLf) & vbCrLf
    End Select
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        .text = s
        .SelStart = 0
        .SelLength = .TextLength
        .Copy
    End With
End Sub

' HTMLeLXgHTMLDocumentIuWFNg
Public Function HTMLDocFromText(ByVal htmlText As String) As Object    'As HtmlDocument
    Set HTMLDocFromText = CreateObject("htmlfile") 'New MSHTML.HTMLDocument
    HTMLDocFromText.Write htmlText
End Function

' HTMLeLXg̃^Oo
' vpeB͈propŎw
' innerText, outerText, innerHTML, outerHTML, href ͕Ŏw
' ȊO p_getTitleFromHTMLAnchor Q
Public Function getTagsFromHTML(ByVal htmlText As String, _
                                ByVal tag As Variant, _
                                ByVal prop As Variant) As Variant
    Dim doc As Object   'As HTMLDocument
    Set doc = HTMLDocFromText(htmlText)
    Dim vec As vh_stdvec:   Set vec = New vh_stdvec
    Dim z As Variant
    If is_bindFun(prop) Then
        For Each z In doc.all.tags(tag)
            vec.push_back z
        Next z
        getTagsFromHTML = mapF(prop, vec.free)
    ElseIf TypeName(prop) = "String" Then
        Select Case StrConv(prop, vbLowerCase)
        Case "it"
            For Each z In doc.all.tags(tag)
                vec.push_back z.innerText
            Next z
        Case "ot"
            For Each z In doc.all.tags(tag)
                vec.push_back z.outerText
            Next z
        Case "ih"
            For Each z In doc.all.tags(tag)
                vec.push_back z.innerHTML
            Next z
        Case "oh"
            For Each z In doc.all.tags(tag)
                vec.push_back z.outerHTML
            Next z
        Case "href"
            For Each z In doc.all.tags(tag)
                vec.push_back z.href
            Next z
        End Select
        getTagsFromHTML = vec.free
    End If
    Set doc = Nothing
End Function

'HTMLAnchorElement 'Title'vpeB擾
    Private Function getTitleFromHTMLAnchor(ByRef anchor As Variant, _
                                            ByRef dummy As Variant) As Variant
        If TypeName(anchor) = "HTMLAnchorElement" Then
            getTitleFromHTMLAnchor = anchor.Title
        End If
    End Function
Public Function p_getTitleFromHTMLAnchor(Optional ByRef firstParam As Variant, Optional ByRef secondParam As Variant) As Variant
    p_getTitleFromHTMLAnchor = make_funPointer(AddressOf getTitleFromHTMLAnchor, firstParam, secondParam)
End Function
    
' Word̃e[uz擾
Public Function wTable2m(ByVal t As Object, Optional ByVal cutHeader As Boolean = False) As Variant
    If StrConv(Application.name, vbLowerCase) Like "*word*" And TypeName(t) = "Table" Then
        Dim ret As Variant, tmp As String
        With t
            ret = makeM(.rows.Count, .Columns.Count)
            Dim i As Long, j As Long
            For i = 1 To .rows.Count Step 1
                For j = 1 To .Columns.Count Step 1
                    tmp = .Cell(i, j).Range.text
                    ret(i - 1, j - 1) = Left(tmp, Len(tmp) - 2)
                Next j
            Next i
        End With
    End If
    If cutHeader Then
        wTable2m = subM(ret, iota(1, UBound(ret, 1)))
    Else
        Call swapVariant(wTable2m, ret)
    End If
End Function

' URLŎw肵t@C̃_E[h
' fileNamesȗ̓N̒ʂiŌ'/'̌땔j
' ߂l̓_E[hłt@C̐
Public Function downloadFiles(ByRef URLs As Variant, _
                              ByVal pathName As String, _
                              Optional ByRef fileNames As Variant, _
                              Optional ByVal userName As String = "", _
                              Optional ByVal passWord As String = "") As Long
    downloadFiles = 0
    Dim fso As Object:      Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.folderExists(pathName) Then
        Set fso = Nothing
        Exit Function
    End If
    Dim URLm As Variant:    URLm = vector(URLs)
    Dim fNames As Variant
    If IsMissing(fileNames) Or IsEmpty(fileNames) Or IsNull(fileNames) Then
        fNames = mapF(p_getNth_b(, -1), mapF(p_split(, "/"), URLm))
    Else
        fNames = vector(fileNames)
    End If
    Dim i As Long
    For i = 0 To min_fun(UBound(URLm), UBound(fNames)) Step 1
        If downloadFile_(URLm(i), fso.BuildPath(pathName, fNames(i)), userName, passWord) Then
            downloadFiles = downloadFiles + 1
        End If
    Next i
    Set fso = Nothing
End Function

    Private Function downloadFile_(ByVal URL As String, _
                                   ByVal fileName As String, _
                                   ByVal userName As String, _
                                   ByVal passWord As String) As Boolean
        downloadFile_ = False
        Dim oo As Object:   Set oo = CreateObject("MSXML2.XMLHTTP")
        If oo Is Nothing Then Exit Function
        On Error GoTo closeFun
        With oo
            If 0 < Len(userName) And 0 < Len(passWord) Then
                .Open "GET", URL, False, userName, passWord
            Else
                .Open "GET", URL, False
            End If
            .setRequestHeader "Pragma", "no-cache"
            .setRequestHeader "Cache-Control", "no-cache"
            .Send
        End With
        Select Case oo.Status       ' HTTP Result Code
        Case Is <= 200          ' NGXg
            With CreateObject("ADODB.Stream")
                .Type = 1 ' ADODB.Stream.adTypeBinary
                .Open
                .Write oo.responseBody
                .SaveToFile fileName, 2 ' adSaveCreateOverWrite
                .Close
            End With
            downloadFile_ = True
        End Select
closeFun:
    End Function

' t@CBase64GR[hibinary -> textj
Function encodeBase64(ByVal fromFile As String, ByVal toFile As String) As Boolean
    With CreateObject("Scripting.FileSystemObject")
        If Not .FileExists(fromFile) Then Exit Function
        If Not .folderExists(.GetParentFolderName(toFile)) Then Exit Function
    End With
    Dim elm As Object
    On Error Resume Next
    Set elm = CreateObject("MSXML2.DOMDocument").CreateElement("base64")
    With CreateObject("ADODB.Stream")
        .Type = 1   'adTypeBinary<commit_msg>m2sheetで「Lotus 1-2-3 形式のキー操作」を一時的にオフするようにした<commit_after>Attribute VB_Name = "Y_IO_utiliy"
'Y_IO_utility
'Copyright (c) 2016 mmYYmmdd
Option Explicit

'*********************************************************************************
'   IO֘A[eBeB
'*********************************************************************************
'   Function    sheet2m             ExcelV[g̃Z͈͂z擾
'   Sub         m2sheet             zExcelV[g̃Z͈͂Ƀy[Xg
'   Function    getRangeMatrix      ExcelV[g̃Z͈͂RangeIuWFNg̔z擾
'   Function    getInterior         IuWFNgInteriorvpeB擾
'   Function    push_back_l         vh_stdVecɒlpush_backt@N^ij
'   Function    push_back_r         vh_stdVecɒlpush_backt@N^iEj
'   Function    textFile2m          eLXgt@C̔zǂݍ
'   Function    mapTextFile         eLXgt@C̍sPʂł̏
'   Function    m2textFile          z̃eLXgt@C
'   Function    getURLText          URLŎw肳ꂽeLXg̔zǂݍ
'   Function    urlEncode           URLGR[h
'   Function    urlDecode           URLfR[h
'   Sub         m2Clip              zi2ȉjNbv{[hɓ]
'   Function    HTMLDocFromText     HTMLeLXgHTMLDocumentIuWFNg
'   Function    getTagsFromHTML     HTMLeLXg̃^Oo
'   (Function p_getTitleFromHTMLAnchor)
'   Function    wTable2m            Word̃e[uz擾
'   Function    downloadFiles       URLŎw肵t@C̃_E[h
'   Function    encodeBase64        t@CBase64GR[hibinary -> textj
'   Function    decodeBase64        t@CBase64fR[hitext -> binaryj
'   Function    str2Base64          Base64GR[h
'*********************************************************************************

Public Declare PtrSafe Function textfile2array Lib "mapM.dll" _
                                    (ByRef fileName As Variant, _
                                ByVal codepage As Long, _
                            ByVal Head_N As Long, _
                        ByVal Head_Cut As Long, _
                    ByVal toAarry As Boolean) As Variant

Public Declare PtrSafe Function textfile_for_each Lib "mapM.dll" _
                                    (ByRef fun As Variant, _
                                ByRef fileName As Variant, _
                            ByVal codepage As Long, _
                        ByVal Head_N As Long, _
                    ByVal Head_Cut As Long) As Long

Public Declare PtrSafe Function array2textfile Lib "mapM.dll" _
                                        (ByRef m As Variant, _
                                    ByRef fileName As Variant, _
                                ByVal codepage As Long, _
                            ByVal append As Boolean, _
                        ByVal CrLf As Boolean) As Long
                                    
' ExcelV[g̃Z͈͂z擾il̂݁j
' vec = TrueF1z
' vec = FaleF2ziftHgj
' LBound = 0 ̔zƂȂ
Public Function sheet2m(ByVal r As Object, Optional ByVal vec As Boolean = False) As Variant
    If StrConv(Application.Name, vbLowerCase) Like "*excel*" And TypeName(r) = "Range" Then
        If r.Cells.count = 1 Then
            sheet2m = makeM(1, 1, r.value)
        Else
            sheet2m = r.value
        End If
        If vec Then sheet2m = vector(sheet2m)
        changeLBound sheet2m, 0
    End If
End Function

' zExcelV[g̃Z͈͂Ƀy[XgĩZwj
' vertical = TrueF1zcɃy[Xg
Public Sub m2sheet(ByRef matrix As Variant, _
                   ByVal r As Object, _
                   Optional ByVal vertical As Boolean = False)
    If StrConv(Application.Name, vbLowerCase) Like "*excel*" And TypeName(r) = "Range" And 0 < sizeof(matrix) Then
        Dim Application_TransitionNavigKeys As Boolean
        Application_TransitionNavigKeys = Application.TransitionNavigKeys
        Application.TransitionNavigKeys = False     '
        Select Case Dimension(matrix)
        Case 0:
            r.value = matrix
        Case 1:
            If vertical Then
                r.Resize(sizeof(matrix), 1).value = transpose(matrix)
            Else
                r.Resize(1, sizeof(matrix)).value = matrix
            End If
        Case 2:
            r.Resize(rowSize(matrix), colSize(matrix)).value = matrix
        End Select
        Application.TransitionNavigKeys = Application_TransitionNavigKeys
    End If
End Sub

' ExcelV[g̃Z͈͂RangeIuWFNg̔z擾
Public Function getRangeMatrix(ByVal r As Object) As Variant
    If StrConv(Application.Name, vbLowerCase) Like "*excel*" And TypeName(r) = "Range" Then
        Dim i As Long, j As Long, ret As Variant
        With r
            ret = makeM(.rows.count, .Columns.count)
            For i = 0 To rowSize(ret) - 1 Step 1
                For j = 0 To colSize(ret) - 1 Step 1
                    Set ret(i, j) = .Cells(i + 1, j + 1)
                Next j
            Next i
        End With
    swapVariant getRangeMatrix, ret
    End If
End Function

' IuWFNgInteriorvpeB擾
Public Function getInterior(ByRef Ob As Variant, ByRef dummuy As Variant) As Variant
    Set getInterior = Ob.Interior
End Function
    Public Function p_getInterior(Optional ByRef firstParam As Variant, Optional ByRef secondParam As Variant) As Variant
        p_getInterior = make_funPointer(AddressOf getInterior, firstParam, secondParam)
    End Function

' vh_stdVecɒlpush_backt@N^ij
Public Function push_back_l(ByRef v As Variant, ByRef x As Variant) As Variant
    Set push_back_l = v.push_back(x)
End Function
    Function p_push_back_l(Optional ByRef firstParam As Variant, Optional ByRef secondParam As Variant) As Variant
        p_push_back_l = make_funPointer(AddressOf push_back_l, firstParam, secondParam)
    End Function

' vh_stdVecɒlpush_backt@N^iEj
Public Function push_back_r(ByRef x As Variant, ByRef v As Variant) As Variant
    Set push_back_r = v.push_back(x)
End Function
    Function p_push_back_r(Optional ByRef firstParam As Variant, Optional ByRef secondParam As Variant) As Variant
        p_push_back_r = make_funPointer(AddressOf push_back_r, firstParam, secondParam)
    End Function

'---------------------------------------------------------------
        ' ϊpR[hy[WiPrivateIȊ֐j
        Function getCodePage(ByVal cp As String) As Long
            Select Case StrConv(cp, vbUpperCase + vbNarrow)
            Case "UTF-16", "UTF16", "UTF-16-LE", "UTF16-LE":
                                                getCodePage = 1200
            Case "UTF-8", "UTF8":               getCodePage = 65001
            Case "UTF-8N", "UTF8N":             getCodePage = -65001
            Case "UTF-7", "UTF7":               getCodePage = 65000
            Case "ANSI":                        getCodePage = 1252  'ANSI(1252)
            Case "SJIS", "S-JIS", "SHIFT-JIS":  getCodePage = 932
            Case "MAC":                         getCodePage = 2
            Case "OEM":                         getCodePage = 1
            Case "SYMBOL", "SYMBOL42":          getCodePage = 42
            Case Else
                If IsNumeric(cp) Then getCodePage = CLng(cp) Else getCodePage = 65001
            End Select
        End Function
'---------------------------------------------------------------

' eLXgt@C̔zǂݍ
' codepage : W̖
' head_n   : ǂݐ擪sw
' head_cut : 擪XLbvsw
' to_Array = False ̎̓eLXgŜЂƂ̕ŕԂ
Public Function textFile2m(ByVal fileName As String, _
                        ByVal codepage As String, _
                        Optional ByVal Head_N As Long = -1, _
                        Optional ByVal Head_Cut As Long = 0, _
                        Optional ByVal to_Array As Boolean = True) As Variant
    textFile2m = textfile2array(fileName, _
                            getCodePage(codepage), _
                        Head_N, _
                    Head_Cut, _
                to_Array)
End Function

' eLXgt@C̍sPʂł̏
' fn       : VBAHaskell̊֐iLȊ֐łȂ΍sԂj
' codepage : W̖
' head_n   : 擪sw
' head_cut : 擪XLbvsw
' ߂l   : s
Public Function mapTextFile(ByRef fn As Variant, _
                            ByVal fileName As String, _
                            ByVal codepage As String, _
                            Optional ByVal Head_N As Long = -1, _
                            Optional ByVal Head_Cut As Long = 0) As Long
    mapTextFile = textfile_for_each(fn, _
                                fileName, _
                            getCodePage(codepage), _
                        Head_N, _
                    Head_Cut)
End Function

' z̃eLXgt@C
Public Function m2textFile(ByRef data As Variant, _
                           ByVal fileName As String, _
                           ByVal codepage As String, _
                           Optional ByVal append As Boolean = False, _
                           Optional ByVal CrLf As Boolean = True) As Long
    Dim codepage_ As Long
    codepage_ = getCodePage(codepage)
    If IsArray(data) Then
        m2textFile = array2textfile(data, fileName, codepage_, append, CrLf)
    Else
        m2textFile = array2textfile(Array(data), fileName, codepage_, append, CrLf)
    End If
End Function

' URLŎw肳ꂽeLXg̔zǂݍ
' head_n : ǂݐ擪sw
Public Function getURLText(ByVal url As String, _
                           ByVal line_end As String, _
                           Optional ByVal Charset As String = "_autodetect_all", _
                           Optional ByVal Head_N As Long = -1, _
                           Optional ByVal userName As String = "", _
                           Optional ByVal passWord As String = "") As Variant
    
    Dim http As Object: Set http = CreateObject("MSXML2.XMLHTTP")
    On Error GoTo closeObjects
    With http
        If 0 < Len(userName) And 0 < Len(passWord) Then
            .Open "GET", url, False, userName, passWord
        Else
            .Open "GET", url, False
        End If
        .setRequestHeader "Pragma", "no-cache"
        .setRequestHeader "Cache-Control", "no-cache"
        .Send
    End With
    Dim ado As Object:  Set ado = CreateObject("ADODB.Stream")
    Dim i As Long
    Dim lineS As String
    With ado
        .Open
        .Position = 0
        .Type = 1       'ADODB.Stream.adTypeBinary
        .Write http.responseBody
        .Position = 0
        .Type = 2       'ADODB.Stream.adTypeText
        .Charset = Charset
        If 0 < Head_N Then
            .LineSeparator = IIf(line_end = vbCr, Asc(vbCr), IIf(line_end = vbLf, Asc(vbLf), -1))
            For i = 1 To Head_N
                lineS = .ReadText(-2)   'adReadLine
                getURLText = getURLText & lineS & IIf(i = Head_N, "", line_end)
            Next i
        Else
            getURLText = .ReadText
        End If
    End With
closeObjects:
    If Not ado Is Nothing Then ado.Close
    Set ado = Nothing
    Set http = Nothing
    If 0 < Len(line_end) And VarType(getURLText) = vbString Then
        getURLText = Split(getURLText, line_end)
    End If
End Function

' URLGR[hiQlj
Public Function urlEncode(ByVal s As String) As String
    Dim ado As Object
    Dim tmp As Variant
    tmp = mapF(p_mid(s), zip(iota(1, Len(s)), repeat(1, Len(s))))
    Set ado = CreateObject("ADODB.Stream")
    ado.Charset = "UTF-8"
    tmp = mapF(p_urlEncode_1(, ado), tmp)
    Set ado = Nothing
    urlEncode = Join(tmp, "")
End Function

' URLfR[hiQlj
Public Function urlDecode(ByVal s As String) As String
    If s Like "*%??%??%??*" Then
        Dim begin As Long, theNext As Long
        begin = 1
        Dim ado As Object
        Set ado = CreateObject("ADODB.Stream")
        Do While begin <= Len(s) And Mid(s, begin) Like "*%??%??%??*"
            If Mid(s, begin, 9) Like "*%??%??%??*" Then
                urlDecode = urlDecode & urlDecode_imple(Mid(s, begin, 9), ado)
                begin = begin + 9
            Else
                theNext = InStr(begin + 1, s, "%")
                If 0 < theNext Then
                    urlDecode = urlDecode & Mid(s, begin, theNext - begin)
                    begin = theNext
                Else
                    urlDecode = urlDecode & Mid(s, begin)
                    begin = Len(s) + 1
                End If
            End If
        Loop
        Set ado = Nothing
        If begin < Len(s) Then
            urlDecode = urlDecode & Mid(s, begin)
        End If
    Else
        urlDecode = s
    End If
End Function

    Private Function isKanaKanji(ByVal s As String) As Boolean
        isKanaKanji = False
        If 0 < Len(s) Then
            If Left(s, 1) Like "[-]" Then
                isKanaKanji = True
            ElseIf Asc(Left(s, 1)) < 0 Then
                isKanaKanji = True
            End If
        End If
    End Function

    ' http://stabucky.com/wp/archives/4237
    Private Function urlEncode_1(ByRef s As Variant, ByRef adodbStream As Variant) As Variant
        Dim chars() As Byte
        If isKanaKanji(s) Then
            With adodbStream
                .Open
                .Type = 2       'ADODB.Stream.adTypeText
                .Position = 0
                .WriteText Left(s, 1)
                .Position = 0
                .Type = 1       'ADODB.Stream.adTypeBinary
                .Position = 3
                chars = .Read
                .Close
                urlEncode_1 = "%" & Hex(chars(0)) & "%" & Hex(chars(1)) & "%" & Hex(chars(2))
            End With
        Else
            urlEncode_1 = s
        End If
    End Function
    Private Function p_urlEncode_1(Optional ByRef firstParam As Variant, Optional ByRef secondParam As Variant) As Variant
        p_urlEncode_1 = make_funPointer(AddressOf urlEncode_1, firstParam, secondParam)
    End Function


    Private Function urlDecode_imple(ByVal code As String, ByRef adodbStream As Object) As String
        Dim chars(0 To 2) As Byte
        chars(0) = CLng("&H" & Mid(code, 2, 2))
        chars(1) = CLng("&H" & Mid(code, 5, 2))
        chars(2) = CLng("&H" & Mid(code, 8, 2))
        With adodbStream
            .Open
            .Type = 1       'ADODB.Stream.adTypeBinary
            .Position = 0
            .Write chars
            .Position = 0
            .Type = 2       'ADODB.Stream.adTypeText
            .Charset = "UTF-8"
            urlDecode_imple = .ReadText
            .Close
        End With
    End Function

' zi2ȉjNbv{[hɓ]
Public Sub m2Clip(ByRef data As Variant)
    Dim s As String
    Select Case Dimension(data)
    Case 0
        s = CStr_(data) & vbCrLf
    Case 1
        s = Join(mapF(p_CStr, data), vbTab) & vbCrLf
    Case 2
        Dim tmp As Variant
        tmp = zipC(mapF(p_CStr, data))
        tmp = mapF(p_join(, vbTab), tmp)
        s = Join(tmp, vbCrLf) & vbCrLf
    End Select
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        .text = s
        .SelStart = 0
        .SelLength = .TextLength
        .Copy
    End With
End Sub

' HTMLeLXgHTMLDocumentIuWFNg
Public Function HTMLDocFromText(ByVal htmlText As String) As Object    'As HtmlDocument
    Set HTMLDocFromText = CreateObject("htmlfile") 'New MSHTML.HTMLDocument
    HTMLDocFromText.Write htmlText
End Function

' HTMLeLXg̃^Oo
' vpeB͈propŎw
' innerText, outerText, innerHTML, outerHTML, href ͕Ŏw
' ȊO p_getTitleFromHTMLAnchor Q
Public Function getTagsFromHTML(ByVal htmlText As String, _
                                ByVal tag As Variant, _
                                ByVal prop As Variant) As Variant
    Dim doc As Object   'As HTMLDocument
    Set doc = HTMLDocFromText(htmlText)
    Dim vec As vh_stdvec:   Set vec = New vh_stdvec
    Dim z As Variant
    If is_bindFun(prop) Then
        For Each z In doc.all.tags(tag)
            vec.push_back z
        Next z
        getTagsFromHTML = mapF(prop, vec.free)
    ElseIf TypeName(prop) = "String" Then
        Select Case StrConv(prop, vbLowerCase)
        Case "it"
            For Each z In doc.all.tags(tag)
                vec.push_back z.innerText
            Next z
        Case "ot"
            For Each z In doc.all.tags(tag)
                vec.push_back z.outerText
            Next z
        Case "ih"
            For Each z In doc.all.tags(tag)
                vec.push_back z.innerHTML
            Next z
        Case "oh"
            For Each z In doc.all.tags(tag)
                vec.push_back z.outerHTML
            Next z
        Case "href"
            For Each z In doc.all.tags(tag)
                vec.push_back z.href
            Next z
        End Select
        getTagsFromHTML = vec.free
    End If
    Set doc = Nothing
End Function

'HTMLAnchorElement 'Title'vpeB擾
    Private Function getTitleFromHTMLAnchor(ByRef anchor As Variant, _
                                            ByRef dummy As Variant) As Variant
        If TypeName(anchor) = "HTMLAnchorElement" Then
            getTitleFromHTMLAnchor = anchor.Title
        End If
    End Function
Public Function p_getTitleFromHTMLAnchor(Optional ByRef firstParam As Variant, Optional ByRef secondParam As Variant) As Variant
    p_getTitleFromHTMLAnchor = make_funPointer(AddressOf getTitleFromHTMLAnchor, firstParam, secondParam)
End Function
    
' Word̃e[uz擾
Public Function wTable2m(ByVal t As Object, Optional ByVal cutHeader As Boolean = False) As Variant
    If StrConv(Application.Name, vbLowerCase) Like "*word*" And TypeName(t) = "Table" Then
        Dim ret As Variant, tmp As String
        With t
            ret = makeM(.rows.count, .Columns.count)
            Dim i As Long, j As Long
            For i = 1 To .rows.count Step 1
                For j = 1 To .Columns.count Step 1
                    tmp = .Cell(i, j).Range.text
                    ret(i - 1, j - 1) = Left(tmp, Len(tmp) - 2)
                Next j
            Next i
        End With
    End If
    If cutHeader Then
        wTable2m = subM(ret, iota(1, UBound(ret, 1)))
    Else
        Call swapVariant(wTable2m, ret)
    End If
End Function

' URLŎw肵t@C̃_E[h
' fileNamesȗ̓N̒ʂiŌ'/'̌땔j
' ߂l̓_E[hłt@C̐
Public Function downloadFiles(ByRef URLs As Variant, _
                              ByVal pathName As String, _
                              Optional ByRef fileNames As Variant, _
                              Optional ByVal userName As String = "", _
                              Optional ByVal passWord As String = "") As Long
    downloadFiles = 0
    Dim fso As Object:      Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.folderExists(pathName) Then
        Set fso = Nothing
        Exit Function
    End If
    Dim URLm As Variant:    URLm = vector(URLs)
    Dim fNames As Variant
    If IsMissing(fileNames) Or IsEmpty(fileNames) Or IsNull(fileNames) Then
        fNames = mapF(p_getNth_b(, -1), mapF(p_split(, "/"), URLm))
    Else
        fNames = vector(fileNames)
    End If
    Dim i As Long
    For i = 0 To min_fun(UBound(URLm), UBound(fNames)) Step 1
        If downloadFile_(URLm(i), fso.BuildPath(pathName, fNames(i)), userName, passWord) Then
            downloadFiles = downloadFiles + 1
        End If
    Next i
    Set fso = Nothing
End Function

    Private Function downloadFile_(ByVal url As String, _
                                   ByVal fileName As String, _
                                   ByVal userName As String, _
                                   ByVal passWord As String) As Boolean
        downloadFile_ = False
        Dim oo As Object:   Set oo = CreateObject("MSXML2.XMLHTTP")
        If oo Is Nothing Then Exit Function
        On Error GoTo closeFun
        With oo
            If 0 < Len(userName) And 0 < Len(passWord) Then
                .Open "GET", url, False, userName, passWord
            Else
                .Open "GET", url, False
            End If
            .setRequestHeader "Pragma", "no-cache"
            .setRequestHeader "Cache-Control", "no-cache"
            .Send
        End With
        Select Case oo.Status       ' HTTP Result Code
        Case Is <= 200          ' NGXg
            With CreateObject("ADODB.Stream")
                .Type = 1 ' ADODB.Stream.adTypeBinary
                .Open
                .Write oo.responseBody
                .SaveToFile fileName, 2 ' adSaveCreateOverWrite
                .Close
            End With
            downloadFile_ = True
        End Select
closeFun:
    End Function

' t@CBase64GR[hibinary -> textj
Function encodeBase64(ByVal fromFile As String, ByVal toFile As String) As Boolean
    With CreateObject("Scripting.FileSystemObject")
        If Not .FileExists(fromFile) Then Exit Function
        If Not .folderExists(.GetParentFolderName(toFile)) Then Exit Function
    End With
    Dim elm As Object
    On Error Resume Next
    Set elm = CreateObject("MSXML2.DOMDocument").CreateElement("base64")
    With CreateObject("ADODB.Stream")
        .Type = 1   'adTypeBinary
{'fraction_non_alphanumeric': 0.0893475037073653, 'fraction_numerical': 0.011319822046465646, 'mean_word_length': 1.708414217819131, 'pattern_counts': {'":': 18, '<': 29, '<?xml version=': 0, '>': 9, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 42, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '5346213', 'n_tokens_mistral': 12803, 'n_tokens_neox': 12275, 'n_words': 3567}