diff --git a/XVBA/MSS/■MSSツール/.vscode/settings.json b/XVBA/MSS/■MSSツール/.vscode/settings.json new file mode 100644 index 00000000..49431ab8 --- /dev/null +++ b/XVBA/MSS/■MSSツール/.vscode/settings.json @@ -0,0 +1,3 @@ +{ + "files.encoding": "shiftjis" +} \ No newline at end of file diff --git a/XVBA/MSS/■MSSツール/MSSツール.xlsm b/XVBA/MSS/■MSSツール/MSSツール.xlsm new file mode 100644 index 00000000..954524ba Binary files /dev/null and b/XVBA/MSS/■MSSツール/MSSツール.xlsm differ diff --git a/XVBA/MSS/■MSSツール/config.json b/XVBA/MSS/■MSSツール/config.json new file mode 100644 index 00000000..0effdd77 --- /dev/null +++ b/XVBA/MSS/■MSSツール/config.json @@ -0,0 +1,14 @@ +{ + "app_name": "XVBA", + "description": "", + "author": "", + "email": "", + "create_ate": "Thu May 29 2025 13:41:00 GMT+0900 (日本標準時)", + "excel_file": "MSSツール.xlsm", + "vba_folder": "vba-files", + "ribbon_file": "customUI14", + "ribbon_folder": "ribbons", + "logs": "on", + "xvba_packages": {}, + "xvba_dev_packages": {} +} \ No newline at end of file diff --git a/XVBA/MSS/■MSSツール/package.json b/XVBA/MSS/■MSSツール/package.json new file mode 100644 index 00000000..a8deae27 --- /dev/null +++ b/XVBA/MSS/■MSSツール/package.json @@ -0,0 +1,15 @@ +{ + "name": "xvba-app", + "version": "1.0.0", + "description": "A XVBA App", + "main": "index.js", + "author": "LocalSmart", + "license": "ISC", + "dependencies": { + "excel-types": "1.0.0", + "Xlog": "1.0.0" + }, + "devDependencies": { + "@localsmart/xvba-cli": "^1.0.2" + } +} \ No newline at end of file diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet1.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet1.cls new file mode 100644 index 00000000..7e5eed8e --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet1.cls @@ -0,0 +1,9 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet1" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet10.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet10.cls new file mode 100644 index 00000000..26de6af1 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet10.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet10" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet11.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet11.cls new file mode 100644 index 00000000..9a6dee97 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet11.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet11" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet12.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet12.cls new file mode 100644 index 00000000..65530ac4 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet12.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet12" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet13.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet13.cls new file mode 100644 index 00000000..90e7028a --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet13.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet13" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet14.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet14.cls new file mode 100644 index 00000000..4324809d --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet14.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet14" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet15.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet15.cls new file mode 100644 index 00000000..3470200e --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet15.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet15" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet16.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet16.cls new file mode 100644 index 00000000..f463f889 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet16.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet16" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet17.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet17.cls new file mode 100644 index 00000000..b55e1e56 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet17.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet17" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet18.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet18.cls new file mode 100644 index 00000000..03b35007 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet18.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet18" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet19.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet19.cls new file mode 100644 index 00000000..3e6aaac9 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet19.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet19" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet2.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet2.cls new file mode 100644 index 00000000..bae245ef --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet2.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet2" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet3.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet3.cls new file mode 100644 index 00000000..b0b36e83 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet3.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet3" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet4.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet4.cls new file mode 100644 index 00000000..c9ba7ab7 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet4.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet4" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet5.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet5.cls new file mode 100644 index 00000000..256756ea --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet5.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet5" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet6.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet6.cls new file mode 100644 index 00000000..eb370ff4 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet6.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet6" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet7.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet7.cls new file mode 100644 index 00000000..9d6db4a0 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet7.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet7" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet8.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet8.cls new file mode 100644 index 00000000..39390f11 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet8.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet8" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/Sheet9.cls b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet9.cls new file mode 100644 index 00000000..c37cda0d --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/Sheet9.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet9" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/MSS/■MSSツール/vba-files/Class/ThisWorkbook.cls b/XVBA/MSS/■MSSツール/vba-files/Class/ThisWorkbook.cls new file mode 100644 index 00000000..71a35984 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Class/ThisWorkbook.cls @@ -0,0 +1,9 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ThisWorkbook" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True diff --git a/XVBA/MSS/■MSSツール/vba-files/Module/JsonConverter.bas b/XVBA/MSS/■MSSツール/vba-files/Module/JsonConverter.bas new file mode 100644 index 00000000..3aec36d2 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Module/JsonConverter.bas @@ -0,0 +1,1123 @@ +Attribute VB_Name = "JsonConverter" +'' +' VBA-JSON v2.3.1 +' (c) Tim Hall - https://github.com/VBA-tools/VBA-JSON +' +' JSON Converter for VBA +' +' Errors: +' 10001 - JSON parse error +' +' @class JsonConverter +' @author tim.hall.engr@gmail.com +' @license MIT (http://www.opensource.org/licenses/mit-license.php) +'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' +' +' Based originally on vba-json (with extensive changes) +' BSD license included below +' +' JSONLib, http://code.google.com/p/vba-json/ +' +' Copyright (c) 2013, Ryo Yokoyama +' All rights reserved. +' +' Redistribution and use in source and binary forms, with or without +' modification, are permitted provided that the following conditions are met: +' * Redistributions of source code must retain the above copyright +' notice, this list of conditions and the following disclaimer. +' * Redistributions in binary form must reproduce the above copyright +' notice, this list of conditions and the following disclaimer in the +' documentation and/or other materials provided with the distribution. +' * Neither the name of the nor the +' names of its contributors may be used to endorse or promote products +' derived from this software without specific prior written permission. +' +' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +' ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +' DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +' DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +' (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +' LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +' ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +' SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' +Option Explicit + +' === VBA-UTC Headers +#If Mac Then + +#If VBA7 Then + +' 64-bit Mac (2016) +Private Declare PtrSafe Function utc_popen Lib "/usr/lib/libc.dylib" Alias "popen" _ + (ByVal utc_Command As String, ByVal utc_Mode As String) As LongPtr +Private Declare PtrSafe Function utc_pclose Lib "/usr/lib/libc.dylib" Alias "pclose" _ + (ByVal utc_File As LongPtr) As LongPtr +Private Declare PtrSafe Function utc_fread Lib "/usr/lib/libc.dylib" Alias "fread" _ + (ByVal utc_Buffer As String, ByVal utc_Size As LongPtr, ByVal utc_Number As LongPtr, ByVal utc_File As LongPtr) As LongPtr +Private Declare PtrSafe Function utc_feof Lib "/usr/lib/libc.dylib" Alias "feof" _ + (ByVal utc_File As LongPtr) As LongPtr + +#Else + +' 32-bit Mac +Private Declare Function utc_popen Lib "libc.dylib" Alias "popen" _ + (ByVal utc_Command As String, ByVal utc_Mode As String) As Long +Private Declare Function utc_pclose Lib "libc.dylib" Alias "pclose" _ + (ByVal utc_File As Long) As Long +Private Declare Function utc_fread Lib "libc.dylib" Alias "fread" _ + (ByVal utc_Buffer As String, ByVal utc_Size As Long, ByVal utc_Number As Long, ByVal utc_File As Long) As Long +Private Declare Function utc_feof Lib "libc.dylib" Alias "feof" _ + (ByVal utc_File As Long) As Long + +#End If + +#ElseIf VBA7 Then + +' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724421.aspx +' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724949.aspx +' http://msdn.microsoft.com/en-us/library/windows/desktop/ms725485.aspx +Private Declare PtrSafe Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long +Private Declare PtrSafe Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long +Private Declare PtrSafe Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long + +#Else + +Private Declare Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long +Private Declare Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long +Private Declare Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long + +#End If + +#If Mac Then + +#If VBA7 Then +Private Type utc_ShellResult + utc_Output As String + utc_ExitCode As LongPtr +End Type + +#Else + +Private Type utc_ShellResult + utc_Output As String + utc_ExitCode As Long +End Type + +#End If + +#Else + +Private Type utc_SYSTEMTIME + utc_wYear As Integer + utc_wMonth As Integer + utc_wDayOfWeek As Integer + utc_wDay As Integer + utc_wHour As Integer + utc_wMinute As Integer + utc_wSecond As Integer + utc_wMilliseconds As Integer +End Type + +Private Type utc_TIME_ZONE_INFORMATION + utc_Bias As Long + utc_StandardName(0 To 31) As Integer + utc_StandardDate As utc_SYSTEMTIME + utc_StandardBias As Long + utc_DaylightName(0 To 31) As Integer + utc_DaylightDate As utc_SYSTEMTIME + utc_DaylightBias As Long +End Type + +#End If +' === End VBA-UTC + +Private Type json_Options + ' VBA only stores 15 significant digits, so any numbers larger than that are truncated + ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits + ' See: http://support.microsoft.com/kb/269370 + ' + ' By default, VBA-JSON will use String for numbers longer than 15 characters that contain only digits + ' to override set `JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True` + UseDoubleForLargeNumbers As Boolean + + ' The JSON standard requires object keys to be quoted (" or '), use this option to allow unquoted keys + AllowUnquotedKeys As Boolean + + ' The solidus (/) is not required to be escaped, use this option to escape them as \/ in ConvertToJson + EscapeSolidus As Boolean +End Type +Public JsonOptions As json_Options + +' ============================================= ' +' Public Methods +' ============================================= ' + +'' +' Convert JSON string to object (Dictionary/Collection) +' +' @method ParseJson +' @param {String} json_String +' @return {Object} (Dictionary or Collection) +' @throws 10001 - JSON parse error +'' +Public Function ParseJson(ByVal JsonString As String) As Object + Dim json_Index As Long + json_Index = 1 + + ' Remove vbCr, vbLf, and vbTab from json_String + JsonString = VBA.Replace(VBA.Replace(VBA.Replace(JsonString, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "") + + json_SkipSpaces JsonString, json_Index + Select Case VBA.Mid$(JsonString, json_Index, 1) + Case "{" + Set ParseJson = json_ParseObject(JsonString, json_Index) + Case "[" + Set ParseJson = json_ParseArray(JsonString, json_Index) + Case Else + ' Error: Invalid JSON string + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(JsonString, json_Index, "Expecting '{' or '['") + End Select +End Function + +'' +' Convert object (Dictionary/Collection/Array) to JSON +' +' @method ConvertToJson +' @param {Variant} JsonValue (Dictionary, Collection, or Array) +' @param {Integer|String} Whitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string +' @return {String} +'' +Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String + Dim json_Buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long + Dim json_Index As Long + Dim json_LBound As Long + Dim json_UBound As Long + Dim json_IsFirstItem As Boolean + Dim json_Index2D As Long + Dim json_LBound2D As Long + Dim json_UBound2D As Long + Dim json_IsFirstItem2D As Boolean + Dim json_Key As Variant + Dim json_Value As Variant + Dim json_DateStr As String + Dim json_Converted As String + Dim json_SkipItem As Boolean + Dim json_PrettyPrint As Boolean + Dim json_Indentation As String + Dim json_InnerIndentation As String + + json_LBound = -1 + json_UBound = -1 + json_IsFirstItem = True + json_LBound2D = -1 + json_UBound2D = -1 + json_IsFirstItem2D = True + json_PrettyPrint = Not IsMissing(Whitespace) + + Select Case VBA.VarType(JsonValue) + Case VBA.vbNull + ConvertToJson = "null" + Case VBA.vbDate + ' Date + json_DateStr = ConvertToIso(VBA.CDate(JsonValue)) + + ConvertToJson = """" & json_DateStr & """" + Case VBA.vbString + ' String (or large number encoded as string) + If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(JsonValue) Then + ConvertToJson = JsonValue + Else + ConvertToJson = """" & json_Encode(JsonValue) & """" + End If + Case VBA.vbBoolean + If JsonValue Then + ConvertToJson = "true" + Else + ConvertToJson = "false" + End If + Case VBA.vbArray To VBA.vbArray + VBA.vbByte + If json_PrettyPrint Then + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) + json_InnerIndentation = VBA.String$(json_CurrentIndentation + 2, Whitespace) + Else + json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) + json_InnerIndentation = VBA.Space$((json_CurrentIndentation + 2) * Whitespace) + End If + End If + + ' Array + json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength + + On Error Resume Next + + json_LBound = LBound(JsonValue, 1) + json_UBound = UBound(JsonValue, 1) + json_LBound2D = LBound(JsonValue, 2) + json_UBound2D = UBound(JsonValue, 2) + + If json_LBound >= 0 And json_UBound >= 0 Then + For json_Index = json_LBound To json_UBound + If json_IsFirstItem Then + json_IsFirstItem = False + Else + ' Append comma to previous line + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength + End If + + If json_LBound2D >= 0 And json_UBound2D >= 0 Then + ' 2D Array + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + End If + json_BufferAppend json_Buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength + + For json_Index2D = json_LBound2D To json_UBound2D + If json_IsFirstItem2D Then + json_IsFirstItem2D = False + Else + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength + End If + + json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2) + + ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If json_Converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(JsonValue(json_Index, json_Index2D)) Then + json_Converted = "null" + End If + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_InnerIndentation & json_Converted + End If + + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength + Next json_Index2D + + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + End If + + json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + json_IsFirstItem2D = True + Else + ' 1D Array + json_Converted = ConvertToJson(JsonValue(json_Index), Whitespace, json_CurrentIndentation + 1) + + ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If json_Converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(JsonValue(json_Index)) Then + json_Converted = "null" + End If + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_Indentation & json_Converted + End If + + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength + End If + Next json_Index + End If + + On Error GoTo 0 + + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) + Else + json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) + End If + End If + + json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + + ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) + + ' Dictionary or Collection + Case VBA.vbObject + If json_PrettyPrint Then + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) + Else + json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) + End If + End If + + ' Dictionary + If VBA.TypeName(JsonValue) = "Dictionary" Then + json_BufferAppend json_Buffer, "{", json_BufferPosition, json_BufferLength + For Each json_Key In JsonValue.keys + ' For Objects, undefined (Empty/Nothing) is not added to object + json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1) + If json_Converted = "" Then + json_SkipItem = json_IsUndefined(JsonValue(json_Key)) + Else + json_SkipItem = False + End If + + If Not json_SkipItem Then + If json_IsFirstItem Then + json_IsFirstItem = False + Else + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_Indentation & """" & json_Key & """: " & json_Converted + Else + json_Converted = """" & json_Key & """:" & json_Converted + End If + + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength + End If + Next json_Key + + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) + Else + json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) + End If + End If + + json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength + + ' Collection + ElseIf VBA.TypeName(JsonValue) = "Collection" Then + json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength + For Each json_Value In JsonValue + If json_IsFirstItem Then + json_IsFirstItem = False + Else + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength + End If + + json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1) + + ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If json_Converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(json_Value) Then + json_Converted = "null" + End If + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_Indentation & json_Converted + End If + + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength + Next json_Value + + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) + Else + json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) + End If + End If + + json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + End If + + ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) + Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal + ' Number (use decimals for numbers) + ConvertToJson = VBA.Replace(JsonValue, ",", ".") + Case Else + ' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType + ' Use VBA's built-in to-string + On Error Resume Next + ConvertToJson = JsonValue + On Error GoTo 0 + End Select +End Function + +' ============================================= ' +' Private Functions +' ============================================= ' + +Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary + Dim json_Key As String + Dim json_NextChar As String + + Set json_ParseObject = New Dictionary + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) <> "{" Then + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{'") + Else + json_Index = json_Index + 1 + + Do + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) = "}" Then + json_Index = json_Index + 1 + Exit Function + ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then + json_Index = json_Index + 1 + json_SkipSpaces json_String, json_Index + End If + + json_Key = json_ParseKey(json_String, json_Index) + json_NextChar = json_Peek(json_String, json_Index) + If json_NextChar = "[" Or json_NextChar = "{" Then + Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) + Else + json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) + End If + Loop + End If +End Function + +Private Function json_ParseArray(json_String As String, ByRef json_Index As Long) As Collection + Set json_ParseArray = New Collection + + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) <> "[" Then + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '['") + Else + json_Index = json_Index + 1 + + Do + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) = "]" Then + json_Index = json_Index + 1 + Exit Function + ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then + json_Index = json_Index + 1 + json_SkipSpaces json_String, json_Index + End If + + json_ParseArray.Add json_ParseValue(json_String, json_Index) + Loop + End If +End Function + +Private Function json_ParseValue(json_String As String, ByRef json_Index As Long) As Variant + json_SkipSpaces json_String, json_Index + Select Case VBA.Mid$(json_String, json_Index, 1) + Case "{" + Set json_ParseValue = json_ParseObject(json_String, json_Index) + Case "[" + Set json_ParseValue = json_ParseArray(json_String, json_Index) + Case """", "'" + json_ParseValue = json_ParseString(json_String, json_Index) + Case Else + If VBA.Mid$(json_String, json_Index, 4) = "true" Then + json_ParseValue = True + json_Index = json_Index + 4 + ElseIf VBA.Mid$(json_String, json_Index, 5) = "false" Then + json_ParseValue = False + json_Index = json_Index + 5 + ElseIf VBA.Mid$(json_String, json_Index, 4) = "null" Then + json_ParseValue = Null + json_Index = json_Index + 4 + ElseIf VBA.InStr("+-0123456789", VBA.Mid$(json_String, json_Index, 1)) Then + json_ParseValue = json_ParseNumber(json_String, json_Index) + Else + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['") + End If + End Select +End Function + +Private Function json_ParseString(json_String As String, ByRef json_Index As Long) As String + Dim json_Quote As String + Dim json_Char As String + Dim json_Code As String + Dim json_Buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long + + json_SkipSpaces json_String, json_Index + + ' Store opening quote to look for matching closing quote + json_Quote = VBA.Mid$(json_String, json_Index, 1) + json_Index = json_Index + 1 + + Do While json_Index > 0 And json_Index <= Len(json_String) + json_Char = VBA.Mid$(json_String, json_Index, 1) + + Select Case json_Char + Case "\" + ' Escaped string, \\, or \/ + json_Index = json_Index + 1 + json_Char = VBA.Mid$(json_String, json_Index, 1) + + Select Case json_Char + Case """", "\", "/", "'" + json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "b" + json_BufferAppend json_Buffer, vbBack, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "f" + json_BufferAppend json_Buffer, vbFormFeed, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "n" + json_BufferAppend json_Buffer, vbCrLf, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "r" + json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "t" + json_BufferAppend json_Buffer, vbTab, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "u" + ' Unicode character escape (e.g. \u00a9 = Copyright) + json_Index = json_Index + 1 + json_Code = VBA.Mid$(json_String, json_Index, 4) + json_BufferAppend json_Buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength + json_Index = json_Index + 4 + End Select + Case json_Quote + json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition) + json_Index = json_Index + 1 + Exit Function + Case Else + json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + End Select + Loop +End Function + +Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long) As Variant + Dim json_Char As String + Dim json_Value As String + Dim json_IsLargeNumber As Boolean + + json_SkipSpaces json_String, json_Index + + Do While json_Index > 0 And json_Index <= Len(json_String) + json_Char = VBA.Mid$(json_String, json_Index, 1) + + If VBA.InStr("+-0123456789.eE", json_Char) Then + ' Unlikely to have massive number, so use simple append rather than buffer here + json_Value = json_Value & json_Char + json_Index = json_Index + 1 + Else + ' Excel only stores 15 significant digits, so any numbers larger than that are truncated + ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits + ' See: http://support.microsoft.com/kb/269370 + ' + ' Fix: Parse -> String, Convert -> String longer than 15/16 characters containing only numbers and decimal points -> Number + ' (decimal doesn't factor into significant digit count, so if present check for 15 digits + decimal = 16) + json_IsLargeNumber = IIf(InStr(json_Value, "."), Len(json_Value) >= 17, Len(json_Value) >= 16) + If Not JsonOptions.UseDoubleForLargeNumbers And json_IsLargeNumber Then + json_ParseNumber = json_Value + Else + ' VBA.Val does not use regional settings, so guard for comma is not needed + json_ParseNumber = VBA.Val(json_Value) + End If + Exit Function + End If + Loop +End Function + +Private Function json_ParseKey(json_String As String, ByRef json_Index As Long) As String + ' Parse key with single or double quotes + If VBA.Mid$(json_String, json_Index, 1) = """" Or VBA.Mid$(json_String, json_Index, 1) = "'" Then + json_ParseKey = json_ParseString(json_String, json_Index) + ElseIf JsonOptions.AllowUnquotedKeys Then + Dim json_Char As String + Do While json_Index > 0 And json_Index <= Len(json_String) + json_Char = VBA.Mid$(json_String, json_Index, 1) + If (json_Char <> " ") And (json_Char <> ":") Then + json_ParseKey = json_ParseKey & json_Char + json_Index = json_Index + 1 + Else + Exit Do + End If + Loop + Else + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '""' or '''") + End If + + ' Check for colon and skip if present or throw if not present + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) <> ":" Then + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting ':'") + Else + json_Index = json_Index + 1 + End If +End Function + +Private Function json_IsUndefined(ByVal json_Value As Variant) As Boolean + ' Empty / Nothing -> undefined + Select Case VBA.VarType(json_Value) + Case VBA.vbEmpty + json_IsUndefined = True + Case VBA.vbObject + Select Case VBA.TypeName(json_Value) + Case "Empty", "Nothing" + json_IsUndefined = True + End Select + End Select +End Function + +Private Function json_Encode(ByVal json_Text As Variant) As String + ' Reference: http://www.ietf.org/rfc/rfc4627.txt + ' Escape: ", \, /, backspace, form feed, line feed, carriage return, tab + Dim json_Index As Long + Dim json_Char As String + Dim json_AscCode As Long + Dim json_Buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long + + For json_Index = 1 To VBA.Len(json_Text) + json_Char = VBA.Mid$(json_Text, json_Index, 1) + json_AscCode = VBA.AscW(json_Char) + + ' When AscW returns a negative number, it returns the twos complement form of that number. + ' To convert the twos complement notation into normal binary notation, add 0xFFF to the return result. + ' https://support.microsoft.com/en-us/kb/272138 + If json_AscCode < 0 Then + json_AscCode = json_AscCode + 65536 + End If + + ' From spec, ", \, and control characters must be escaped (solidus is optional) + + Select Case json_AscCode + Case 34 + ' " -> 34 -> \" + json_Char = "\""" + Case 92 + ' \ -> 92 -> \\ + json_Char = "\\" + Case 47 + ' / -> 47 -> \/ (optional) + If JsonOptions.EscapeSolidus Then + json_Char = "\/" + End If + Case 8 + ' backspace -> 8 -> \b + json_Char = "\b" + Case 12 + ' form feed -> 12 -> \f + json_Char = "\f" + Case 10 + ' line feed -> 10 -> \n + json_Char = "\n" + Case 13 + ' carriage return -> 13 -> \r + json_Char = "\r" + Case 9 + ' tab -> 9 -> \t + json_Char = "\t" + Case 0 To 31, 127 To 65535 + ' Non-ascii characters -> convert to 4-digit hex + json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4) + End Select + + json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength + Next json_Index + + json_Encode = json_BufferToString(json_Buffer, json_BufferPosition) +End Function + +Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String + ' "Peek" at the next number of characters without incrementing json_Index (ByVal instead of ByRef) + json_SkipSpaces json_String, json_Index + json_Peek = VBA.Mid$(json_String, json_Index, json_NumberOfCharacters) +End Function + +Private Sub json_SkipSpaces(json_String As String, ByRef json_Index As Long) + ' Increment index to skip over spaces + Do While json_Index > 0 And json_Index <= VBA.Len(json_String) And VBA.Mid$(json_String, json_Index, 1) = " " + json_Index = json_Index + 1 + Loop +End Sub + +Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean + ' Check if the given string is considered a "large number" + ' (See json_ParseNumber) + + Dim json_Length As Long + Dim json_CharIndex As Long + json_Length = VBA.Len(json_String) + + ' Length with be at least 16 characters and assume will be less than 100 characters + If json_Length >= 16 And json_Length <= 100 Then + Dim json_CharCode As String + + json_StringIsLargeNumber = True + + For json_CharIndex = 1 To json_Length + json_CharCode = VBA.Asc(VBA.Mid$(json_String, json_CharIndex, 1)) + Select Case json_CharCode + ' Look for .|0-9|E|e + Case 46, 48 To 57, 69, 101 + ' Continue through characters + Case Else + json_StringIsLargeNumber = False + Exit Function + End Select + Next json_CharIndex + End If +End Function + +Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index As Long, ErrorMessage As String) + ' Provide detailed parse error message, including details of where and what occurred + ' + ' Example: + ' Error parsing JSON: + ' {"abcde":True} + ' ^ + ' Expecting 'STRING', 'NUMBER', null, true, false, '{', or '[' + + Dim json_StartIndex As Long + Dim json_StopIndex As Long + + ' Include 10 characters before and after error (if possible) + json_StartIndex = json_Index - 10 + json_StopIndex = json_Index + 10 + If json_StartIndex <= 0 Then + json_StartIndex = 1 + End If + If json_StopIndex > VBA.Len(json_String) Then + json_StopIndex = VBA.Len(json_String) + End If + + json_ParseErrorMessage = "Error parsing JSON:" & VBA.vbNewLine & _ + VBA.Mid$(json_String, json_StartIndex, json_StopIndex - json_StartIndex + 1) & VBA.vbNewLine & _ + VBA.Space$(json_Index - json_StartIndex) & "^" & VBA.vbNewLine & _ + ErrorMessage +End Function + +Private Sub json_BufferAppend(ByRef json_Buffer As String, _ + ByRef json_Append As Variant, _ + ByRef json_BufferPosition As Long, _ + ByRef json_BufferLength As Long) + ' VBA can be slow to append strings due to allocating a new string for each append + ' Instead of using the traditional append, allocate a large empty string and then copy string at append position + ' + ' Example: + ' Buffer: "abc " + ' Append: "def" + ' Buffer Position: 3 + ' Buffer Length: 5 + ' + ' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer + ' Buffer: "abc " + ' Buffer Length: 10 + ' + ' Put "def" into buffer at position 3 (0-based) + ' Buffer: "abcdef " + ' + ' Approach based on cStringBuilder from vbAccelerator + ' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp + ' + ' and clsStringAppend from Philip Swannell + ' https://github.com/VBA-tools/VBA-JSON/pull/82 + + Dim json_AppendLength As Long + Dim json_LengthPlusPosition As Long + + json_AppendLength = VBA.Len(json_Append) + json_LengthPlusPosition = json_AppendLength + json_BufferPosition + + If json_LengthPlusPosition > json_BufferLength Then + ' Appending would overflow buffer, add chunk + ' (double buffer length or append length, whichever is bigger) + Dim json_AddedLength As Long + json_AddedLength = IIf(json_AppendLength > json_BufferLength, json_AppendLength, json_BufferLength) + + json_Buffer = json_Buffer & VBA.Space$(json_AddedLength) + json_BufferLength = json_BufferLength + json_AddedLength + End If + + ' Note: Namespacing with VBA.Mid$ doesn't work properly here, throwing compile error: + ' Function call on left-hand side of assignment must return Variant or Object + Mid$(json_Buffer, json_BufferPosition + 1, json_AppendLength) = CStr(json_Append) + json_BufferPosition = json_BufferPosition + json_AppendLength +End Sub + +Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long) As String + If json_BufferPosition > 0 Then + json_BufferToString = VBA.Left$(json_Buffer, json_BufferPosition) + End If +End Function + +'' +' VBA-UTC v1.0.6 +' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter +' +' UTC/ISO 8601 Converter for VBA +' +' Errors: +' 10011 - UTC parsing error +' 10012 - UTC conversion error +' 10013 - ISO 8601 parsing error +' 10014 - ISO 8601 conversion error +' +' @module UtcConverter +' @author tim.hall.engr@gmail.com +' @license MIT (http://www.opensource.org/licenses/mit-license.php) +'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' + +' (Declarations moved to top) + +' ============================================= ' +' Public Methods +' ============================================= ' + +'' +' Parse UTC date to local date +' +' @method ParseUtc +' @param {Date} UtcDate +' @return {Date} Local date +' @throws 10011 - UTC parsing error +'' +Public Function ParseUtc(utc_UtcDate As Date) As Date + On Error GoTo utc_ErrorHandling + +#If Mac Then + ParseUtc = utc_ConvertDate(utc_UtcDate) +#Else + Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION + Dim utc_LocalDate As utc_SYSTEMTIME + + utc_GetTimeZoneInformation utc_TimeZoneInfo + utc_SystemTimeToTzSpecificLocalTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_UtcDate), utc_LocalDate + + ParseUtc = utc_SystemTimeToDate(utc_LocalDate) +#End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10011, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description +End Function + +'' +' Convert local date to UTC date +' +' @method ConvertToUrc +' @param {Date} utc_LocalDate +' @return {Date} UTC date +' @throws 10012 - UTC conversion error +'' +Public Function ConvertToUtc(utc_LocalDate As Date) As Date + On Error GoTo utc_ErrorHandling + +#If Mac Then + ConvertToUtc = utc_ConvertDate(utc_LocalDate, utc_ConvertToUtc:=True) +#Else + Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION + Dim utc_UtcDate As utc_SYSTEMTIME + + utc_GetTimeZoneInformation utc_TimeZoneInfo + utc_TzSpecificLocalTimeToSystemTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_LocalDate), utc_UtcDate + + ConvertToUtc = utc_SystemTimeToDate(utc_UtcDate) +#End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description +End Function + +'' +' Parse ISO 8601 date string to local date +' +' @method ParseIso +' @param {Date} utc_IsoString +' @return {Date} Local date +' @throws 10013 - ISO 8601 parsing error +'' +Public Function ParseIso(utc_IsoString As String) As Date + On Error GoTo utc_ErrorHandling + + Dim utc_Parts() As String + Dim utc_DateParts() As String + Dim utc_TimeParts() As String + Dim utc_OffsetIndex As Long + Dim utc_HasOffset As Boolean + Dim utc_NegativeOffset As Boolean + Dim utc_OffsetParts() As String + Dim utc_Offset As Date + + utc_Parts = VBA.Split(utc_IsoString, "T") + utc_DateParts = VBA.Split(utc_Parts(0), "-") + ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2))) + + If UBound(utc_Parts) > 0 Then + If VBA.InStr(utc_Parts(1), "Z") Then + utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":") + Else + utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+") + If utc_OffsetIndex = 0 Then + utc_NegativeOffset = True + utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-") + End If + + If utc_OffsetIndex > 0 Then + utc_HasOffset = True + utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":") + utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":") + + Select Case UBound(utc_OffsetParts) + Case 0 + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0) + Case 1 + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0) + Case 2 + ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2)))) + End Select + + If utc_NegativeOffset Then: utc_Offset = -utc_Offset + Else + utc_TimeParts = VBA.Split(utc_Parts(1), ":") + End If + End If + + Select Case UBound(utc_TimeParts) + Case 0 + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0) + Case 1 + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0) + Case 2 + ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2)))) + End Select + + ParseIso = ParseUtc(ParseIso) + + If utc_HasOffset Then + ParseIso = ParseIso - utc_Offset + End If + End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10013, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & utc_IsoString & ": " & Err.Number & " - " & Err.Description +End Function + +'' +' Convert local date to ISO 8601 string +' +' @method ConvertToIso +' @param {Date} utc_LocalDate +' @return {Date} ISO 8601 string +' @throws 10014 - ISO 8601 conversion error +'' +Public Function ConvertToIso(utc_LocalDate As Date) As String + On Error GoTo utc_ErrorHandling + + ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z") + + Exit Function + +utc_ErrorHandling: + Err.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description +End Function + +' ============================================= ' +' Private Functions +' ============================================= ' + +#If Mac Then + +Private Function utc_ConvertDate(utc_Value As Date, Optional utc_ConvertToUtc As Boolean = False) As Date + Dim utc_ShellCommand As String + Dim utc_Result As utc_ShellResult + Dim utc_Parts() As String + Dim utc_DateParts() As String + Dim utc_TimeParts() As String + + If utc_ConvertToUtc Then + utc_ShellCommand = "date -ur `date -jf '%Y-%m-%d %H:%M:%S' " & _ + "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & "' " & _ + " +'%s'` +'%Y-%m-%d %H:%M:%S'" + Else + utc_ShellCommand = "date -jf '%Y-%m-%d %H:%M:%S %z' " & _ + "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & " +0000' " & _ + "+'%Y-%m-%d %H:%M:%S'" + End If + + utc_Result = utc_ExecuteInShell(utc_ShellCommand) + + If utc_Result.utc_Output = "" Then + Err.Raise 10015, "UtcConverter.utc_ConvertDate", "'date' command failed" + Else + utc_Parts = Split(utc_Result.utc_Output, " ") + utc_DateParts = Split(utc_Parts(0), "-") + utc_TimeParts = Split(utc_Parts(1), ":") + + utc_ConvertDate = DateSerial(utc_DateParts(0), utc_DateParts(1), utc_DateParts(2)) + _ + TimeSerial(utc_TimeParts(0), utc_TimeParts(1), utc_TimeParts(2)) + End If +End Function + +Private Function utc_ExecuteInShell(utc_ShellCommand As String) As utc_ShellResult +#If VBA7 Then + Dim utc_File As LongPtr + Dim utc_Read As LongPtr +#Else + Dim utc_File As Long + Dim utc_Read As Long +#End If + + Dim utc_Chunk As String + + On Error GoTo utc_ErrorHandling + utc_File = utc_popen(utc_ShellCommand, "r") + + If utc_File = 0 Then: Exit Function + + Do While utc_feof(utc_File) = 0 + utc_Chunk = VBA.Space$(50) + utc_Read = CLng(utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File)) + If utc_Read > 0 Then + utc_Chunk = VBA.Left$(utc_Chunk, CLng(utc_Read)) + utc_ExecuteInShell.utc_Output = utc_ExecuteInShell.utc_Output & utc_Chunk + End If + Loop + +utc_ErrorHandling: + utc_ExecuteInShell.utc_ExitCode = CLng(utc_pclose(utc_File)) +End Function + +#Else + +Private Function utc_DateToSystemTime(utc_Value As Date) As utc_SYSTEMTIME + utc_DateToSystemTime.utc_wYear = VBA.Year(utc_Value) + utc_DateToSystemTime.utc_wMonth = VBA.Month(utc_Value) + utc_DateToSystemTime.utc_wDay = VBA.Day(utc_Value) + utc_DateToSystemTime.utc_wHour = VBA.Hour(utc_Value) + utc_DateToSystemTime.utc_wMinute = VBA.Minute(utc_Value) + utc_DateToSystemTime.utc_wSecond = VBA.Second(utc_Value) + utc_DateToSystemTime.utc_wMilliseconds = 0 +End Function + +Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date + utc_SystemTimeToDate = DateSerial(utc_Value.utc_wYear, utc_Value.utc_wMonth, utc_Value.utc_wDay) + _ + TimeSerial(utc_Value.utc_wHour, utc_Value.utc_wMinute, utc_Value.utc_wSecond) +End Function + +#End If diff --git a/XVBA/MSS/■MSSツール/vba-files/Module/Module1.bas b/XVBA/MSS/■MSSツール/vba-files/Module/Module1.bas new file mode 100644 index 00000000..4e3ca58e --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Module/Module1.bas @@ -0,0 +1,529 @@ +Attribute VB_Name = "Module1" +Option Explicit + +'****************************************************************************** +'V[g +Public shMSSdata As String +Public shMSSattach As String +Public shMSSlist1 As String +Public shMSSlist2 As String + +Public shMSSattach2 As String +Public shMSSlist3 As String + +Public thList As String + +'ʕϐF +Public keiyakuCode As String +Public workFolder As String +Public customerName As String +Public currentDirPath As String +Public apiKey As String +Public baseURL As String + +'gDXg +Public DeptsList As New Dictionary + + +'tH_ɎgpłȂꗗ +Public invalidChars As String + +'****************************************************************************** +Function init() + 'pubNϐɒli[ + shMSSdata = "MSSf[^" + shMSSattach = "MSSYt" + shMSSlist1 = "MSSf[^ꗗ" + shMSSlist2 = "MSSXg" + + shMSSattach2 = "qlf[^Yt" + shMSSlist3 = "qlf[^Xg" + + thList = "WFljύX\" + + + currentDirPath = Application.ThisWorkbook.Path + invalidChars = "<>/\\:*?" & Chr(34) & Chr(39) & Chr(0) & Chr(60) & Chr(62) & Chr(42) & Chr(124) & Chr(58) & Chr(160) + + 'Pleasanter API KEY + apiKey = "6504c8a807677a3a576e10327f3c19876c55736ee45d4a845796b9e7f5e087bfd4bd0d8184863da8cf1733ca635111432ab334aea59102b06a96ee6d2c05190d" + baseURL = "https://nextoffice.Next-hd.co.jp" + + '_E[ht@CۑtH_̃pX쐬 + Dim class200 As String + class200 = Range("R[h").value + If class200 <> "" Then + 'tH_ɎgȂ폜 + Dim i As Integer + For i = 1 To Len(invalidChars) + class200 = Replace(class200, Mid(invalidChars, i, 1), "") + Next i + 'Xy[XA_[XRAɒu + class200 = Replace(class200, " ", "") + class200 = Replace(class200, "@", "") + workFolder = class200 + Else + workFolder = "" + End If + +End Function + + +Sub getFileDownloadList1() + 'Debug.Print ">>> w肳ꂽYtt@Cꊇ_E[h Jn" + Call init + + Dim listCount As Long + Dim fileCount As Long + + Dim hyplink As Hyperlink + + '_E[hÕNA + Dim g1 As Long + g1 = 12 + Dim g2 As Long + g2 = Worksheets(shMSSattach).Cells(Rows.count, 8).End(xlUp).Row + If g2 >= g1 Then + With Worksheets(shMSSattach).Range(Worksheets(shMSSattach).Cells(g1, 8), Worksheets(shMSSattach).Cells(g2, 8)) + .ClearContents + .Hyperlinks.Delete + .Font.Color = RGB(0, 0, 0) + .Font.Underline = False + .Font.Bold = False + End With + End If + + 'NA + With Worksheets(shMSSattach).Range("H9") + .ClearContents + .Hyperlinks.Delete + .Font.Color = RGB(0, 0, 0) + .Font.Underline = False + .Font.Bold = False + End With + + Worksheets(shMSSattach).Cells(g1, 8).value = "---_E[hJn---" + + listCount = Worksheets(shMSSattach).Cells(Rows.count, 1).End(xlUp).Row + Dim i As Long + 'Ytt@CV[gADLw肳Ă鍀ڂGuidXg擾 + For i = 2 To listCount + If Worksheets(shMSSattach).Cells(i, 6) = 1 Then + If Worksheets(shMSSattach).Cells(i, 5) > 0 Then + '********************************** + 'ڋqʃtH_݂邩mF + Dim fso As Object + Set fso = CreateObject("Scripting.FileSystemObject") + + If Not fso.FolderExists(currentDirPath & "\" & workFolder) Then + 'Ȃꍇ̓tH_쐬 + fso.CreateFolder (currentDirPath & "\" & workFolder) + + End If + + 'ۑfBNg̃N쐬 + Worksheets(shMSSattach).Range("H9").value = workFolder + Set hyplink = ActiveSheet.Hyperlinks.Add( _ + Anchor:=Worksheets(shMSSattach).Range("H9"), _ + Address:=workFolder) + + 'ۑfBNgmF + Dim saveFolderPath As String + Dim docName As String + Dim docNumber As String + docName = Worksheets(shMSSattach).Cells(i, 2).value 'ڂ̖O + docNumber = Worksheets(shMSSattach).Cells(i, 1) 'ڂ̔ԍ + + Dim charCount As Integer + For charCount = 1 To Len(invalidChars) + docName = Replace(docName, Mid(invalidChars, charCount, 1), "") + Next charCount + + saveFolderPath = currentDirPath & "\" & workFolder & "\" & docNumber & "." & docName + + 'ږtH_݂邩mF + If Not fso.FolderExists(saveFolderPath) Then + 'Ȃꍇ̓tH_쐬 + fso.CreateFolder (saveFolderPath) + End If + + Dim j As Long + j = Worksheets(shMSSattach).Cells(i, 4) 'ڂ̗W + fileCount = Worksheets(shMSSattach).Cells(Rows.count, j).End(xlUp).Row 't@CGuidXg̖sW + + '擾GuidXgɃ_E[hJn + Dim k As Long + + + For k = 4 To fileCount + Dim guid As String + Dim fileName As String + fileName = Worksheets(shMSSattach).Cells(k, j + 1).value + guid = Worksheets(shMSSattach).Cells(k, j).value + 'Debug.Print "t@CDL: " & fileName + + '_E[h + Dim result As Boolean + result = getAttachmentsFile(guid, saveFolderPath) + + '_E[hۑ + If result = True Then + g2 = Worksheets(shMSSattach).Cells(Rows.count, 8).End(xlUp).Row + 1 + Worksheets(shMSSattach).Cells(g2, 8).value = docNumber & "." & docName & "\" & fileName + Set hyplink = ActiveSheet.Hyperlinks.Add( _ + Anchor:=Worksheets(shMSSattach).Cells(g2, 8), _ + Address:=workFolder & "\" & Worksheets(shMSSattach).Cells(g2, 8).value) + End If + + Next k + End If + End If + Next i + + g2 = Worksheets(shMSSattach).Cells(Rows.count, 8).End(xlUp).Row + 1 + Worksheets(shMSSattach).Cells(g2, 8).value = "---_E[hI---" + + 'Debug.Print "<<< w肳ꂽYtt@Cꊇ_E[h I" + +End Sub + + +Sub getFileDownloadList2() + 'Debug.Print ">>> w肳ꂽqlf[^Ytt@Cꊇ_E[h Jn" + Call init + + Dim listCount As Long + Dim fileCount As Long + + Dim hyplink As Hyperlink + + + '_E[hÕNA + Dim g1 As Long + g1 = 13 + Dim g2 As Long + g2 = Worksheets(shMSSattach2).Cells(Rows.count, 2).End(xlUp).Row + If g2 >= g1 Then + With Worksheets(shMSSattach2).Range(Worksheets(shMSSattach2).Cells(g1, 2), Worksheets(shMSSattach2).Cells(g2, 2)) + .ClearContents + .Hyperlinks.Delete + .Font.Color = RGB(0, 0, 0) + .Font.Underline = False + .Font.Bold = False + End With + End If + + 'ۑtH_N NA + With Worksheets(shMSSattach2).Range("B10") + .ClearContents + .Hyperlinks.Delete + .Font.Color = RGB(0, 0, 0) + .Font.Underline = False + .Font.Bold = False + End With + + Worksheets(shMSSattach2).Cells(g1, 2).value = "---_E[hJn---" + + listCount = Worksheets(shMSSlist3).Cells(Rows.count, 3).End(xlUp).Row + Dim i As Long + 'qlf[^XgV[gADLw肳Ă鍀ڂGuidXg擾 + For i = 4 To listCount + If Worksheets(shMSSlist3).Cells(i, 6) = 1 Then + If Worksheets(shMSSlist3).Cells(i, 5) > 0 Then + '********************************** + 'ڋqʃtH_݂邩mF + Dim fso As Object + Set fso = CreateObject("Scripting.FileSystemObject") + + If Not fso.FolderExists(currentDirPath & "\" & workFolder) Then + 'Ȃꍇ̓tH_쐬 + fso.CreateFolder (currentDirPath & "\" & workFolder) + + End If + + 'ۑtH_N N쐬 + Worksheets(shMSSattach2).Range("B10").value = workFolder + Set hyplink = ActiveSheet.Hyperlinks.Add( _ + Anchor:=Worksheets(shMSSattach2).Range("B10"), _ + Address:=workFolder) + + 'ۑfBNgmF + Dim saveFolderPath As String + Dim docName As String + Dim docNumber As String + docName = Worksheets(shMSSlist3).Cells(i, 2).value 'ڂ̖O + docNumber = Worksheets(shMSSlist3).Cells(i, 1) 'ڂ̔ԍ + + Dim charCount As Integer + For charCount = 1 To Len(invalidChars) + docName = Replace(docName, Mid(invalidChars, charCount, 1), "") + Next charCount + + saveFolderPath = currentDirPath & "\" & workFolder & "\" & docNumber & "." & docName + + 'ږtH_݂邩mF + If Not fso.FolderExists(saveFolderPath) Then + 'Ȃꍇ̓tH_쐬 + fso.CreateFolder (saveFolderPath) + End If + + Dim j As Long + j = Worksheets(shMSSlist3).Cells(i, 4) 'ڂ̗W + fileCount = Worksheets(shMSSlist3).Cells(Rows.count, j).End(xlUp).Row 't@CGuidXg̖sW + + '擾GuidXgɃ_E[hJn + Dim k As Long + + + For k = 4 To fileCount + Dim guid As String + Dim fileName As String + fileName = Worksheets(shMSSlist3).Cells(k, j + 1).value + guid = Worksheets(shMSSlist3).Cells(k, j).value + 'Debug.Print "t@CDL: " & fileName + + '_E[h + Dim result As Boolean + result = getAttachmentsFile(guid, saveFolderPath) + + '_E[hۑ + If result = True Then + g2 = Worksheets(shMSSattach2).Cells(Rows.count, 2).End(xlUp).Row + 1 + Worksheets(shMSSattach2).Cells(g2, 2).value = docNumber & "." & docName & "\" & fileName + Set hyplink = ActiveSheet.Hyperlinks.Add( _ + Anchor:=Worksheets(shMSSattach2).Cells(g2, 2), _ + Address:=workFolder & "\" & Worksheets(shMSSattach2).Cells(g2, 2).value) + End If + + Next k + End If + End If + Next i + + g2 = Worksheets(shMSSattach2).Cells(Rows.count, 2).End(xlUp).Row + 1 + Worksheets(shMSSattach2).Cells(g2, 2).value = "---_E[hI---" + + 'Debug.Print "<<< w肳ꂽqlf[^Ytt@Cꊇ_E[h I" +End Sub + + +'vU^[̃[U[ꗗ擾 +Sub getPleasanterUsers() + Application.ScreenUpdating = False 'ʍXV~ + Application.Calculation = xlManual 'vZ~ + 'Debug.Print ">>> vU^[̃[U[ꗗ擾 Jn" + + Dim sh As Worksheet + Set sh = Worksheets("}X^[f[^") + sh.ListObjects("ЈXg").DataBodyRange.Delete + sh.ListObjects("gDXg").DataBodyRange.Delete + + Call init + + Call getPleasanterDeptsRequest(0) + Call getPleasanterUsersRequest(0) + + Application.Calculation = xlAutomatic 'vZJn + Application.ScreenUpdating = True 'ʍXVJn + 'Debug.Print "<<< vU^[̃[U[ꗗ擾 I" +End Sub + +Function getPleasanterUsersRequest(offset) + 'ʕϐ + Dim apiUrl As String + Dim apiUrlParam As String + + 'NGXgURL + apiUrl = baseURL & "/pleasanter/api/users/" + apiUrlParam = "Get" + + 'wb_ + Dim apiHeaders As New Dictionary + apiHeaders.Add "Content-Type", "application/json;charset=utf-8" + + 'NGXgf[^ + Dim apiBody As New Dictionary + apiBody.Add "ApiVersion", "1.1" + apiBody.Add "ApiKey", apiKey + apiBody.Add "Offset", offset + + 'Filterϐ + Dim colSorter As New Dictionary + colSorter.Add "UserId", "asc" + + 'Viewϐ + Dim view As New Dictionary + view.Add "ColumnSorterHash", colSorter + apiBody.Add "View", view + + 'HTTPNGXgM\bhĂяo + Dim res As Object + Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody) + + If res("StatusCode") = 200 Then + 'Ɏ擾łV[g֏ + 'Call exportToSheetData(res) + 'Debug.Print JsonConverter.ConvertToJson(res("Response")("TotalCount")) + 'Debug.Print JsonConverter.ConvertToJson(res("Response")("PageSize")) + 'Debug.Print JsonConverter.ConvertToJson(res("Response")("Offset")) + 'Debug.Print JsonConverter.ConvertToJson(res("Response")("Data").count) + 'Debug.Print "----- 擾" + + Call exportUsersList(res) + + End If + + '200ȏ̏ꍇ͍Ďs + If res("Response")("PageSize") + res("Response")("Offset") < res("Response")("TotalCount") Then + Call getPleasanterUsersRequest(offset + 200) + End If + + +End Function + +'}X^[f[^V[g̎ЈXge[uXV +Function exportUsersList(res) + Dim value + Dim N As Long + Dim sh As Worksheet + Set sh = Worksheets("}X^[f[^") + + For Each value In res("Response")("Data") + 'Debug.Print value("UserId") & " " & value("LoginId") & " " & value("Name") + + sh.ListObjects("ЈXg").ListRows.Add + N = sh.ListObjects("ЈXg").ListRows.count + With sh.ListObjects("ЈXg").ListRows(N) + .Range(1) = value("UserId") + .Range(2) = value("LoginId") + .Range(3) = value("Name") + .Range(4) = value("DeptCode") + .Range(5) = DeptsList(value("DeptCode")) + .Range(6) = "" + End With + + Next value + +End Function + +Function getPleasanterDeptsRequest(offset) + 'ʕϐ + Dim apiUrl As String + Dim apiUrlParam As String + + 'NGXgURL + apiUrl = baseURL & "/pleasanter/api/depts/" + apiUrlParam = "Get" + + 'wb_ + Dim apiHeaders As New Dictionary + apiHeaders.Add "Content-Type", "application/json;charset=utf-8" + + 'NGXgf[^ + Dim apiBody As New Dictionary + apiBody.Add "ApiVersion", "1.1" + apiBody.Add "ApiKey", apiKey + apiBody.Add "Offset", offset + + 'Filterϐ + Dim colSorter As New Dictionary + colSorter.Add "DeptId", "asc" + + 'Viewϐ + Dim view As New Dictionary + view.Add "ColumnSorterHash", colSorter + apiBody.Add "View", view + + 'HTTPNGXgM\bhĂяo + Dim res As Object + Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody) + + If res("StatusCode") = 200 Then + 'Ɏ擾łV[g֏ + 'Call exportToSheetData(res) + 'Debug.Print JsonConverter.ConvertToJson(res("Response")("TotalCount")) + 'Debug.Print JsonConverter.ConvertToJson(res("Response")("PageSize")) + 'Debug.Print JsonConverter.ConvertToJson(res("Response")("Offset")) + 'Debug.Print JsonConverter.ConvertToJson(res("Response")("Data").count) + 'Debug.Print "----- 擾" + + Call exportDeptsList(res) + + End If + + '200ȏ̏ꍇ͍Ďs + If res("Response")("PageSize") + res("Response")("Offset") < res("Response")("TotalCount") Then + Call getPleasanterDeptsRequest(offset + 200) + End If + + +End Function + +'}X^[f[^V[g̑gDXgXV +Function exportDeptsList(res) + Dim value + Dim N As Long + Dim sh As Worksheet + Set sh = Worksheets("}X^[f[^") + + For Each value In res("Response")("Data") + DeptsList.Add value("DeptCode"), value("DeptName") + + sh.ListObjects("gDXg").ListRows.Add + N = sh.ListObjects("gDXg").ListRows.count + With sh.ListObjects("gDXg").ListRows(N) + .Range(1) = value("DeptId") + .Range(2) = value("DeptCode") + .Range(3) = value("DeptName") + .Range(4) = value("Body") + End With + + Next value + +End Function + +Sub SheetToPdfSave1() + Call SheetToPdfSave("o", "oy{pz") +End Sub + +Sub SheetToPdfSave2() + Call SheetToPdfSave("evmF(݌v_)", "evmF(݌v_)y{pz") +End Sub + +Sub SheetToPdfSave3() + Call SheetToPdfSave("evmF({_)", "evmF({_)y{pz") +End Sub + + +'w肵V[g𖼑O‚PDFۑ +Function SheetToPdfSave(shName, fileName) + + Call init + '********************************** + 'ڋqʃtH_݂邩mF + Dim fso As Object + Set fso = CreateObject("Scripting.FileSystemObject") + + If Not fso.FolderExists(currentDirPath & "\" & workFolder) Then + 'Ȃꍇ̓tH_쐬 + fso.CreateFolder (currentDirPath & "\" & workFolder) + + End If + Dim filePath + filePath = ThisWorkbook.Path & "\" + Dim fileName2 + fileName2 = workFolder & "" & fileName + + 'ۑ + Dim saveFile + + saveFile = filePath & workFolder & "\" & fileName2 & ".pdf" + + Debug.Print saveFile + + Worksheets(shName).Range("A1").Select + ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, fileName:=saveFile _ + , Quality:=xlQualityStandard, _ + IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True + +End Function diff --git a/XVBA/MSS/■MSSツール/vba-files/Module/Module2.bas b/XVBA/MSS/■MSSツール/vba-files/Module/Module2.bas new file mode 100644 index 00000000..397a8604 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Module/Module2.bas @@ -0,0 +1,272 @@ +Attribute VB_Name = "Module2" +Option Explicit +'########################################################################################################## +'@selectKeiyakuCode +'@@@_R[hIAf[^1擾 +'@getMSSdataRequest +'@@@qlf[^t@C̈ꗗ擾NGXg +'@exportToSheetData +'@@@擾t@CV[gɕۑ + + +'****************************************************************************** +'Xg_R[hI +Sub selectKeiyakuCode() + Application.ScreenUpdating = False 'ʍXV~ + Application.Calculation = xlManual 'vZ~ + + Call init + 'Debug.Print ">>> MSSf[^1擾鏈Jn܂" + + Dim Ad As String 'Zԍpϐ + Dim Col As Integer 'Z̗ԍpϐ + Dim Row As Integer 'Z̍sԍpϐ + + Ad = ActiveCell.Address + Col = ActiveCell.Column + Row = ActiveCell.Row + + Range("R[hID").value = "" + Range("R[h^Cg").value = "" + + 'e[u͈͖ɃJ[\ƂɃ{^A_R[h擾 + If Row >= 3 And Row <= 104 And Col >= 4 And Col <= 19 Then + Dim keiyakuCode As Variant + keiyakuCode = Worksheets(shMSSlist1).Cells(Row, 13).value + + 'Debug.Print keiyakuCode + + If keiyakuCode <> 0 Then + Range("_R[hw").value = keiyakuCode + Else + Range("_R[hw").value = "" + Range("R[hID").value = "" + Range("R[h^Cg").value = "" + + End If + End If + + If Range("_R[hw").value <> "" Then + 'e[uOɃJ[\ƂA•ʌ_R[hɒls + If Range("_R[hw").value = "9999AAABB" Then + MsgBox "_R[hy9999AAABBz͑Is" + Else + Call getMSSdataRequest(Range("_R[hw").value) + End If + Else + MsgBox "擾XgIĂ" + End If + + Application.Calculation = xlAutomatic 'vZJn + Application.ScreenUpdating = True 'ʍXVJn + 'Debug.Print "<<< MSSf[^1擾鏈I܂" +End Sub + + +'****************************************************************************** +'vU^[}X^[V[gP̃f[^擾 +Function getMSSdataRequest(ByVal keiyakuCode As String) + 'ʕϐ + Dim apiUrl As String + Dim apiUrlParam As String + Dim tableId As String + + 'MSSe[uID + tableId = "189112" + + 'NGXgURL + apiUrl = baseURL & "/pleasanter/api/items/" & tableId & "/" + apiUrlParam = "Get" + + 'wb_ + Dim apiHeaders As New Dictionary + apiHeaders.Add "Content-Type", "application/json;charset=utf-8" + + 'NGXgf[^ + Dim apiBody As New Dictionary + apiBody.Add "ApiVersion", "1.1" + apiBody.Add "ApiKey", apiKey + + 'Filterϐ + Dim colFilter As New Dictionary + colFilter.Add "ClassA", keiyakuCode + + 'Viewϐ + Dim view As New Dictionary + view.Add "ColumnFilterHash", colFilter + apiBody.Add "View", view + + 'HTTPNGXgM\bhĂяo + Dim res As Object + Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody) + + If res("StatusCode") = 200 And res("Response")("TotalCount") = 1 Then + 'O[oϐ֏i[ + keiyakuCode = res("Response")("Data")(1)("ClassHash")("ClassA") + + 'Ɏ擾łV[g֏ + 'Debug.Print "•ʏ 擾" + Call exportToSheetData(res) + End If + +End Function + +'****************************************************************************** +'vU^[}X^[V[g擾f[^V[gɏ +Function exportToSheetData(res As Object) + Dim itemTitle As String + Dim resultId As String + + itemTitle = res("Response")("Data")(1)("ItemTitle") + Range("R[h^Cg").value = itemTitle + + resultId = res("Response")("Data")(1)("ResultId") + Range("R[hID").value = resultId + + Dim key, g + g = 2 + For Each key In res("Response")("Data")(1) + If IsObject(res("Response")("Data")(1)(key)) Then + 'gHash̏ꍇ͔΂ + Else + Worksheets(shMSSdata).Cells(g, 26) = key + Worksheets(shMSSdata).Cells(g, 27) = res("Response")("Data")(1)(key) + g = g + 1 + End If + Next key + + + 'ŏIs擾 + Dim lastRow As Long + Dim hashNameList As New Dictionary + hashNameList.Add 2, "ClassHash" + hashNameList.Add 5, "NumHash" + hashNameList.Add 8, "DateHash" + hashNameList.Add 11, "DescriptionHash" + hashNameList.Add 14, "CheckHash" + hashNameList.Add 17, "AttachmentsHash" + + Dim j As Long + j = 2 + For j = 2 To 14 Step 3 + 'OɃZNA + Worksheets(shMSSdata).Columns(j + 2).ClearContents + 'HashXg + Dim hashName As String + hashName = hashNameList(j) + + lastRow = Worksheets(shMSSdata).Cells(Rows.count, j).End(xlUp).Row + Dim i As Long + For i = 2 To lastRow + 'Zl擾 + Dim colName As String + colName = Worksheets(shMSSdata).Cells(i, j).value + Dim data As Variant + data = res("Response")("Data")(1)(hashName)(colName) + + 't̏ꍇ͉ + If hashName = "DateHash" Then + If data = "1899-12-30T00:00:00" Then + data = "" + Else + data = Replace(data, "T", " ") + End If + End If + + Worksheets(shMSSdata).Cells(i, j + 2) = data + Next i + Next j + + '****************************************************************************** + 'Ytt@Cf[^ + 'OɃZNA + Worksheets(shMSSattach).Range("L4:DD100").ClearContents + '_E[hÕNA + Dim g1 As Long + g1 = 12 + Dim g2 As Long + g2 = Worksheets(shMSSattach).Cells(Rows.count, 8).End(xlUp).Row + If g2 >= g1 Then + With Worksheets(shMSSattach).Range(Worksheets(shMSSattach).Cells(g1, 8), Worksheets(shMSSattach).Cells(g2, 8)) + .ClearContents + .Hyperlinks.Delete + .Font.Color = RGB(0, 0, 0) + .Font.Underline = False + .Font.Bold = False + End With + End If + + 'NA + With Worksheets(shMSSattach).Range("H9") + .ClearContents + .Hyperlinks.Delete + .Font.Color = RGB(0, 0, 0) + .Font.Underline = False + .Font.Bold = False + End With + + + hashName = hashNameList(j) + Dim jj As Long + jj = 3 + lastRow = Worksheets(shMSSattach).Cells(Rows.count, jj).End(xlUp).Row + For i = 2 To lastRow + 'Zl擾 + colName = Worksheets(shMSSattach).Cells(i, jj).value + + Dim rowNum As Long + rowNum = Worksheets(shMSSattach).Cells(i, jj + 1).value + + If res("Response")("Data")(1)(hashName).Exists(colName) = True Then + Dim k As Long + For k = 1 To res("Response")("Data")(1)(hashName)(colName).count + Dim l As Long + l = (k - 1) * 2 + ''Debug.Print res("Response")("Data")(1)(hashName)(colName)(k)("Guid") + ''Debug.Print res("Response")("Data")(1)(hashName)(colName)(k)("Name") + Worksheets(shMSSattach).Cells(k + 3, rowNum) = res("Response")("Data")(1)(hashName)(colName)(k)("Guid") + Worksheets(shMSSattach).Cells(k + 3, rowNum + 1) = res("Response")("Data")(1)(hashName)(colName)(k)("Name") + Next k + + End If + Next i + + + '****************************************************************************** + 'qlf[^GuidۊǃGÃNA + 'OɃZNA + Worksheets(shMSSlist3).Range("L4:ZZ100").ClearContents + + '_E[hÕNA + 'Dim g1 As Long + g1 = 13 + 'Dim g2 As Long + g2 = Worksheets(shMSSattach2).Cells(Rows.count, 2).End(xlUp).Row + If g2 >= g1 Then + With Worksheets(shMSSattach2).Range(Worksheets(shMSSattach2).Cells(g1, 2), Worksheets(shMSSattach2).Cells(g2, 2)) + .ClearContents + .Hyperlinks.Delete + .Font.Color = RGB(0, 0, 0) + .Font.Underline = False + .Font.Bold = False + End With + End If + + 'ۑtH_N NA + With Worksheets(shMSSattach2).Range("B10") + .ClearContents + .Hyperlinks.Delete + .Font.Color = RGB(0, 0, 0) + .Font.Underline = False + .Font.Bold = False + End With + + 'qlf[^t@C̎擾 + Call getMSSfilesList + '̑f[^̎擾 + Call getOtherData + + Call jsonToSheetTest + +End Function + diff --git a/XVBA/MSS/■MSSツール/vba-files/Module/Module3.bas b/XVBA/MSS/■MSSツール/vba-files/Module/Module3.bas new file mode 100644 index 00000000..97e6351d --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Module/Module3.bas @@ -0,0 +1,250 @@ +Attribute VB_Name = "Module3" +Option Explicit +'########################################################################################################## +'@getMSSlist +'@@@MSSČꗗ̎擾 +'@getMSSlistRequest +'@@@vU^[}X^[V[gwcƏ̑Sf[^擾 +' exportToMSSlist +'@@@vU^[}X^[V[g擾Xgf[^ + +'****************************************************************************** +'MSSf[^XgŎ擾 +Sub getMSSlist() + Application.ScreenUpdating = False 'ʍXV~ + Application.Calculation = xlManual 'vZ~ + + Call init + 'Debug.Print ">>> MSSf[^XgŎ擾鏈Jn܂" + + 'MSSf[^ꗗcƏ擾 + Dim shopName As String + Dim shopCode As String + Dim statusName As String + Dim statusCode As String + + shopName = Range("cƏw").value + statusName = Range("Xe[^X").value + + 'cƏƃXe[^X͂ǂ炩Kw + If shopName = "" And statusName = "" Then + Range("cƏw").Select + MsgBox "cƏXe[^Xw肵Ă" + Else + '_R[ȟ•ʎw藓󗓂ɂĂ烊Xg擾s + 'Range("_R[h").Value = "" + + Call getMSSlistRequest + End If + + Application.Calculation = xlAutomatic 'vZJn + Application.ScreenUpdating = True 'ʍXVJn + 'Debug.Print "<<< MSSf[^XgŎ擾鏈I܂" +End Sub + + +'****************************************************************************** +'vU^[}X^[V[gwcƏ̑Sf[^擾 +Function getMSSlistRequest() + 'ʕϐ + Dim apiUrl As String + Dim apiUrlParam As String + Dim tableId As String + + 'MSSe[uID + tableId = "189112" + + 'NGXgURL + apiUrl = baseURL & "/pleasanter/api/items/" & tableId & "/" + apiUrlParam = "Get" + + 'wb_ + Dim apiHeaders As New Dictionary + apiHeaders.Add "Content-Type", "application/json;charset=utf-8" + + 'NGXgf[^ + Dim apiBody As New Dictionary + apiBody.Add "ApiVersion", "1.1" + apiBody.Add "ApiKey", apiKey + + 't쐬 + Dim currentDate As Date + currentDate = Date + + 'ߌ擾AtvZ + Dim delayMonth As Integer + If Range("").value = "" Then + Range("").value = 1 + delayMonth = -1 + Else + delayMonth = (-1) * Range("").value + End If + + Dim previousYearDate As Date + previousYearDate = DateAdd("m", delayMonth, currentDate) + + 'ɕϊ + Dim previousYearDateString As String + previousYearDateString = Format(previousYearDate, "yyyy/mm/dd") + previousYearDateString = previousYearDateString & " 00:00:00" + + 'Debug.Print previousYearDateString + + 'Filterϐ + Dim colFilter As New Dictionary + Dim shopID As String + Dim statusID As String + Dim salesID As String + Dim yakuinID As String + Dim sekkeiID As String + Dim bunruiID As String + + shopID = Range("cƏID") + statusID = Range("Xe[^XID") + salesID = Range("cID") + sekkeiID = Range("݌vID") + yakuinID = Range("ID") + bunruiID = Range("V[gID") + + If shopID <> "" Then + colFilter.Add "ClassF", "[" & shopID & "]" + End If + If statusID <> "" Then + colFilter.Add "Status", "[" & statusID & "]" + End If + If salesID <> "" Then + colFilter.Add "ClassG", "[" & salesID & "]" + End If + If sekkeiID <> "" Then + colFilter.Add "ClassL", "[" & sekkeiID & "]" + End If + If yakuinID <> "" Then + colFilter.Add "Class122", "[" & yakuinID & "]" + End If + If bunruiID <> "" Then + colFilter.Add "ClassP", "[" & bunruiID & "]" + End If + + colFilter.Add "UpdatedTime", "[""" & previousYearDateString & ",""]" + + Dim colSorter As New Dictionary + colSorter.Add "Status", "asc" + colSorter.Add "ClassG", "asc" + + 'Viewϐ + Dim view As New Dictionary + view.Add "ColumnFilterHash", colFilter + view.Add "ColumnSorterHash", colSorter + apiBody.Add "View", view + + 'HTTPNGXgM\bhĂяo + Dim res As Object + Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody) + + If res("StatusCode") = 200 Then + 'Ɏ擾łV[g֏ + 'Call exportToSheetData(res) + 'Debug.Print JsonConverter.ConvertToJson(res("Response")("TotalCount")) + 'Debug.Print "MSSf[^Xg 擾" + Call exportToMSSlist(res) + End If + +End Function + + +'****************************************************************************** +'vU^[}X^[V[g擾Xgf[^ +Function exportToMSSlist(res As Object) + 'Xg̃NA + Worksheets(shMSSlist2).Range("B3:AZ100").ClearContents + 'Xe[^X Status + '^Cg ItemTitle + 'V[g ClassP* + '_cƏ ClassF* + 'Sc ClassG* + 'Ǘ݌v ClassL + ' ClassY + 'S Class122 + '_R[h ClassA + '݌v_ ClassN* + '_uh Class033* + 'H ClassQ + '{_ DateD + '݌v_ DateE + 'H\ DateH + '㓏\ DateJ + 'n\ DateL + 'ŏIXV UpdatedTime + + Dim dataCount As Long + dataCount = res("Response")("TotalCount") + + If dataCount = 0 Then + Exit Function + End If + + ''Debug.Print JsonConverter.ConvertToJson(res("Response")("Data")) + + Dim i As Long + For i = 1 To dataCount + Dim j As Long: j = 2 + + Dim dataArray() As Variant + ReDim dataArray(1) + dataArray(1) = res("Response")("Data")(i)("ResultId") + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = res("Response")("Data")(i)("Status") + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ItemTitle") + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("ClassP") + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("ClassF") + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("ClassG") + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("ClassL") + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("ClassY") + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("Class122") + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("ClassA") + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("ClassN") + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("Class033") + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = res("Response")("Data")(i)("ClassHash")("ClassQ") + + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = stringToDate(res("Response")("Data")(i)("DateHash")("DateD")) + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = stringToDate(res("Response")("Data")(i)("DateHash")("DateE")) + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = stringToDate(res("Response")("Data")(i)("DateHash")("DateH")) + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = stringToDate(res("Response")("Data")(i)("DateHash")("DateJ")) + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = stringToDate(res("Response")("Data")(i)("DateHash")("DateL")) + ReDim Preserve dataArray(UBound(dataArray) + 1) + dataArray(UBound(dataArray)) = stringToDate(res("Response")("Data")(i)("UpdatedTime")) + + + Dim k As Long + For k = 0 To UBound(dataArray) + Worksheets(shMSSlist2).Cells(i + 2, k + 1) = dataArray(k) + Next k + Next i + +End Function + + +Function stringToDate(ByVal dateVal As String) As Variant + If dateVal = "1899-12-30T00:00:00" Then + stringToDate = "" + Else + stringToDate = CDate(Replace(dateVal, "T", " ")) + End If +End Function + diff --git a/XVBA/MSS/■MSSツール/vba-files/Module/Module4.bas b/XVBA/MSS/■MSSツール/vba-files/Module/Module4.bas new file mode 100644 index 00000000..928ae187 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Module/Module4.bas @@ -0,0 +1,237 @@ +Attribute VB_Name = "Module4" +Option Explicit +'########################################################################################################## +'@callRestApi +'@@@restAPINGXgėp֐ +'@getAttachmentsFile +'@@@Ytt@C +'@exportFileList +'@@@擾t@CV[gɕۑ + + +'****************************************************************************** +'REST APIďo +'@method@GetPOST +'@url@REST APIURL +'@urlParam@NGXgp[^iIvVj +'@headers@wb_iIvVj +Function callRestApi(ByVal method As String, ByVal url As String, Optional ByVal urlParam As String = "", Optional ByVal headers As Dictionary = Null, Optional ByVal body As Dictionary = Null) As Object + + 'HTTPNGXg̃IuWFNg` + Dim objHTTP As Object + Set objHTTP = New XMLHTTP60 + + 'HTTPNGXg̐ڑݒ + objHTTP.Open method, url & urlParam, False + + 'NGXgwb_[ݒiꍇsetRequestHeader𕡐Ηǂ̂`j + Dim i As Long + For i = 0 To headers.count - 1 + objHTTP.setRequestHeader headers.keys(i), headers.items(i) + Next i + + 'NGXgM + objHTTP.send JsonConverter.ConvertToJson(body) + + Do While objHTTP.readyState < 4 + DoEvents + Loop + + 'X|X̕iobjHTTP.responseTextjJsonɕϊĕԋp + Set callRestApi = JsonConverter.ParseJson(objHTTP.responseText) + +End Function + +'****************************************************************************** +'guidYtt@C̃oCif[^擾 +Function getAttachmentsFile(guid As String, saveFolderPath As String) As Boolean + 'ʕϐ + Dim apiUrl As String + Dim apiUrlParam As String + Dim tableId As String + + 'NGXgURL + apiUrl = baseURL & "/pleasanter/api/binaries/" & guid & "/" + apiUrlParam = "Get" + + 'wb_ + Dim apiHeaders As New Dictionary + apiHeaders.Add "Content-Type", "application/json;charset=utf-8" + + 'NGXgf[^ + Dim apiBody As New Dictionary + apiBody.Add "ApiVersion", "1.1" + apiBody.Add "ApiKey", apiKey + + 'HTTPNGXgM\bhĂяo + Dim res As Object + Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody) + + If res("StatusCode") = 200 Then + '_E[hBase64f[^t@Cۑ + Dim base64Data As String + base64Data = res("Response")("Base64") + + '********************************** + 'ۑt@CpX + Dim saveFilePath As String + saveFilePath = saveFolderPath & "\" & res("Response")("FileName") + + '********************************** + 'Base64f[^fR[hĕۑ + Dim ret As Long + ret = DecodeBase64(base64Data, saveFilePath) + + 'bZ[W\ + Debug.Print "t@C̕ۑɐ܂F" & saveFilePath & ":" & ret + If ret = -1 Then + getAttachmentsFile = True + End If + End If +End Function + + +'****************************************************************************** +'@Base64fR[hăt@C‚ĕۑi㏑j +'------------------------------------------------------------------------------ +'@PFBase64̕@2Fۑt@C +'****************************************************************************** +Function DecodeBase64(ByVal Base64Str As String, ByVal filePath As String) As Long + 't@CBase64fR[h + Dim elm As Object + Dim ret As Long + Const adTypeBinary = 1 + Const adSaveCreateOverWrite = 2 + + ret = -1 ' + On Error Resume Next + Set elm = CreateObject("MSXML2.DOMDocument").createElement("base64") + elm.DataType = "bin.base64" + elm.text = Base64Str + With CreateObject("ADODB.Stream") + .Type = adTypeBinary + .Open + .Write elm.nodeTypedValue + .SaveToFile filePath, adSaveCreateOverWrite + .Close + End With + If Err.Number <> 0 Then ret = 0 + On Error GoTo 0 + DecodeBase64 = ret +End Function + +Sub jsonToSheetTest() + Dim jsonStr As String + Dim targetSheet As String + Dim targetCol As String + + 'ۊǂV[g + targetSheet = "JSONf[^" + + 'ǂݍރf[^Ɠfoʒu + jsonStr = Range("_json").value + targetCol = 2 + Call jsonToSheet(jsonStr, targetSheet, targetCol) + + jsonStr = Range("{Hjson").value + targetCol = 4 + Call jsonToSheet(jsonStr, targetSheet, targetCol) + + jsonStr = Range("_cƏjson").value + targetCol = 6 + Call jsonToSheet(jsonStr, targetSheet, targetCol) + + jsonStr = Range("_uhjson").value + targetCol = 8 + Call jsonToSheet(jsonStr, targetSheet, targetCol) + + jsonStr = Range("V[Yjson").value + targetCol = 10 + Call jsonToSheet(jsonStr, targetSheet, targetCol) + + jsonStr = Range("xJSON").value + targetCol = 14 + Call jsonToSheet2(jsonStr, targetSheet, targetCol) + + +End Sub + +'****************************************************************************** +'json𕪉Aw肵V[gEZ̈ʒuɓWJ +Function jsonToSheet(ByVal jsonStr As String, ByVal targetSheet As String, ByVal targetCol As Long) + Debug.Print ">>> Json𕪐͂AV[gɏo" + + Dim jsonObj As Object + Dim key1, key2 + Dim item1, item2 + Dim i + + i = 3 + + 'f[^NA + With Worksheets(targetSheet) + .Range(.Cells(i, targetCol), .Cells(1000, targetCol + 1)).ClearContents + End With + + 'JSON񂪋󕶎̏ꍇI + If jsonStr = "" Then + Exit Function + End If + + 'fVACY + Set jsonObj = JsonConverter.ParseJson(jsonStr) + For Each key1 In jsonObj + + If IsObject(jsonObj(key1)) Then + 'gIuWFNg̏ꍇ͂x + For Each key2 In jsonObj(key1) + item2 = jsonObj(key1)(key2) + Worksheets(targetSheet).Cells(i, targetCol) = key2 + Worksheets(targetSheet).Cells(i, targetCol + 1) = item2 + i = i + 1 + Next key2 + Else + item1 = jsonObj(key1) + Worksheets(targetSheet).Cells(i, targetCol) = key1 + Worksheets(targetSheet).Cells(i, targetCol + 1) = item1 + i = i + 1 + End If + + Next key1 + + +End Function + +'****************************************************************************** +'json𕪉Aw肵V[gEZ̈ʒuɓWJ 2 +'z^Cv +Function jsonToSheet2(ByVal jsonStr As String, ByVal targetSheet As String, ByVal targetCol As Long) + Debug.Print ">>> Json𕪐͂AV[gɏo 2" + + Dim jsonObj As Object + Set jsonObj = JsonConverter.ParseJson(jsonStr) + + Dim key1, item1 + Dim obj + Dim i, j + + i = 3 + + For Each obj In jsonObj + j = targetCol + + For Each key1 In obj + item1 = obj(key1) + Worksheets(targetSheet).Cells(i, j) = item1 + j = j + 1 + Next key1 + + i = i + 1 + + Next obj + + +End Function + + + diff --git a/XVBA/MSS/■MSSツール/vba-files/Module/Module5.bas b/XVBA/MSS/■MSSツール/vba-files/Module/Module5.bas new file mode 100644 index 00000000..1a418df9 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Module/Module5.bas @@ -0,0 +1,129 @@ +Attribute VB_Name = "Module5" +Option Explicit +'########################################################################################################## +'@getMSSfilesList +'@@@qlf[^t@C̃Xg_E[h +'@getMSSfilesListRequest +'@@@qlf[^t@C̈ꗗ擾NGXg +'@exportFileList +'@@@擾t@CV[gɕۑ + + +'****************************************************************************** +'qlf[^̈ꗗ擾 +Sub getMSSfilesList() + Application.ScreenUpdating = False 'ʍXV~ + Application.Calculation = xlManual 'vZ~ + + Call init + 'Debug.Print ">>> qlf[^t@C̃Xg_E[h Jn" + + '// + Dim recordId As String + recordId = Range("qlf[^ID").value + If recordId <> "" And recordId <> "212512" Then + Call getMSSfilesListRequest(recordId) + End If + + Application.Calculation = xlAutomatic 'vZJn + Application.ScreenUpdating = True 'ʍXVJn + 'Debug.Print "<<< qlf[^t@C̃Xg_E[h I" + +End Sub + +'****************************************************************************** +'qlf[^̈ꗗ擾NGXgM +Function getMSSfilesListRequest(ByVal recordId As String) + + 'ʕϐ + Dim apiUrl As String + Dim apiUrlParam As String + Dim tableId As String + + 'NGXgURL + apiUrl = baseURL & "/pleasanter/api/items/" & recordId & "/" + apiUrlParam = "Get" + + 'wb_ + Dim apiHeaders As New Dictionary + apiHeaders.Add "Content-Type", "application/json;charset=utf-8" + + 'NGXgf[^ + Dim apiBody As New Dictionary + apiBody.Add "ApiVersion", "1.1" + apiBody.Add "ApiKey", apiKey + + 'HTTPNGXgM\bhĂяo + Dim res As Object + Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody) + + If res("StatusCode") = 200 And res("Response")("TotalCount") = 1 Then + 'Ɏ擾łV[g֏ + 'Debug.Print "qlf[^ 擾" + Call exportFileList(res) + End If + +End Function + +Function exportFileList(res) + 'OɃZNA + Worksheets(shMSSlist3).Range("L4:ZZ100").ClearContents + + '_E[hÕNA + Dim g1 As Long + g1 = 13 + Dim g2 As Long + g2 = Worksheets(shMSSattach2).Cells(Rows.count, 2).End(xlUp).Row + If g2 >= g1 Then + With Worksheets(shMSSattach2).Range(Worksheets(shMSSattach2).Cells(g1, 2), Worksheets(shMSSattach2).Cells(g2, 2)) + .ClearContents + .Hyperlinks.Delete + .Font.Color = RGB(0, 0, 0) + .Font.Underline = False + .Font.Bold = False + End With + End If + + 'ۑtH_N NA + With Worksheets(shMSSattach2).Range("B10") + .ClearContents + .Hyperlinks.Delete + .Font.Color = RGB(0, 0, 0) + .Font.Underline = False + .Font.Bold = False + End With + + Dim i As Long + Dim colNum As Long + + Dim hashName As String + Dim colLabel As String + Dim colName As String + + Dim lastRow As Long + lastRow = Worksheets(shMSSlist3).Cells(Rows.count, 3).End(xlUp).Row + + hashName = "AttachmentsHash" + + For i = 4 To lastRow + colLabel = Worksheets(shMSSlist3).Cells(i, 2).value + colName = Worksheets(shMSSlist3).Cells(i, 3).value + colNum = Worksheets(shMSSlist3).Cells(i, 4).value + + If res("Response")("Data")(1)(hashName).Exists(colName) = True Then + Dim k As Long + For k = 1 To res("Response")("Data")(1)(hashName)(colName).count + Dim l As Long + l = (k - 1) * 2 + + 'Ytt@CXg + Worksheets(shMSSlist3).Cells(k + 3, colNum) = res("Response")("Data")(1)(hashName)(colName)(k)("Guid") + Worksheets(shMSSlist3).Cells(k + 3, colNum + 1) = res("Response")("Data")(1)(hashName)(colName)(k)("Name") + Next k + + End If + Next i + + +End Function + diff --git a/XVBA/MSS/■MSSツール/vba-files/Module/Module6.bas b/XVBA/MSS/■MSSツール/vba-files/Module/Module6.bas new file mode 100644 index 00000000..f55b4db0 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Module/Module6.bas @@ -0,0 +1,390 @@ +Attribute VB_Name = "Module6" +Option Explicit + +'evmFf[^C|[g +Sub getArariDataTest() + Application.ScreenUpdating = False 'ʍXV~ + Application.Calculation = xlManual 'vZ~ + + Call init + 'Debug.Print ">>> evmF̃_E[h Jn" + + Dim resultId As String + resultId = Range("ResultId").value + + If resultId <> "" Then + 'Debug.Print resultId + Call getArariDataRequest(resultId) + + End If + + Application.Calculation = xlAutomatic 'vZJn + Application.ScreenUpdating = True 'ʍXVJn + 'Debug.Print "<<< evmF̃_E[h I" +End Sub + +'MSS}X^[V[gIDw肵āAevmF̃f[^擾 +Function getArariDataRequest(classA) + 'ʕϐ + Dim apiUrl As String + Dim apiUrlParam As String + Dim tableId As String + + 'evmFe[uID + tableId = "189113" + + 'NGXgURL + apiUrl = baseURL & "/pleasanter/api/items/" & tableId & "/" + apiUrlParam = "Get" + + 'wb_ + Dim apiHeaders As New Dictionary + apiHeaders.Add "Content-Type", "application/json;charset=utf-8" + + 'NGXgf[^ + Dim apiBody As New Dictionary + apiBody.Add "ApiVersion", "1.1" + apiBody.Add "ApiKey", apiKey + + 'Filterϐ + Dim colFilter As New Dictionary + colFilter.Add "ClassA", "[" & classA & "]" + + 'Viewϐ + Dim view As New Dictionary + view.Add "ColumnFilterHash", colFilter + apiBody.Add "View", view + + 'HTTPNGXgM\bhĂяo + Dim res As Object + Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody) + + 'Debug.Print res("StatusCode") + 'Debug.Print res("Response")("TotalCount") + + If res("StatusCode") = 200 And res("Response")("TotalCount") = 1 Then + 'O[oϐ֏i[ + 'Debug.Print res("StatusCode") + ''Debug.Print res("Response")("TotalCount") + ''Debug.Print res("Response")("Data")(1)("DescriptionHash")("DescriptionA") + + 'Ɏ擾łV[g֏ + 'Debug.Print "evmF 擾" + Call exportArariData(res) + End If + + +End Function + +'evf[^V[gɏo͂ +Function exportArariData(res) + 'Debug.Print "<< evmF o͊Jn" + + Dim arariSh + + 'f[^̃NA + Set arariSh = Worksheets("evmF({_)") + arariSh.Range("F11:G11").ClearContents '{̋z + arariSh.Range("C12:G21").ClearContents 'tэH + arariSh.Range("L24").ClearContents 'v(%) + arariSh.Range("C25:I34").ClearContents '{̍H悹 + arariSh.Range("C37:I46").ClearContents 'mtя悹 + arariSh.Range("C49:I58").ClearContents 'T[rX + arariSh.Range("G59:I59").ClearContents 'Љ + arariSh.Range("F60:G60").ClearContents 'l + arariSh.Range("C63:I72").ClearContents '̑H + arariSh.Range("G80").ClearContents 'ώZ`FbN ljύX + + Set arariSh = Worksheets("evmF(݌v_)") + arariSh.Range("F11:G11").ClearContents '{̋z + arariSh.Range("C12:G21").ClearContents 'tэH + arariSh.Range("L24").ClearContents 'v(%) + arariSh.Range("C25:I34").ClearContents '{̍H悹 + arariSh.Range("C37:I46").ClearContents 'mtя悹 + arariSh.Range("C49:I58").ClearContents 'T[rX + arariSh.Range("G59:I59").ClearContents 'Љ + arariSh.Range("F60:G60").ClearContents 'l + arariSh.Range("C63:I72").ClearContents '̑H + arariSh.Range("G80").ClearContents 'ώZ`FbN ljύX + + '{_evmFi[ϐ + Dim descA, descB, desc002, descD, descF, descH, descI, descJ, descL, desc008 As String + Dim descAdata, descBdata, desc002data, descDdata, descFdata, descHdata, descIdata, descJdata, descLdata, desc008data As Object + descA = res("Response")("Data")(1)("DescriptionHash")("DescriptionA") 'A.{̉i + descB = res("Response")("Data")(1)("DescriptionHash")("DescriptionB") 'B.tэ + desc002 = res("Response")("Data")(1)("DescriptionHash")("Description002") '002.v1 + descD = res("Response")("Data")(1)("DescriptionHash")("DescriptionD") 'D.{̍H悹 + descF = res("Response")("Data")(1)("DescriptionHash")("DescriptionF") 'F.mtэH + descH = res("Response")("Data")(1)("DescriptionHash")("DescriptionH") 'H.T[rX + descI = res("Response")("Data")(1)("DescriptionHash")("DescriptionI") 'I.Љ + descJ = res("Response")("Data")(1)("DescriptionHash")("DescriptionJ") 'J.T[rX l + descL = res("Response")("Data")(1)("DescriptionHash")("DescriptionL") 'L.̑H + desc008 = res("Response")("Data")(1)("DescriptionHash")("Description008") '008.ώZ`FbN + + Set descAdata = JsonConverter.ParseJson(descA) + Set descBdata = JsonConverter.ParseJson(descB) + Set desc002data = JsonConverter.ParseJson(desc002) + Set descDdata = JsonConverter.ParseJson(descD) + Set descFdata = JsonConverter.ParseJson(descF) + Set descHdata = JsonConverter.ParseJson(descH) + Set descIdata = JsonConverter.ParseJson(descI) + Set descJdata = JsonConverter.ParseJson(descJ) + Set descLdata = JsonConverter.ParseJson(descL) + Set desc008data = JsonConverter.ParseJson(desc008) + + Dim xx As Long + Dim value + + '{_evmF + Set arariSh = Worksheets("evmF({_)") + arariSh.Cells(1, 18) = res("Response")("Data")(1)("ResultId") + '------------------------------------------------------------ + '{̋z + xx = 11 + For Each value In descAdata + arariSh.Cells(xx, 6) = value("1") + arariSh.Cells(xx, 7) = value("2") + xx = xx + 1 + Next value + '------------------------------------------------------------ + 'tэH + xx = 12 + For Each value In descBdata + arariSh.Cells(xx, 3) = value("0") + arariSh.Cells(xx, 6) = value("1") + arariSh.Cells(xx, 7) = value("2") + xx = xx + 1 + If xx = 22 Then + Exit For + End If + Next value + '------------------------------------------------------------ + 'v1 v + xx = 24 + For Each value In desc002data + arariSh.Cells(xx, 12) = value("7") + xx = xx + 1 + Next value + '------------------------------------------------------------ + '{̍H悹 + xx = 25 + For Each value In descDdata + arariSh.Cells(xx, 3) = value("0") + arariSh.Cells(xx, 6) = value("1") + arariSh.Cells(xx, 7) = value("2") + arariSh.Cells(xx, 8) = value("3") + arariSh.Cells(xx, 9) = value("4") + xx = xx + 1 + If xx = 35 Then + Exit For + End If + Next value + '------------------------------------------------------------ + 'mtя悹 + xx = 37 + For Each value In descFdata + arariSh.Cells(xx, 3) = value("0") + arariSh.Cells(xx, 6) = value("1") + arariSh.Cells(xx, 7) = value("2") + arariSh.Cells(xx, 8) = value("3") + arariSh.Cells(xx, 9) = value("4") + xx = xx + 1 + If xx = 47 Then + Exit For + End If + Next value + '------------------------------------------------------------ + 'T[rX + xx = 49 + For Each value In descHdata + arariSh.Cells(xx, 3) = value("0") + arariSh.Cells(xx, 6) = value("1") + arariSh.Cells(xx, 7) = value("2") + arariSh.Cells(xx, 8) = value("3") + arariSh.Cells(xx, 9) = value("4") + xx = xx + 1 + If xx = 59 Then + Exit For + End If + Next value + '------------------------------------------------------------ + 'Љ + xx = 59 + For Each value In descIdata + arariSh.Cells(xx, 7) = value("2") + arariSh.Cells(xx, 8) = value("3") + arariSh.Cells(xx, 9) = value("4") + xx = xx + 1 + Next value + '------------------------------------------------------------ + 'l + xx = 60 + For Each value In descJdata + arariSh.Cells(xx, 6) = value("1") + arariSh.Cells(xx, 7) = value("2") + xx = xx + 1 + Next value + '------------------------------------------------------------ + '̑ + xx = 63 + For Each value In descLdata + arariSh.Cells(xx, 3) = value("0") + arariSh.Cells(xx, 6) = value("1") + arariSh.Cells(xx, 7) = value("2") + arariSh.Cells(xx, 8) = value("3") + arariSh.Cells(xx, 9) = value("4") + xx = xx + 1 + If xx = 73 Then + Exit For + End If + Next value + '------------------------------------------------------------ + 'ώZ`FbN + xx = 80 + For Each value In desc008data + arariSh.Cells(xx, 7) = value("2") + xx = xx + 1 + Next value + + '------------------------------------------------------------ + '݌v_evmFi[ϐ + Dim desc021, desc022, desc042, desc024, desc026, desc028, desc029, desc030, desc032, desc048 As String + + desc021 = res("Response")("Data")(1)("DescriptionHash")("Description021") 'S_A.{̉i + desc022 = res("Response")("Data")(1)("DescriptionHash")("Description022") 'S_B.tэ + desc042 = res("Response")("Data")(1)("DescriptionHash")("Description042") 'v1 + desc024 = res("Response")("Data")(1)("DescriptionHash")("Description024") 'S_D.{̍H悹 + desc026 = res("Response")("Data")(1)("DescriptionHash")("Description026") 'S_F.mtэH + desc028 = res("Response")("Data")(1)("DescriptionHash")("Description028") 'S_H.T[rX + desc029 = res("Response")("Data")(1)("DescriptionHash")("Description029") 'S_I.Љ + desc030 = res("Response")("Data")(1)("DescriptionHash")("Description030") 'S_J.T[rX l + desc032 = res("Response")("Data")(1)("DescriptionHash")("Description032") 'S_L.̑H + desc048 = res("Response")("Data")(1)("DescriptionHash")("Description048") '048.ώZ`FbN + + Set descAdata = JsonConverter.ParseJson(desc021) + Set descBdata = JsonConverter.ParseJson(desc022) + Set desc002data = JsonConverter.ParseJson(desc042) + Set descDdata = JsonConverter.ParseJson(desc024) + Set descFdata = JsonConverter.ParseJson(desc026) + Set descHdata = JsonConverter.ParseJson(desc028) + Set descIdata = JsonConverter.ParseJson(desc029) + Set descJdata = JsonConverter.ParseJson(desc030) + Set descLdata = JsonConverter.ParseJson(desc032) + Set desc008data = JsonConverter.ParseJson(desc048) + + '݌v_evmF + Set arariSh = Worksheets("evmF(݌v_)") + arariSh.Cells(1, 18) = res("Response")("Data")(1)("ResultId") + '------------------------------------------------------------ + '{̋z + xx = 11 + For Each value In descAdata + arariSh.Cells(xx, 6) = value("1") + arariSh.Cells(xx, 7) = value("2") + xx = xx + 1 + Next value + '------------------------------------------------------------ + 'tэH + xx = 12 + For Each value In descBdata + arariSh.Cells(xx, 3) = value("0") + arariSh.Cells(xx, 6) = value("1") + arariSh.Cells(xx, 7) = value("2") + xx = xx + 1 + If xx = 22 Then + Exit For + End If + Next value + '------------------------------------------------------------ + 'v1 v + xx = 24 + For Each value In desc002data + arariSh.Cells(xx, 12) = value("7") + xx = xx + 1 + Next value + '------------------------------------------------------------ + '{̍H悹 + xx = 25 + For Each value In descDdata + arariSh.Cells(xx, 3) = value("0") + arariSh.Cells(xx, 6) = value("1") + arariSh.Cells(xx, 7) = value("2") + arariSh.Cells(xx, 8) = value("3") + arariSh.Cells(xx, 9) = value("4") + xx = xx + 1 + If xx = 35 Then + Exit For + End If + Next value + '------------------------------------------------------------ + 'mtя悹 + xx = 37 + For Each value In descFdata + arariSh.Cells(xx, 3) = value("0") + arariSh.Cells(xx, 6) = value("1") + arariSh.Cells(xx, 7) = value("2") + arariSh.Cells(xx, 8) = value("3") + arariSh.Cells(xx, 9) = value("4") + xx = xx + 1 + If xx = 47 Then + Exit For + End If + Next value + '------------------------------------------------------------ + 'T[rX + xx = 49 + For Each value In descHdata + arariSh.Cells(xx, 3) = value("0") + arariSh.Cells(xx, 6) = value("1") + arariSh.Cells(xx, 7) = value("2") + arariSh.Cells(xx, 8) = value("3") + arariSh.Cells(xx, 9) = value("4") + xx = xx + 1 + If xx = 59 Then + Exit For + End If + Next value + '------------------------------------------------------------ + 'Љ + xx = 59 + For Each value In descIdata + arariSh.Cells(xx, 7) = value("2") + arariSh.Cells(xx, 8) = value("3") + arariSh.Cells(xx, 9) = value("4") + xx = xx + 1 + Next value + '------------------------------------------------------------ + 'l + xx = 60 + For Each value In descJdata + arariSh.Cells(xx, 6) = value("1") + arariSh.Cells(xx, 7) = value("2") + xx = xx + 1 + Next value + '------------------------------------------------------------ + '̑ + xx = 63 + For Each value In descLdata + arariSh.Cells(xx, 3) = value("0") + arariSh.Cells(xx, 6) = value("1") + arariSh.Cells(xx, 7) = value("2") + arariSh.Cells(xx, 8) = value("3") + arariSh.Cells(xx, 9) = value("4") + xx = xx + 1 + If xx = 73 Then + Exit For + End If + Next value + '------------------------------------------------------------ + 'ώZ`FbN + xx = 80 + For Each value In desc008data + arariSh.Cells(xx, 7) = value("2") + xx = xx + 1 + Next value + + '------------------------------------------------------------ + + 'Debug.Print "<< evmF o͊" + +End Function diff --git a/XVBA/MSS/■MSSツール/vba-files/Module/Module7.bas b/XVBA/MSS/■MSSツール/vba-files/Module/Module7.bas new file mode 100644 index 00000000..8a45bbc8 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Module/Module7.bas @@ -0,0 +1,242 @@ +Attribute VB_Name = "Module7" +Option Explicit + +'[h^CAHvZf[^C|[g + +Sub getOtherData() + Application.ScreenUpdating = False 'ʍXV~ + Application.Calculation = xlManual 'vZ~ + + Call init + 'Debug.Print ">>> ֘Ae[ũ_E[h Jn" + + Dim resultId As String + resultId = Range("ResultId").value + + If resultId <> "" Then + '[h^Cf[^擾 + 'Debug.Print ">> [h^Cf[^擾Jn" + Call getOtherTableData(resultId, "116503", "R") + 'Debug.Print "<< [h^Cf[^擾" + + 'HvZf[^擾 + 'Debug.Print ">> HvZf[^擾Jn" + Call getOtherTableData(resultId, "203147", "K") + 'Debug.Print "<< HvZf[^擾" + + 'ljύXWFf[^擾 + 'Debug.Print ">> ljύXWFf[^擾Jn" + Call getOtherTableData(resultId, "212533", "T") + 'Debug.Print "<< ljύXWFf[^擾" + + Call getArariDataRequest(resultId) + + End If + + Application.Calculation = xlAutomatic 'vZJn + Application.ScreenUpdating = True 'ʍXVJn + 'Debug.Print "<<< ֘Ae[ũ_E[h I" +End Sub + + + +'MSS}X^[V[gIDw肵āA֘Ae[uo擾 +Function getOtherTableData(classA, targetId, shName) + 'ʕϐ + Dim apiUrl As String + Dim apiUrlParam As String + Dim tableId As String + + '[h^Ce[uID + tableId = targetId + + 'NGXgURL + apiUrl = baseURL & "/pleasanter/api/items/" & tableId & "/" + apiUrlParam = "Get" + + 'wb_ + Dim apiHeaders As New Dictionary + apiHeaders.Add "Content-Type", "application/json;charset=utf-8" + + 'NGXgf[^ + Dim apiBody As New Dictionary + apiBody.Add "ApiVersion", "1.1" + apiBody.Add "ApiKey", apiKey + + 'Filterϐ + Dim colFilter As New Dictionary + colFilter.Add "ClassA", "[" & classA & "]" + + 'Viewϐ + Dim view As New Dictionary + view.Add "ColumnFilterHash", colFilter + apiBody.Add "View", view + + 'HTTPNGXgM\bhĂяo + Dim res As Object + Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody) + + 'Debug.Print res("StatusCode") + 'Debug.Print res("Response")("TotalCount") + + If res("StatusCode") = 200 Then + 'O[oϐ֏i[ + 'Debug.Print res("StatusCode") + + 'Ɏ擾łV[g֏ + 'Debug.Print "<<< f[^擾" + Call exportDataToSheet(res, shName) + End If + + +End Function + +Function exportDataToSheet(res, shName) + 'Debug.Print ">>> f[^o͊Jn" + Dim sh As Worksheet + Set sh = Worksheets(shName) + + 'V[gNA + sh.Cells.Clear + + Dim data As New Dictionary + Dim value + Dim i, j As Long + + i = 1 + For Each value In res("Response")("Data") + data.Add "ResultId", value("ResultId") + data.Add "Status", value("Status") + data.Add "ItemTitle", value("ItemTitle") + data.Add "Updator", value("Updator") + data.Add "UpdatedTime", stringToDate(value("UpdatedTime")) + data.Add "Body", value("Body") + + Dim keys, items, count + + 'Class + keys = value("ClassHash").keys + items = value("ClassHash").items + count = value("ClassHash").count + For j = 0 To count - 1 + data.Add keys(j), items(j) + Next j + 'Num + keys = value("NumHash").keys + items = value("NumHash").items + count = value("NumHash").count + For j = 0 To count - 1 + data.Add keys(j), items(j) + Next j + 'Date + keys = value("DateHash").keys + items = value("DateHash").items + count = value("DateHash").count + For j = 0 To count - 1 + data.Add keys(j), stringToDate(items(j)) + Next j + 'Description + keys = value("DescriptionHash").keys + items = value("DescriptionHash").items + count = value("DescriptionHash").count + For j = 0 To count - 1 + data.Add keys(j), items(j) + Next j + 'Check + keys = value("CheckHash").keys + items = value("CheckHash").items + count = value("CheckHash").count + For j = 0 To count - 1 + data.Add keys(j), items(j) + Next j + + data.Add "Owner", value("Owner") + + + Dim k, itemCount As Long + itemCount = data.count + For k = 1 To itemCount + If (i) = 1 Then + sh.Cells((i), k) = data.keys(k - 1) + End If + + sh.Cells((i + 1), k) = data.items(k - 1) + Next k + + data.RemoveAll + + i = i + 1 + Next value + + 'Debug.Print "<<< f[^o͊" + +End Function + + + +'ׂĂ̒ljύXWF\f[^ij擾 +Sub getAllTsuihenList() + Application.ScreenUpdating = False 'ʍXV~ + Application.Calculation = xlManual 'vZ~ + + Call init + 'Debug.Print ">>> ׂĂ̒ljύXWF\f[^ij擾 Jn" + + Dim shName + shName = "T" + + 'ʕϐ + Dim apiUrl As String + Dim apiUrlParam As String + Dim tableId As String + + '[h^Ce[uID + tableId = "212533" + + 'NGXgURL + apiUrl = baseURL & "/pleasanter/api/items/" & tableId & "/" + apiUrlParam = "Get" + + 'wb_ + Dim apiHeaders As New Dictionary + apiHeaders.Add "Content-Type", "application/json;charset=utf-8" + + 'NGXgf[^ + Dim apiBody As New Dictionary + apiBody.Add "ApiVersion", "1.1" + apiBody.Add "ApiKey", apiKey + + 'Filterϐ + Dim colFilter As New Dictionary + colFilter.Add "Status", "[100,101,200]" + + Dim colSorter As New Dictionary + colSorter.Add "Status", "desc" + + 'Viewϐ + Dim view As New Dictionary + view.Add "ColumnFilterHash", colFilter + view.Add "ColumnSorterHash", colSorter + apiBody.Add "View", view + + 'HTTPNGXgM\bhĂяo + Dim res As Object + Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody) + + 'Debug.Print res("StatusCode") + 'Debug.Print res("Response")("TotalCount") + + If res("StatusCode") = 200 Then + 'O[oϐ֏i[ + 'Debug.Print res("StatusCode") + + 'Ɏ擾łV[g֏ + 'Debug.Print "<<< f[^擾" + Call exportDataToSheet(res, shName) + End If + + Application.Calculation = xlAutomatic 'vZJn + Application.ScreenUpdating = True 'ʍXVJn + 'Debug.Print "<<< ׂĂ̒ljύXWF\f[^ij擾 I" + +End Sub diff --git a/XVBA/MSS/■MSSツール/vba-files/Module/Module8.bas b/XVBA/MSS/■MSSツール/vba-files/Module/Module8.bas new file mode 100644 index 00000000..927f8bd0 --- /dev/null +++ b/XVBA/MSS/■MSSツール/vba-files/Module/Module8.bas @@ -0,0 +1,292 @@ +Attribute VB_Name = "Module8" +Option Explicit + +'Xg_R[hI +Sub getTsuihenFiles() + 'Application.ScreenUpdating = False 'ʍXV~ + Application.Calculation = xlManual 'vZ~ + + Call init + 'Debug.Print ">>> IljύX\̊֘Af[^_E[h" + + Dim Ad As String 'Zԍpϐ + Dim Col As Integer 'Z̗ԍpϐ + Dim Row As Integer 'Z̍sԍpϐ + + Dim sh As Worksheet + Set sh = Worksheets(thList) + + Ad = ActiveCell.Address + Col = ActiveCell.Column + Row = ActiveCell.Row + + + 'e[u͈͖ɃJ[\ƂɃ{^A_R[h擾 + If Row >= 3 And Row <= 104 And Col >= 4 And Col <= 19 Then + Dim recoreId As Variant + recoreId = sh.Cells(Row, 5).value + + 'Debug.Print recoreId + + If recoreId <> 0 Then + Range("WFǕϐ\ID").value = recoreId + + 'Xg + With sh.Range("B11") + .ClearContents + .Hyperlinks.Delete + .Font.Color = RGB(0, 0, 0) + .Font.Underline = False + .Font.Bold = False + End With + + With sh.Range("B14:B113") + .ClearContents + .Hyperlinks.Delete + .Font.Color = RGB(0, 0, 0) + .Font.Underline = False + .Font.Bold = False + End With + + Call getTsuihenFilesRequest(recoreId) + + Else + Range("WFǕϐ\ID").value = "" + 'Xg + With sh.Range("B11") + .ClearContents + .Hyperlinks.Delete + .Font.Color = RGB(0, 0, 0) + .Font.Underline = False + .Font.Bold = False + End With + + With sh.Range("B14:B113") + .ClearContents + .Hyperlinks.Delete + .Font.Color = RGB(0, 0, 0) + .Font.Underline = False + .Font.Bold = False + End With + + MsgBox "擾R[hIĂ" + End If + Else + Range("WFǕϐ\ID").value = "" + MsgBox "擾R[hIĂ" + End If + + Application.Calculation = xlAutomatic 'vZJn + 'Application.ScreenUpdating = True 'ʍXVJn + 'Debug.Print "<<< IljύX\̊֘Af[^_E[hI܂" + +End Sub + +Function getTsuihenFilesRequest(targetId) + 'ʕϐ + Dim apiUrl As String + Dim apiUrlParam As String + Dim tableId As String + + '[h^Ce[uID + tableId = targetId + + 'NGXgURL + apiUrl = baseURL & "/pleasanter/api/items/" & tableId & "/" + apiUrlParam = "Get" + + 'wb_ + Dim apiHeaders As New Dictionary + apiHeaders.Add "Content-Type", "application/json;charset=utf-8" + + 'NGXgf[^ + Dim apiBody As New Dictionary + apiBody.Add "ApiVersion", "1.1" + apiBody.Add "ApiKey", apiKey + + 'HTTPNGXgM\bhĂяo + Dim res As Object + Set res = callRestApi("POST", apiUrl, apiUrlParam, apiHeaders, apiBody) + + 'Debug.Print res("StatusCode") + 'Debug.Print res("Response")("TotalCount") + + If res("StatusCode") = 200 Then + 'O[oϐ֏i[ + 'Debug.Print res("StatusCode") + 'Debug.Print res("Response")("TotalCount") + 'Ɏ擾łV[g֏ + 'Debug.Print "<<< ljύXf[^擾" + Call exporTsuihenFiles(res) + End If + + +End Function + +Function exporTsuihenFiles(res) + Dim sh As Worksheet + Set sh = Worksheets(thList) + + Dim hyplink As Hyperlink + + Dim tsuihenFolder As String + 'ljύXf[^ۑtH_ + tsuihenFolder = res("Response")("Data")(1)("ClassHash")("ClassM") + + 'Debug.Print currentDirPath & "\" & tsuihenFolder + + 'ڋqʃtH_݂邩mF + Dim fso As Object + Set fso = CreateObject("Scripting.FileSystemObject") + + 'ljύXۑtH_ + If Not fso.FolderExists(currentDirPath & "\" & tsuihenFolder) Then + 'Ȃꍇ̓tH_쐬 + fso.CreateFolder (currentDirPath & "\" & tsuihenFolder) + End If + + Dim file + Dim saveFolderPath As String + Dim guid As String + Dim name As String + Dim result As Boolean + + Dim xx As Long + xx = 14 + sh.Cells(xx, 2).value = "---_E[hJn---" + xx = xx + 1 + + sh.Cells(11, 2).value = tsuihenFolder + Set hyplink = sh.Hyperlinks.Add( _ + Anchor:=sh.Cells(11, 2), _ + Address:=tsuihenFolder) + + For Each file In res("Response")("Data")(1)("AttachmentsHash")("AttachmentsA") + saveFolderPath = currentDirPath & "\" & tsuihenFolder & "\" & "_񏑌{" + If Not fso.FolderExists(saveFolderPath) Then + 'Ȃꍇ̓tH_쐬 + fso.CreateFolder (saveFolderPath) + End If + guid = file("Guid") + name = file("Name") + '_E[h + result = getAttachmentsFile(guid, saveFolderPath) + + '_E[hۑ + If result = True Then + sh.Cells(xx, 2).value = "_񏑌{" & "\" & name + Set hyplink = sh.Hyperlinks.Add( _ + Anchor:=sh.Cells(xx, 2), _ + Address:=tsuihenFolder & "\" & "_񏑌{" & "\" & name) + + xx = xx + 1 + End If + + Next file + + For Each file In res("Response")("Data")(1)("AttachmentsHash")("AttachmentsB") + saveFolderPath = currentDirPath & "\" & tsuihenFolder & "\" & "z@" + If Not fso.FolderExists(saveFolderPath) Then + 'Ȃꍇ̓tH_쐬 + fso.CreateFolder (saveFolderPath) + End If + guid = file("Guid") + name = file("Name") + '_E[h + result = getAttachmentsFile(guid, saveFolderPath) + + '_E[hۑ + If result = True Then + sh.Cells(xx, 2).value = "z@" & "\" & name + Set hyplink = sh.Hyperlinks.Add( _ + Anchor:=sh.Cells(xx, 2), _ + Address:=tsuihenFolder & "\" & "z@" & "\" & name) + + xx = xx + 1 + End If + Next file + + For Each file In res("Response")("Data")(1)("AttachmentsHash")("AttachmentsC") + saveFolderPath = currentDirPath & "\" & tsuihenFolder & "\" & "zA" + If Not fso.FolderExists(saveFolderPath) Then + 'Ȃꍇ̓tH_쐬 + fso.CreateFolder (saveFolderPath) + End If + guid = file("Guid") + name = file("Name") + '_E[h + result = getAttachmentsFile(guid, saveFolderPath) + '_E[hۑ + If result = True Then + sh.Cells(xx, 2).value = "zA" & "\" & name + Set hyplink = sh.Hyperlinks.Add( _ + Anchor:=sh.Cells(xx, 2), _ + Address:=tsuihenFolder & "\" & "zA" & "\" & name) + + xx = xx + 1 + End If + Next file + + For Each file In res("Response")("Data")(1)("AttachmentsHash")("AttachmentsD") + saveFolderPath = currentDirPath & "\" & tsuihenFolder & "\" & "zB" + If Not fso.FolderExists(saveFolderPath) Then + 'Ȃꍇ̓tH_쐬 + fso.CreateFolder (saveFolderPath) + End If + guid = file("Guid") + name = file("Name") + '_E[h + result = getAttachmentsFile(guid, saveFolderPath) + If result = True Then + sh.Cells(xx, 2).value = "zB" & "\" & name + Set hyplink = sh.Hyperlinks.Add( _ + Anchor:=sh.Cells(xx, 2), _ + Address:=tsuihenFolder & "\" & "zB" & "\" & name) + + xx = xx + 1 + End If + Next file + + For Each file In res("Response")("Data")(1)("AttachmentsHash")("AttachmentsE") + saveFolderPath = currentDirPath & "\" & tsuihenFolder & "\" & "zC" + If Not fso.FolderExists(saveFolderPath) Then + 'Ȃꍇ̓tH_쐬 + fso.CreateFolder (saveFolderPath) + End If + guid = file("Guid") + name = file("Name") + '_E[h + result = getAttachmentsFile(guid, saveFolderPath) + If result = True Then + sh.Cells(xx, 2).value = "zC" & "\" & name + Set hyplink = sh.Hyperlinks.Add( _ + Anchor:=sh.Cells(xx, 2), _ + Address:=tsuihenFolder & "\" & "zC" & "\" & name) + + xx = xx + 1 + End If + Next file + + For Each file In res("Response")("Data")(1)("AttachmentsHash")("AttachmentsF") + saveFolderPath = currentDirPath & "\" & tsuihenFolder & "\" & "zD" + If Not fso.FolderExists(saveFolderPath) Then + 'Ȃꍇ̓tH_쐬 + fso.CreateFolder (saveFolderPath) + End If + guid = file("Guid") + name = file("Name") + '_E[h + result = getAttachmentsFile(guid, saveFolderPath) + If result = True Then + sh.Cells(xx, 2).value = "zD" & "\" & name + Set hyplink = sh.Hyperlinks.Add( _ + Anchor:=sh.Cells(xx, 2), _ + Address:=tsuihenFolder & "\" & "zD" & "\" & name) + + xx = xx + 1 + End If + Next file + + sh.Cells(xx, 2).value = "---_E[hI---" + +End Function diff --git a/XVBA/MSS/■MSSツール/xvba_modules/Xdebug/CHANGELOG.md b/XVBA/MSS/■MSSツール/xvba_modules/Xdebug/CHANGELOG.md new file mode 100644 index 00000000..f1f3ad96 --- /dev/null +++ b/XVBA/MSS/■MSSツール/xvba_modules/Xdebug/CHANGELOG.md @@ -0,0 +1,13 @@ +# Changelog +## Xdebug (Under Construction) + +- This package provides a way to simulate VBA Immediate Window in Output VSCode window + +## [1.0.0b0] - 2020-09-16 +### Added + - Create XDebug.printx + - Create XDebug.printError + + + + \ No newline at end of file diff --git a/XVBA/MSS/■MSSツール/xvba_modules/Xdebug/README.md b/XVBA/MSS/■MSSツール/xvba_modules/Xdebug/README.md new file mode 100644 index 00000000..9d8b74f0 --- /dev/null +++ b/XVBA/MSS/■MSSツール/xvba_modules/Xdebug/README.md @@ -0,0 +1,58 @@ +# Xdebug (VBA Immediate Window in Output VSCode Window) + +## Description + - This package provides a way to simulate VBA Immediate Window in Output VSCode window + - Find the Output window (VBA Immediate Window) + + ## Methods + +

+VBA immediate Window +

+ + + ### Xdebug.printx + +- This method print any type os variable + + +``` + +Public Sub index() + + + Dim test(1) As Variant + + 'Add an Object + Set test(0) = Sheets(1) + 'Add a String + test(1) = "Test Xdebug Output" + + Xdebug.printx test + +End Sub + +``` + + + ### Xdebug.printError + +- This method is use for print error + + +``` + Public Sub index() + + On Error GoTo ErrorHandle: + 'throw an error + d = 1/0 + 'Your code here + + + ErrorHandle: + Xdebug.errorSource = "pageConsoller.index" + Xdebug.printError + + End Sub +``` + diff --git a/XVBA/MSS/■MSSツール/xvba_modules/Xdebug/Xdebug.cls b/XVBA/MSS/■MSSツール/xvba_modules/Xdebug/Xdebug.cls new file mode 100644 index 00000000..dd1b1d3b --- /dev/null +++ b/XVBA/MSS/■MSSツール/xvba_modules/Xdebug/Xdebug.cls @@ -0,0 +1,241 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Xdebug" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False + +'namespace=xvba_modules\Xdebug + +Public env As String + +'Example of Package Create by XVBA-CLI + +Private OS_TMP__FOLDER_PATH As String + +Private IMMEDIATE_FOLDER As String + +Private IMMEDIATE_FILE As String + +Private DEBUG_FILE_PATH As String + +Const EMPTY_TYPE = 0 +Const NULL_TYPE = 1 +Const ERROR_TYPE = 10 +Const INTEGER_TYPE = 2 +Const LONG_TYPE = 3 +Const SINGLE_TYPE = 4 +Const DOUBLE_TYPE = 5 +Const CURRENCY_TYPE = 6 +Const DATE_TYPE = 7 +Const DECIMAL_TYPE = 14 +Const LONG_LONG_TYPE = 20 +Const BOOLEAN_TYPE = 11 +Const STRING_TYPE = 8 +Const ARRAY_TYPE = 8204 +Const OBJECT_TYPE = 9 +Const VARIANT_TYPE = 12 +Const DATA_OBJECT_TYPE = 13 +Private Const MESSAGE_SPACE = " " + +Public errorSource As String +Public errorTitle As String + +'/* +'Flag for Actrive os Deactive VBA Debug.Print +'*/ +Public vbaDebugPrintActive As Boolean + +Private Sub class_initialize() + + Dim fso As Object + Set fso = CreateObject("Scripting.FileSystemObject") + OS_TMP__FOLDER_PATH = fso.GetSpecialFolder(2) + IMMEDIATE_FOLDER = "xvba_immediate" + IMMEDIATE_FILE = "immediate.txt" + vbaDebugPrintActive = True + errorSource = "" + errorTitle = "XVBA: New Error Was Found" + env = "DEV" + + DEBUG_FILE_PATH = OS_TMP__FOLDER_PATH & "\" & IMMEDIATE_FOLDER & "\" & IMMEDIATE_FILE + +End Sub + + + + +Public Function printx(inputValue As Variant, Optional messageType As Integer = 1) + + If (env = "DEV") Then + Dim messageText As String + + messageText = createOutputMessage(inputValue) + + Call writeDebugFileContent(messageText, messageType) + End If +End Function + +'/* +'Print A Error +' +'*/ +Public Function printError() + If (env = "DEV") Then + + Dim message As String + + message = ErrorHanddler() + + Call writeDebugFileContent(message, 0) + + End If +End Function + + +'/* +' +'Write Debug ino on File +' +' +'*/ +Private Function writeDebugFileContent(messageText, messageType) + + Dim filePath As String + Dim FileNum As Integer + Dim PREFIX As String + + filePath = DEBUG_FILE_PATH + + FileNum = FreeFile + + PREFIX = Now & " - " + + Open filePath For Append As #FileNum + + Dim debugMessage As String + Select Case messageType + + Case 0 'Error Message + + debugMessage = PREFIX & "Error:" & messageText + Case 1 'Success + debugMessage = PREFIX & messageText + Case Else 'No Type Set + + debugMessage = PREFIX & "Info:" & messageText + End Select + + Print #FileNum, debugMessage + + Close #FileNum + + If (vbaDebugPrintActive) Then + + Debug.Print debugMessage + + End If +End Function + + +Private Function createOutputMessage(inputValue) As String + + Dim typeOfVar As Integer + Dim response As String + + typeOfVar = VarType(inputValue) + + + 'Set Error Source Macro/Function name + Err.Source = "createOutputMessage" + Select Case typeOfVar + Case STRING_TYPE + response = "String: " & inputValue + Case INTEGER_TYPE + response = "Integer: " & CStr(inputValue) + Case LONG_TYPE + response = "Long: " & CStr(inputValue) + Case SINGLE_TYPE + response = "Single: " & CStr(inputValue) + Case DOUBLE_TYPE + response = "Double: " & CStr(inputValue) + Case CURRENCY_TYPE + response = "Currenty: " & CStr(inputValue) + Case DATE_TYPE + response = "Date: " & CStr(inputValue) + Case DECIMAL_TYPE + response = "Decimal: " & CStr(inputValue) + Case LONG_LONG_TYPE + response = "LongLong: " & CStr(inputValue) + Case BOOLEAN_TYPE + response = "Boolean: " & CStr(inputValue) + Case ARRAY_TYPE + response = makeArrayTypeMessage(inputValue) + Case EMPTY_TYPE + response = "Empty: " + Case OBJECT_TYPE + response = "Object: " & TypeName(inputValue) + Case NULL_TYPE + response = "Null: " + Case ERROR_TYPE + response = "Error: " + Case VARIANT_TYPE + response = "Variant: " + Case DATA_OBJECT_TYPE + response = "Data Object: " & TypeName(inputValue) + Case Else + response = "Type Not Supported yet please inform xvba developer " + Debug.Print typeOfVar + Debug.Print inputValue + + End Select + + + createOutputMessage = response + +End Function + + +Private Function makeArrayTypeMessage(inputValue) As String + Dim nextItem As Variant + Dim response As String + Dim message As String + + For Each nextItem In inputValue + message = createOutputMessage(nextItem) + response = response & " [ " & message & " ]" & vbCrLf + Next nextItem + makeArrayTypeMessage = "Array: " & vbCrLf & response +End Function + + + +Private Function ErrorHanddler() As String + Dim errorDescription As String + Dim numberDescription As String + Dim lineError As String + Dim sourceError As String + Dim errorTitleMsg As String + Dim errorSourceMsg As String + + errorTitleMsg = vbCrLf & MESSAGE_SPACE & errorTitle + errorSourceMsg = vbCrLf & MESSAGE_SPACE & "Error Source: " & errorSource + + + Select Case Err.Number + Case 11 + numberDescription = vbCrLf & MESSAGE_SPACE & "Error Number: " & Err.Number + lineError = vbCrLf & MESSAGE_SPACE & "Error Line: " & Erl + errorDescription = vbCrLf & MESSAGE_SPACE & "Error Description: " & Err.Description + Case Else + numberDescription = vbCrLf & MESSAGE_SPACE & "Error Number: " & Err.Number + errorDescription = vbCrLf & MESSAGE_SPACE & "Error Description: " & Err.Description + End Select + + + ErrorHanddler = errorTitleMsg & lineError & errorSourceMsg & numberDescription & errorDescription + +End Function diff --git a/XVBA/MSS/■MSSツール/xvba_modules/Xdebug/images/immediate.gif b/XVBA/MSS/■MSSツール/xvba_modules/Xdebug/images/immediate.gif new file mode 100644 index 00000000..dd641693 Binary files /dev/null and b/XVBA/MSS/■MSSツール/xvba_modules/Xdebug/images/immediate.gif differ diff --git a/XVBA/MSS/■MSSツール/xvba_modules/Xdebug/xvba.package.json b/XVBA/MSS/■MSSツール/xvba_modules/Xdebug/xvba.package.json new file mode 100644 index 00000000..4a1da537 --- /dev/null +++ b/XVBA/MSS/■MSSツール/xvba_modules/Xdebug/xvba.package.json @@ -0,0 +1,15 @@ +{ + "package": "Xdebug", + "version": "1.0.0", + "author": "Alberto Edaurdo", + "email": "alberto.aeraphe@gmail.com", + "license": "ISC", + "repository": { + "type": "git", + "url": "https://github.com/Aeraphe/xdebug.git" + }, + "description": "Creating amazing XVBA packages", + "dependencies": {}, + "dev_dependencies": {}, + "homepage": "www.xvba.dev" +} \ No newline at end of file diff --git a/XVBA/MSS/■MSSツール/xvba_modules/excel-types/CHANGELOG.md b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/CHANGELOG.md new file mode 100644 index 00000000..39a71ff4 --- /dev/null +++ b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/CHANGELOG.md @@ -0,0 +1,8 @@ +# Changelog +## excel@types (Under Construction) + +- This package provides a way to use auto-complete for excel class + + + + \ No newline at end of file diff --git a/XVBA/MSS/■MSSツール/xvba_modules/excel-types/README.md b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/README.md new file mode 100644 index 00000000..dcf0411e --- /dev/null +++ b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/README.md @@ -0,0 +1,51 @@ +# Excel VBA type Definitions Package (excel-types) + + - This package provides a way to use auto-complete for Excel VBA Class + - You can Create your own vba type definition packages our update this. + - Type definition packages are named like: name-types + - The packages are store in www.xvba.dev + - Ech excel vba class has your own file definition + - The files extension has to be filename.d.vb + - Auto-complete just expose Public types + + +## Create,install and share VBA Packages With Xvba-cli and Xvba Repository: + +- Xvba Repository : www.xvba.dev +- XVBA-CLI Command Line Interface for XVBA VSCode extension @localsmart/xvba-cli + +## Install + +- For instal excel-types just use XVBA-CLI install command + +``` + npx xvba install excel-types +``` +## Comments Block + +- Use comments blocks below for documenting class/methods/Subs/Functions/Properties +- The comments blocs has to start with '/* and ends with '*/ + +``` + +'/* +'Represents the entire Microsoft Excel application. +' +' +'*/ +Public Class Application() + +``` + +``` +'/* +'Returns a Range object that represents the active cell in the active window +'(the window on top) or in the specified window. If the window isn't displaying +'a worksheet, this property fails. Read-only. +' +'@type {Object.} +' +'*/ +Public Property ActiveCell As Range + +``` \ No newline at end of file diff --git a/XVBA/MSS/■MSSツール/xvba_modules/excel-types/application.d.vb b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/application.d.vb new file mode 100644 index 00000000..af74a242 --- /dev/null +++ b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/application.d.vb @@ -0,0 +1,147 @@ +'/* +'Represents the entire Microsoft Excel application. +' +' +'*/ +Public Class Application() + +'/* +'Returns an object that represents the active sheet (the sheet on top) +'in the active workbook or in the specified window or workbook. +'Returns Nothing if no sheet is active. +' +'*/ +Public Property ActiveSheet As Worksheet + +'/* +'Returns a Workbook object that represents the workbook in the +'active window (the window on top). +'Returns Nothing if there are no windows open or if either +'the Info window or the Clipboard window is the active window. Read-only. +' +' +'*/ +Public Property ActiveWorkbook As Workbook + +'/* +'True if Microsoft Excel displays certain alerts and messages while +'a macro is running. Read/write Boolean. +' +'Example +'Application.DisplayAlerts = False +'Workbooks("BOOK1.XLS").Close +'Application.DisplayAlerts = True +' +'*/ +Public Property DisplayAlerts As Boolean + + +'/* +'Returns or sets an XlCalculation value that represents the calculation mode. +' +'Example +'Application.Calculation = xlCalculationManual +'Application.Calculation = xlAutomatic +' +'@type {XlCalculation} +'*/ +Public Property Calculation As XlCalculation + +'/* +'True if events are enabled for the specified object. Read/write Boolean. +' +'@type {Boolean} +'*/ +Public Property EnableEvents As Boolean + +'/* +'True if screen updating is turned on. Read/write Boolean. +'@type {Boolean} +'*/ +Public Property ScreenUpdating As Boolean + + +'/* +'Returns a Range object that represents the active cell in the active window +'(the window on top) or in the specified window. If the window isn't displaying +'a worksheet, this property fails. Read-only. +' +'@type {Object.} +' +'*/ +Public Property ActiveCell As Range + +'/* +'Returns a Chart object that represents the active chart (either an embedded chart or a chart sheet). +'An embedded chart is considered active when it's either selected or activated. When no chart is active, +'this property returns Nothing. +' +'Example: +'ActiveChart.HasLegend = True +' +'@type {Object.} +'*/ +Public Property ActiveChart As Chart + +'/* +'Returns a Workbooks collection that represents all the open workbooks. Read-only. +' +'@type {Object.} Workbooks Collection +'*/ +Public Property ThisWorkbook As Workbook + +'/* +'Returns a Workbooks collection that represents all the open workbooks. Read-only. +' +'@type {Object.} Workbooks Collection +'*/ +Public Property Workbooks As Workbooks + +'/* +'Activates a Microsoft application. If the application is already running, +'this method activates the running application. +'If the application isn't running, this method starts a new instance of the application. +' +'Example: (This example starts and activates Word.) +' +'Application.ActivateMicrosoftApp xlMicrosoftWord +' +'@param {XlMSApplication} index +'*/ +Public Sub ActivateMicrosoftApp( index As XlMSApplication) + +End Sub + +'/* +'An event occurs when all pending refresh activity (both synchronous and asynchronous) +'and all of the resultant calculation activities have been completed. +' +'*/ +Public Event AfterCalculate() + +'/* +'Occurs when a new workbook is created. +' +'Example: +' +'Private Sub App_NewWorkbook(ByVal Wb As Workbook) +'Application.Windows.Arrange xlArrangeStyleTiled End Sub +' +'@param {Workbook} Wb +'*/ +Public Event NewWorkbook(ByVal Wb As Workbook) + +'/* +'Returns a Sheets collection that represents all the sheets in the specified workbook. Read-only Sheets object. +' +'Example: +'Set newSheet = Sheets.Add(Type:=xlWorksheet) +'For i = 1 To Sheets.Count +' newSheet.Cells(i, 1).Value = Sheets(i).Name +' Next i +' +'@type {Sheets} +'*/ +Public Property Sheets As Worksheets + +End Class \ No newline at end of file diff --git a/XVBA/MSS/■MSSツール/xvba_modules/excel-types/dictionary.d.vb b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/dictionary.d.vb new file mode 100644 index 00000000..6a580711 --- /dev/null +++ b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/dictionary.d.vb @@ -0,0 +1,109 @@ + + + +'/* +' +' +' +'/* +Public Class Scripting() + + +'/* +' +'Object that stores data key/item pairs. +' +'/* +Public Function Dictionary() + +End Function + +'/* +' +'Adds a new key/item pair to a Dictionary object. +' +'*/ +Public Sub Add() + +End Sub + +'/* +' +'Returns a Boolean value that indicates whether a specified key exists in the Dictionary object. +' +'*/ +Public Sub Exists() + +End Sub + +'/* +' +'Returns an array of all the items in a Dictionary object. +' +'*/ +Public Sub Items() + +End Sub + +'/* +' +'Returns an array of all the keys in a Dictionary object. +' +'*/ +Public Sub Keys() + +End Sub + +'/* +' +'Removes one specified key/item pair from the Dictionary object. +' +'*/ +Public Sub Remove() + +End Sub + +'/* +' +'Removes all the key/item pairs in the Dictionary object. +' +'*/ +Public Sub RemoveAll() + +End Sub + + + +'/* +'Sets or returns the comparison mode for comparing keys in a Dictionary object. +' +' +'*/ +Public Property CompareMode As Variant + + +'/* +'Returns the number of key/item pairs in a Dictionary object. +' +' +'*/ +Public Property Count As Long + + +'/* +'Sets or returns the value of an item in a Dictionary object. +' +' +'*/ +Public Property Item As Variant + +'/* +'Sets a new key value for an existing key value in a Dictionary object. +' +' +'*/ +Public Property Key As Variant + + + +End Class \ No newline at end of file diff --git a/XVBA/MSS/■MSSツール/xvba_modules/excel-types/err.d.vb b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/err.d.vb new file mode 100644 index 00000000..7115cac1 --- /dev/null +++ b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/err.d.vb @@ -0,0 +1,30 @@ +'/* +'Contains information about run-time errors. +' +' +'*/ +Public Class Err() + +'/* +'Returns or sets a string expression containing a +'descriptive string associated with an object. Read/write. +' +'*/ +Public Property Description As String + +'/* +'Returns or sets a numeric value specifying an error. +'Number is the Err object's default property. Read/write. +' +'*/ +Public Property Number As Integer + + +'/* +'Returns or sets a string expression specifying the name of +'the object or application that originally generated the error. Read/write. +' +'*/ +Public Property Source As String + +End Class \ No newline at end of file diff --git a/XVBA/MSS/■MSSツール/xvba_modules/excel-types/functions.d.vb b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/functions.d.vb new file mode 100644 index 00000000..38aba162 --- /dev/null +++ b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/functions.d.vb @@ -0,0 +1,547 @@ + +'/* +'[Conversion Func] +' +'*/ +Function Asc() +End Function + +'/* +'[Conversion Func] +'Returns a String containing the character associated +'with the specified character code. +' +'Example: +' +'Dim MyChar +'MyChar = Chr(65) ' Returns A. +'MyChar = Chr(97) ' Returns a. +'MyChar = Chr(62) ' Returns >. +'MyChar = Chr(37) ' Returns %. +'*/ +Function Chr() +End Function + +'/* +'[Conversion Func] +' +'*/ +Function Format() +End Function + +'/* +'[Conversion Func] +' +'*/ +Function Hex() +End Function + + +'/* +'[Conversion Func] +' +'*/ +Function Oct() +End Function + + +'/* +'[Conversion Func] +'Returns a Variant (String) representation of a number. +' +'Example: +'Dim MyString +'MyString = Str(459) ' Returns " 459". +'MyString = Str(-459.65) ' Returns "-459.65". +'MyString = Str(459.001) ' Returns " 459.001". +' +'*/ +Function Str() As Variant +End Function + + +'/* +'[Conversion Func] +'Returns the numbers contained in a string as +'a numeric value of appropriate type. +' +'Example: +' +'Dim MyValue +'MyValue = Val("2457") ' Returns 2457. +'MyValue = Val(" 2 45 7") ' Returns 2457. +'MyValue = Val("24 and 57") ' Returns 24. +'*/ +Function Val(String) +End Function + + + +Function CreateObject() +End Function + + +Function CurDir() +End Function + +'/* +'Returns a Variant (Date) containing the current system date. +' +'Example +' +'Dim MyDate +'MyDate = Date ' MyDate contains the current system date. +' +'*/ +Function Date() + +End Function + + + +Function DateDiff() +End Function + +Function DatePart() +End Function + +Function DateSerial() +End Function + +Function Day() +End Function + +Function DDB() +End Function + +Function Dir() +End Function + +Function DoEvents() +End Function + +Function Environ() +End Function + +Function EOF() +End Function + +Function Error() +End Function + + +Function FileAttr() +End Function + +Function FileDateTime() +End Function + +Function FileLen() +End Function + +Function Filter() +End Function + +Function FormatCurrency() +End Function + +Function FormatDateTime() +End Function + +Function FormatNumber() +End Function + +Function FormaPercent() +End Function + + +Function FreeFile() +End Function + +Function FV() +End Function + +Function GetAllSettings() +End Function + +Function GetAttr() +End Function + +Function GetObject() +End Function + +Function GetSetting() +End Function + + +Function Hour() +End Function + +Function IIf() +End Function + +Function IMEStatus() +End Function + +Function Input() +End Function + +Function InputBox() +End Function + +Function InStr() +End Function + +Function InStrRev() +End Function + +Function IPmt() +End Function + + + +Function IRR() +End Function + +Function IsArray() +End Function + +Function IsDate() +End Function + +'/* +' +'Returns a Boolean value indicating whether a variable has been initialized. +' +'*/ +Function IsEmpty() +End Function + + +Function IsError() +End Function + +Function IsMissing() +End Function + +Function IsNull() +End Function + +Function IsNumeric() +End Function + + +Function IsObject() +End Function + +'/* +'Returns a string created by joining a number of substrings contained in an array. +' +'*/ +Function Join() +End Function + + + +Function LBound() +End Function + +Function LCase() +End Function + +Function Left() +End Function + +Function Len() +End Function + + +Function Loc() +End Function + +Function LOF() +End Function + +Function LTrim() +End Function + +Function RTrim() +End Function + +Function Trim() +End Function + + +Function MacID() +End Function + + + +Function MacScript() +End Function + +'/* +'[Math Function] +'Returns a value of the same type that is passed to it specifying the absolute value of a number. +' +'*/ +Function Abs() +End Function + +'/* +'[Math Function] +'Returns a Double specifying the arctangent of a number. +' +'*/ +Function Atn() +End Function + + +'/* +'[Math Function] +' +'*/ +Function Cos() +End Function + +'/* +'[Math Function] +' +'*/ +Function Exp() +End Function + +'/* +'[Math Function] +' +'*/ +Function Int() +End Function + +'/* +'[Math Function] +' +'*/ +Function Fix() +End Function + +'/* +'[Math Function] +' +'*/ +Function Log() +End Function + + +'/* +'[Math Function] +' +'*/ +Function Rnd() +End Function + +'/* +'[Math Function] +' +'*/ +Function Sgn() +End Function + +'/* +'[Math Function] +' +'*/ +Function Sin() +End Function + +'/* +'[Math Function] +' +'*/ +Function Sqr() +End Function + +'/* +'[Math Function] +' +'*/ +Function Tan() +End Function + + + +Function Mid() +End Function + + +Function Minute() +End Function + + +Function MIRR() +End Function + + +Function Month() +End Function + +Function MonthName() +End Function + +'/* +'Displays a message in a dialog box, waits for the user to click a button, +'and returns an Integer indicating which button the user clicked. +' +'*/ +Function MsgBox(prompt, [ buttons, ] [ title, ] [ helpfile, context ]) +End Function + + +Function Now() +End Function + + +Function NPer() +End Function + + +Function NPV() +End Function + +Function PPmt() +End Function + + +Function QBColor() +End Function + + +Function Rate() +End Function + +'/* +'Returns a string, which is a substring of a string +'expression beginning at the start position (defaults to 1), +'in which a specified substring has been replaced with another +'substring a specified number of times. +' +'*/ +Function Replace(expression, find, replace, [ start, [ count, [ compare ]]]) +End Function + +Function RGB() +End Function + + +Function Right() +End Function + + +Function Round() +End Function + + +Function Second() +End Function + + + +Function Seek() +End Function + + +Function Shell() +End Function + + +Function SNL() +End Function + + +Function Space() +End Function + + +Function Spc() +End Function + + +Function Split() +End Function + + +Function StrComp() +End Function + + + +Function StrConv() +End Function + + +Function String() +End Function + + +Function StrReverse() +End Function + + + +Function Switch() +End Function + + +Function SYD() +End Function + + +Function Tab() +End Function + + +Function Time() +End Function + + + +Function Timer() +End Function + + +Function TimeSerial() +End Function + + +Function TimeValue() +End Function + + + +Function TypeName() +End Function + + +Function UBound() +End Function + + +Function Ucase() +End Function + + +Function VarType() +End Function + + + +Function Weekday() +End Function + + +Function WeekdayName() +End Function + + +Function Year() +End Function \ No newline at end of file diff --git a/XVBA/MSS/■MSSツール/xvba_modules/excel-types/range.d.vb b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/range.d.vb new file mode 100644 index 00000000..92a9c7d7 --- /dev/null +++ b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/range.d.vb @@ -0,0 +1,625 @@ +'/* +'Represents a cell, a row, a column, a selection of cells containing one or more contiguous blocks of cells, or a 3D range. +' +' +'*/ +Public Class Range() + +'/* +'(Range) +' +'Activates a single cell, which must be inside the current selection. +'To select a range of cells, use the Select method., +' +'Example +' +'This example selects cells A1:C3 on Sheet1 and then makes cell B2 the active cell. +' +' Worksheets("Sheet1").Activate +' Range("A1:C3").Select +' Range("B2").Activate +' +'*/ +Public Sub Activate() + +End Sub + + +'/* +'Adds a comment to the range. +' +'Example: +' +'Worksheets(1).Range("E5").AddComment "Current Sales" +' +'@param {String} text +'*/ +Public Sub AddComment(text As String) + +End Sub + +Public Sub AddCommentThreaded() + +End Sub + +Public Sub AdvancedFilter() + +End Sub + +Public Sub AllocateChanges() + +End Sub + +Public Sub ApplyName() + +End Sub + +Public Sub ApplyOutLineStyles() + +End Sub + +Public Sub AutoComplete() + +End Sub + +Public Sub AutoFill() + +End Sub + +Public Sub AutoFilter() + +End Sub + +Public Sub AutioFit() + +End Sub + +Public Sub AutoOutline() + +End Sub + +Public Sub BorderAround() + +End Sub + +Public Sub Calculate() + +End Sub + +Public Sub CalculateRowMajorOrder() + +End Sub + +Public Sub CheckSpelling() + +End Sub + +Public Sub Clear() + +End Sub + +Public Sub ClearComments() + +End Sub + +Public Sub ClearContents() + +End Sub + +Public Sub ClearFormats() + +End Sub + +Public Sub ClearHyperlinks() + +End Sub + +Public Sub ClearNotes() + +End Sub + +Public Sub ClearOutline() + +End Sub + +Public Sub ColumnDifferences() + +End Sub + +Public Sub Consolidate() + +End Sub + +Public Sub ConvertToLinkedDataType() + +End Sub + +Public Sub Copy() + +End Sub + +Public Sub CopyFromRecordset() + +End Sub + +Public Sub CopyPicture() + +End Sub + +Public Sub CreateNames() + +End Sub + +Public Sub Cut() + +End Sub + +Public Function DataSeries (Rowcol, Type, Date, Step, Stop, Trend) + +End Function + +Public Function DataTypeToText() + +End Function + +Public Function Delete (Shift) + +End Function + +Public Function DialogBox() + +End Function + +Public Function Dirty() + +End Function +Public Function DiscardChanges() + +End Function +Public Function EditionOptions (Type, Option, Name, Reference, Appearance, ChartSize, Format) + +End Function +Public Function ExportAsFixedFormat (Type, FileName, Quality, IncludeDocProperties, IgnorePrintAreas, From, To, OpenAfterPublish, FixedFormatExtClassPtr) + +End Function +Public Function FillDown() + +End Function +Public Function FillLeft() + +End Function + +Public Function FillRight() + +End Function + +Public Function FillUp() + +End Function + +Public Function Find (What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat) + +End Function + +Public Function FindNext (After) + +End Function + +Public Function FindPrevious (Before) + +End Function + +Public Function FlashFill () + +End Function + + +Public Function FunctionWizard () + +End Function + + +Public Function Group (Start, End, By, Periods) + +End Function + +Public Function Insert (Shift, CopyOrigin) + +End Function + + +Public Function InsertIndent (InsertAmount) + +End Function + + +Public Function Justify() + +End Function + + +Public Function ListNames() + +End Function + +Public Function Merge(Across) + +End Function + +Public Function NavigateArrow(TowardPrecedent, ArrowNumber, LinkNumber) + +End Function + +Public Function NoteText(Text, Start, Length) + +End Function + +Public Function Parse(ParseLine, Destination) + +End Function + +Public Function PasteSpecial(Paste, Operation, SkipBlanks, Transpose) + +End Function + + +Public Function PrintOut(From, To, Copies, Preview, ActivePrinter, PrintToFile, Collate, PrToFileName) + +End Function + +Public Function PrintPreview(EnableChanges) + +End Function + +Public Function RemoveDuplicates(Columns , Header) + +End Function + +Public Function RemoveSubtotal() + +End Function + + +Public Function Replace(What, Replacement, LookAt, SearchOrder, MatchCase, MatchByte, SearchFormat, ReplaceFormat) + +End Function + + +Public Function RowDifferences(Comparison) + +End Function + +Public Function Run(Arg1, Arg2, Arg3, Arg4, Arg5...) + +End Function + +Public Function Select() + +End Function + +Public Function SetCellDataTypeFromCell(Range, LanguageCulture) + +End Function + + +Public Function SetPhonetic() + +End Function + + +Public Function Show() + +End Function + + +Public Function ShowCard() + +End Function + + +Public Function ShowDependents(Remove) + +End Function + + +Public Function ShowErrors() + +End Function + + +Public Function ShowPrecedents(Remove) + +End Function + + +Public Function Sort(Key1, Order1, Key2, Type, Order2, Key3, Order3, Header, OrderCustom, MatchCase, Orientation, SortMethod, DataOption1, DataOption2, DataOption3) + +End Function + + +Public Function SortSpecial(SortMethod, Key1, Order1, Type, Key2, Order2, Key3, Order3, Header, OrderCustom, MatchCase, Orientation, DataOption1, DataOption2, DataOption3) + +End Function + +Public Function Speak(SpeakDirection, SpeakFormulas) + +End Function + + +Public Function SpecialCells(Type, Value) + +End Function + +Public Function SubscribeTo(Edition, Format) + +End Function + +Public Function Subtotal(GroupBy, Function, TotalList, Replace, PageBreaks, SummaryBelowData) + +End Function + + +Public Function Table(RowInput, ColumnInput) + +End Function + + +Public Function TextToColumns(Destination, DataType, TextQualifier, ConsecutiveDelimiter, Tab, Semicolon, Comma, Space, Other, OtherChar, FieldInfo, DecimalSeparator, ThousandsSeparator, TrailingMinusNumbers + +End Function + + +Public Function Ungroup() + +End Function + + +Public Function UnMerge() + +End Function + +Public Property AddIndent As Variant + +Public Function Address(RowAbsolute, ColumnAbsolute, ReferenceStyle, External, RelativeTo) As Variant +End Function + +Public Function AddressLocal(RowAbsolute, ColumnAbsolute, ReferenceStyle, External, RelativeTo) As Range +End Function + +Public Property Application As Application + +Public Property Areas As Areas + +Public Property Borders As Variant + +Public Property Cells As Range + +Public Function Characters(Start, Length) As Variant +End Function + +Public Property Column As Long + +Public Property Columns As Long + +Public Property ColumnWidth As Variant + +Public Property Comment As Variant + +Public Property CommentThreaded As Variant + + +Public Property Count As Long + + +Public Property CountLarge As Variant + + +Public Property Creator As Integer + + +Public Property CurrentArray As Range + +'/* +'Returns a Range object that represents the current region. +'The current region is a range bounded by any combination of blank rows and blank columns. Read-only. +' +'Example +'Worksheets("Sheet1").Activate +'ActiveCell.CurrentRegion.Select +'*/ +Public Property CurrentRegion As Range + +Public Property Dependents As Range + +Public Property DirectDependents As Range + +Public Property DirectPrecedents As Range + +Public Property DisplayFormat As Object + + +Public Function End(Direction) As Object +End Function + +Public Property EntireColumn As Range + + +Public Property EntireRow As Range + + +Public Property Errors As Errors + + +Public Property Font As Font + + +Public Property FormatConditions As Range + +Public Property Formula As Variant + +Public Property FormulaArray As Variant + +Public Property FormulaHidden As Variant + + +Public Property FormulaLocal As Object + +Public Property FormulaR1C1 As Varaint + +Public Property FormulaR1C1Local As Varaint + +Public Property HasArray As Varaint + +Public Property HasFormula As Varaint + +Public Property HasRichDataType As Varaint + +Public Property Height As Double + +Public Property Hidden As Variant + +Public Property HorizontalAlignment As Variant + +Public Property Hyperlinks As Object + +Public Property ID As String + +Public Property IndentLevel As Variant + +Public Property Interior As Double + +Public Function Item (RowIndex, ColumnIndex) As Range +End Function + + +Public Property Left As Variant + + +Public Property LinkedDataTypeState As Variant + +Public Property ListHeaderRows As Variant + + +Public Property ListObject As Object + +Public Property LocationInTable As Variant + +Public Property Locked As Variant + +Public Property MDX As String + +Public Property MergeArea As Range + +Public Property MergeCells As Boolean + +Public Property Name As Variant + +Public Property Next As Range + +Public Property NumberFormat As Variant + +Public Property NumberFormatLocal As Variant + +Public Function Offset (RowOffset, ColumnOffset) As Range + +End Function + + +Public Property Orientation As Variant + +Public Property OutlineLevel As Variant + +Public Property PageBreak As Variant + +Public Property Parent As Variant + +Public Property Phonetic As Variant + +Public Property Phonetics As Variant + +Public Property PivotCell As Variant + + +Public Property PivotField As Variant + + +Public Property PivotItem As Variant + +Public Property PivotTable As Variant + +Public Property Precedents As Range + +Public Property PrefixCharacter As Variant + + +Public Property Previous As Range + +Public Property QueryTable As Variant + +Public Function Range (Cell1, Cell2) As Range +End Function + +Public Property ReadingOrder As Variant + +Public Function Resize (RowSize, ColumnSize) As Range +End Function + + +Public Property Row As Long + +Public Property RowHeight As Double + +Public Property Rows As Range + +Public Property ServerActions As Variant + + +Public Property ShowDetail As Variant + + +Public Property ShrinkToFit As Variant + + +Public Property SoundNote As Variant + + +Public Property SparklineGroups As Variant + + +Public Property Style As Variant + +Public Property Summary As Variant + + +Public Property Text As String + +Public Property Top As Variant + +Public Property UseStandardHeight As Variant + +Public Property UseStandardWidth As Variant + +Public Property Validation As Variant + +Public Function Value (RangeValueDataType) As Variant +End Function + +Public Property Value2 As Variant + + +Public Property VerticalAlignment As Variant + +Public Property Width As Double + + + +Public Property Worksheet As Worksheet + + +Public Property WrapText As Variant + +Public Property XPath As XPath + + + +End Class diff --git a/XVBA/MSS/■MSSツール/xvba_modules/excel-types/workbook.d.vb b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/workbook.d.vb new file mode 100644 index 00000000..55764e2b --- /dev/null +++ b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/workbook.d.vb @@ -0,0 +1,157 @@ +'/* +'Represents a Microsoft Excel workbook. +' +' +'*/ +Public Class Workbook() + +'/* +'Returns a String that represents the complete path to the +'workbook/file that this workbook object represents. +' +'*/ +Public Property Path As String + + +Public Property Worksheets As Worksheet + +'/* +'True if a backup file is created when this file is saved. Read-only Boolean. +' +'@type {Boolean} +'*/ +Public Property CreateBackup As Boolean + +'/* +'Returns a String value that represents the name of the object. +' +'@type {Boolean} +'*/ +Public Property Name As String + +'/* +'True if no changes have been made to the specified workbook since it was last saved. Read/write Boolean. +' +'Example: +'If Not ActiveWorkbook.Saved Then +' MsgBox "This workbook contains unsaved changes." +'End If +' +'@type {Boolean} +'*/ +Public Property Saved As String + +'/* +'Returns a Sheets collection that represents all the sheets in the specified workbook. Read-only Sheets object. +' +'Example: +'Set newSheet = Sheets.Add(Type:=xlWorksheet) +'For i = 1 To Sheets.Count +' newSheet.Cells(i, 1).Value = Sheets(i).Name +' Next i +' +'@type {Sheets} +'*/ +Public Property Sheets As Worksheets + + +'/* +' +'Activates the first window associated with the workbook. +' +'*/ +Public Function Activate() + +End Function + +'/* +' +'Closes the object. +' +'Example +' +'Workbooks("BOOK1.XLS").Close SaveChanges:=False +' +'@param {Variant} SaveChanges:[Optional] True or false +'@param {Variant} FileName:[Optional] Saves changes under this file name. +'@param {Variant} RouteWorkbook:[Optional] True or False +'*/ +Public Function Close(SaveChanges,FileName,RouteWorkbook) + +End Function + +'/* +'Saves changes to the specified workbook. +'*/ +Public Function Save() + +End Function + +'/* +'Saves changes to the workbook in a different file. +' +'@param {Variant} FileName:[Optional] +'@param {Variant} FileFormat:[Optional] +'@param {Variant} Password:[Optional] +'@param {Variant} WriteResPassword:[Optional] +'@param {Variant} ReadOnlyRecommended:[Optional] +'@param {Variant} CreateBackup:[Optional] +'@param {Variant} AccessMode:[Optional] +'@param {Variant} ConflictResolution:[Optional] +'@param {Variant} AddToMru:[Optional] +'@param {Variant} TextCodepage:[Optional] +'@param {Variant} TextVisualLayout:[Optional] +'@param {Variant} Local:[Optional] +'*/ +Public Function SaveAs(FileName, FileFormat, Password, WriteResPassword, ReadOnlyRecommended, CreateBackup, AccessMode, ConflictResolution, AddToMru, TextCodepage, TextVisualLayout, Local) + +End Function + + +'/* +'Exports the data that has been mapped to the specified XML schema map to an XML data file. +' +'@param {String} FileName:[Required] +'@param {XmlMap} Map:[Required] +'*/ +Public Function SaveAsXMLData(FileName, Map) + +End Function + + +'/* +'Saves a copy of the workbook to a file but doesn't modify the open workbook in memory. +' +'Example +'ActiveWorkbook.SaveCopyAs "C:\TEMP\XXXX.XLS" +' +'@param {Variant} FileName:[Required] +'*/ +Public Function SaveCopyAs(FileName, Map) + +End Function + +'/* +'Sends the workbook by using the installed mail system. +' +'Example +'ActiveWorkbook.SendMail recipients:="Jean Selva" +' +'@param {Variant} Recipients:[Required] +'@param {Variant} Subject:[Optional] +'@param {Variant} ReturnReceipt:[Optional] +'*/ +Public Function SendMail(Recipients, Subject, ReturnReceipt) + +End Function + +'/* +' +'The ExportAsFixedFormat method is used to publish +'a workbook to either the PDF or XPS format. +' +'*/ +Public Function ExportAsFixedFormat(Type, FileName, Quality, IncludeDocProperties, IgnorePrintAreas, From, To, OpenAfterPublish, FixedFormatExtClassPtr) +End Function + +End Class \ No newline at end of file diff --git a/XVBA/MSS/■MSSツール/xvba_modules/excel-types/workbooks.d.vb b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/workbooks.d.vb new file mode 100644 index 00000000..07f71c5f --- /dev/null +++ b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/workbooks.d.vb @@ -0,0 +1,109 @@ +'/* +'A collection of all the Workbook objects that are currently open in the Microsoft Excel application. +' +'*/ +Public Class Workbooks() + +'/* +'Creates a new workbook. The new workbook becomes the active workbook. +' +'@param {Variant} Template:[Optional] Determines how the new workbook is created. +'If this argument is a string specifying the name of an existing Microsoft Excel file, +'the new workbook is created with the specified file as a template. +'*/ +Public Function Add(Template) + +End Function + + +'/* +'True if Microsoft Excel can check out a specified workbook from a server. +'Read/write Boolean. +' +'@param {String} FileName:[Required] The name of the file to check out. +' +'*/ +Public Function CanCheckOut (FileName) + +End Function + + +Public Function CheckOut (FileName) + +End Function + + +Public Function Close () + +End Function + +'/* +' +'Opens a workbook. +' +'Example +'Workbooks.Open "ANALYSIS.XLS" +'ActiveWorkbook.RunAutoMacros xlAutoOpen +'*/ +Public Function Open (FileName, UpdateLinks, ReadOnly, Format, Password, WriteResPassword, IgnoreReadOnlyRecommended, Origin, Delimiter, Editable, Notify, Converter, AddToMru, Local, CorruptLoad) As Workbook + +End Function + +'/* +'Returns a Workbook object representing a database. +'*/ +Public Function OpenDatabase (FileName, CommandText, CommandType, BackgroundQuery, ImportDataAs) + +End Function + + +'/* +'Loads and parses a text file as a new workbook with a single sheet that contains the parsed text-file data. +'*/ +Public Function (FileName, Origin, StartRow, DataType, TextQualifier, ConsecutiveDelimiter, Tab, Semicolon, Comma, Space, Other, OtherChar, FieldInfo, TextVisualLayout, DecimalSeparator, ThousandsSeparator, TrailingMinusNumbers, Local) + +End Function + +'/* +'Opens an XML data file. Returns a Workbook object. +'*/ +Public Function OpenXML (FileName, Stylesheets, LoadOption) + +End Function + + +'/* +'When used without an object qualifier, this property returns an +'Application object that represents the Microsoft Excel application. +' +'*/ +Public Property Application As Application + + +'/* +'Returns a Long value that represents the number of objects in the collection. +' +'*/ +Public Property Count As Long + +'/* +'Returns a 32-bit integer that indicates the application in which this object was created. Read-only Long. +' +'*/ +Public Property Creator As Integer + + + +'/* +'Returns a single object from a collection. +' +'*/ +Public Property Item(Index) As Object + +'/* +'Returns the parent object for the specified object. Read-only. +' +'*/ +Public Property Parent As Object + +End Class \ No newline at end of file diff --git a/XVBA/MSS/■MSSツール/xvba_modules/excel-types/worksheet.d.vb b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/worksheet.d.vb new file mode 100644 index 00000000..24a02271 --- /dev/null +++ b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/worksheet.d.vb @@ -0,0 +1,86 @@ +'/* +'Represents a worksheet. +' +'Example +' +'Worksheets(1).Visible = False +' +'*/ +Public Class Worksheet() + + +'/* +'Makes the current sheet the active sheet. +' +'Example +'ActiveWorkbook.SendMail recipients:="Jean Selva" +'*/ +Public Sub Activate() + +End Sub + + +Public Sub Calculate() + +End Sub + +Public Sub Copy() + +End Sub + +Public Sub Delete() +End Sub + +Public Sub Move() + +End Sub + +Public Sub Past() + +End Sub + +Public Sub PastSpecial() + +End Sub + +Public Sub Select() +End Sub + +Public Sub SaveAs() + +End Sub + +'/* +' +'Returns a Range object that represents a cell or a range of cells. +' +'Example: +' +'Worksheets("Sheet1").Range("A1").Value = 3.14159 +' +'*/ +Public Property Range As Range + + +'/* +' +'Returns a Range object that represents all the rows on the specified worksheet. +' +'Example: +' +'Worksheets("Sheet1").Rows(3).Delete +' +'*/ +Public Property Row As Range + + +'/* +' +'Returns a Long value that represents the index number of the +'object within the collection of similar objects.orksheets("Sheet1").Rows(3).Delete +' +'*/ +Public Property Index As Long + + +End Class \ No newline at end of file diff --git a/XVBA/MSS/■MSSツール/xvba_modules/excel-types/worksheets.d.vb b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/worksheets.d.vb new file mode 100644 index 00000000..7d775495 --- /dev/null +++ b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/worksheets.d.vb @@ -0,0 +1,54 @@ +'/* +'A collection of all the Worksheet objects in the specified or active workbook. Each Worksheet object represents a worksheet. +' +'Example +' +'Worksheets(1).Visible = False +' +'*/ +Public Class Worksheets() + +'/* +'Constructor +' +'*/ +Public Sub New(Name As String) As Worksheet + +End Sub + +Public Sub Add() + +End Sub + + +Public Sub Add2() + +End Sub + +Public Sub Copy() + +End Sub + +Public Sub Delete() +End Sub + +Public Sub Move() + +End Sub + +Public Sub FillAcrossSheets() + +End Sub + +Public Sub PrintOut() + +End Sub + +Public Sub PrintPreview() +End Sub + +Public Sub Select() + +End Sub + +End Class \ No newline at end of file diff --git a/XVBA/MSS/■MSSツール/xvba_modules/excel-types/xvba.package.json b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/xvba.package.json new file mode 100644 index 00000000..2fb972d9 --- /dev/null +++ b/XVBA/MSS/■MSSツール/xvba_modules/excel-types/xvba.package.json @@ -0,0 +1,15 @@ +{ + "package": "excel-types", + "version": "1.0.0", + "author": "Alberto Oliveira", + "email": "alberto.aeraph@gmail.comn", + "license": "ISC", + "repository": { + "type": "git", + "url": "https://github.com/Aeraphe/excel-types.git" + }, + "description": "Creating amazing XVBA packages", + "dependencies": {}, + "dev_dependencies": {}, + "homepage": "https://github.com/Aeraphe/xvba-cli" +} \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/.vscode/settings.json b/XVBA/MSS/■事業計画VBA/.vscode/settings.json new file mode 100644 index 00000000..49431ab8 --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/.vscode/settings.json @@ -0,0 +1,3 @@ +{ + "files.encoding": "shiftjis" +} \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/config.json b/XVBA/MSS/■事業計画VBA/config.json new file mode 100644 index 00000000..d4f1e4c3 --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/config.json @@ -0,0 +1,14 @@ +{ + "app_name": "XVBA", + "description": "", + "author": "", + "email": "", + "create_ate": "Thu May 29 2025 14:14:10 GMT+0900 (日本標準時)", + "excel_file": "事業計画集計v3.2.xlsm", + "vba_folder": "vba-files", + "ribbon_file": "customUI14", + "ribbon_folder": "ribbons", + "logs": "on", + "xvba_packages": {}, + "xvba_dev_packages": {} +} \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/package.json b/XVBA/MSS/■事業計画VBA/package.json new file mode 100644 index 00000000..a8deae27 --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/package.json @@ -0,0 +1,15 @@ +{ + "name": "xvba-app", + "version": "1.0.0", + "description": "A XVBA App", + "main": "index.js", + "author": "LocalSmart", + "license": "ISC", + "dependencies": { + "excel-types": "1.0.0", + "Xlog": "1.0.0" + }, + "devDependencies": { + "@localsmart/xvba-cli": "^1.0.2" + } +} \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/Xdebug/CHANGELOG.md b/XVBA/MSS/■事業計画VBA/xvba_modules/Xdebug/CHANGELOG.md new file mode 100644 index 00000000..f1f3ad96 --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/xvba_modules/Xdebug/CHANGELOG.md @@ -0,0 +1,13 @@ +# Changelog +## Xdebug (Under Construction) + +- This package provides a way to simulate VBA Immediate Window in Output VSCode window + +## [1.0.0b0] - 2020-09-16 +### Added + - Create XDebug.printx + - Create XDebug.printError + + + + \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/Xdebug/README.md b/XVBA/MSS/■事業計画VBA/xvba_modules/Xdebug/README.md new file mode 100644 index 00000000..9d8b74f0 --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/xvba_modules/Xdebug/README.md @@ -0,0 +1,58 @@ +# Xdebug (VBA Immediate Window in Output VSCode Window) + +## Description + - This package provides a way to simulate VBA Immediate Window in Output VSCode window + - Find the Output window (VBA Immediate Window) + + ## Methods + +

+VBA immediate Window +

+ + + ### Xdebug.printx + +- This method print any type os variable + + +``` + +Public Sub index() + + + Dim test(1) As Variant + + 'Add an Object + Set test(0) = Sheets(1) + 'Add a String + test(1) = "Test Xdebug Output" + + Xdebug.printx test + +End Sub + +``` + + + ### Xdebug.printError + +- This method is use for print error + + +``` + Public Sub index() + + On Error GoTo ErrorHandle: + 'throw an error + d = 1/0 + 'Your code here + + + ErrorHandle: + Xdebug.errorSource = "pageConsoller.index" + Xdebug.printError + + End Sub +``` + diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/Xdebug/Xdebug.cls b/XVBA/MSS/■事業計画VBA/xvba_modules/Xdebug/Xdebug.cls new file mode 100644 index 00000000..0856356e --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/xvba_modules/Xdebug/Xdebug.cls @@ -0,0 +1,241 @@ +VERSION 1.0 CLASS +BEGIN +MultiUse = -1 'True +END +Attribute VB_Name = "Xdebug" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False + +'namespace=xvba_modules\Xdebug + +Public env As String + +'Example of Package Create by XVBA-CLI + +Private OS_TMP__FOLDER_PATH As String + +Private IMMEDIATE_FOLDER As String + +Private IMMEDIATE_FILE As String + +Private DEBUG_FILE_PATH As String + +Const EMPTY_TYPE = 0 +Const NULL_TYPE = 1 +Const ERROR_TYPE = 10 +Const INTEGER_TYPE = 2 +Const LONG_TYPE = 3 +Const SINGLE_TYPE = 4 +Const DOUBLE_TYPE = 5 +Const CURRENCY_TYPE = 6 +Const DATE_TYPE = 7 +Const DECIMAL_TYPE = 14 +Const LONG_LONG_TYPE = 20 +Const BOOLEAN_TYPE = 11 +Const STRING_TYPE = 8 +Const ARRAY_TYPE = 8204 +Const OBJECT_TYPE = 9 +Const VARIANT_TYPE = 12 +Const DATA_OBJECT_TYPE = 13 +Private Const MESSAGE_SPACE = " " + +Public errorSource As String +Public errorTitle As String + +'/* +'Flag for Actrive os Deactive VBA Debug.Print +'*/ +Public vbaDebugPrintActive As Boolean + +Private Sub class_initialize() + + Dim fso As Object + Set fso = CreateObject("Scripting.FileSystemObject") + OS_TMP__FOLDER_PATH = fso.GetSpecialFolder(2) + IMMEDIATE_FOLDER = "xvba_immediate" + IMMEDIATE_FILE = "immediate.txt" + vbaDebugPrintActive = True + errorSource = "" + errorTitle = "XVBA: New Error Was Found" + env = "DEV" + + DEBUG_FILE_PATH = OS_TMP__FOLDER_PATH & "\" & IMMEDIATE_FOLDER & "\" & IMMEDIATE_FILE + +End Sub + + + + +Public Function printx(inputValue As Variant,Optional messageType As Integer = 1) + + if(env="DEV") Then + Dim messageText As String + + messageText = createOutputMessage(inputValue) + + Call writeDebugFileContent(messageText,messageType) + End If +End Function + +'/* +'Print A Error +' +'*/ +Public Function printError() + if(env="DEV") Then + + Dim message As String + + message = ErrorHanddler() + + Call writeDebugFileContent(message,0) + + End If +End Function + + +'/* +' +'Write Debug ino on File +' +' +'*/ +Private Function writeDebugFileContent(messageText,messageType) + + Dim filePath As String + Dim FileNum As Integer + Dim PREFIX As String + + filePath = DEBUG_FILE_PATH + + FileNum = FreeFile + + PREFIX = Now & " - " + + Open filePath For Append As #FileNum + + Dim debugMessage As String + Select Case messageType + + Case 0 'Error Message + + debugMessage= PREFIX & "Error:" & messageText + Case 1 'Success + debugMessage= PREFIX & messageText + Case Else 'No Type Set + + debugMessage= PREFIX & "Info:" & messageText + End Select + + Print #FileNum,debugMessage + + Close #FileNum + + If (vbaDebugPrintActive) Then + + Debug.Print debugMessage + + End If +End Function + + +Private Function createOutputMessage(inputValue) As String + + Dim typeOfVar As Integer + Dim response As String + + typeOfVar = VarType(inputValue) + + + 'Set Error Source Macro/Function name + Err.Source="createOutputMessage" + Select Case typeOfVar + Case STRING_TYPE + response = "String: " & inputValue + Case INTEGER_TYPE + response = "Integer: " & CStr(inputValue) + Case LONG_TYPE + response = "Long: " & CStr(inputValue) + Case SINGLE_TYPE + response = "Single: " & CStr(inputValue) + Case DOUBLE_TYPE + response = "Double: " & CStr(inputValue) + Case CURRENCY_TYPE + response = "Currenty: " & CStr(inputValue) + Case DATE_TYPE + response = "Date: " & CStr(inputValue) + Case DECIMAL_TYPE + response = "Decimal: " & CStr(inputValue) + Case LONG_LONG_TYPE + response = "LongLong: " & CStr(inputValue) + Case BOOLEAN_TYPE + response = "Boolean: " & CStr(inputValue) + Case ARRAY_TYPE + response = makeArrayTypeMessage(inputValue) + Case EMPTY_TYPE + response = "Empty: " + Case OBJECT_TYPE + response = "Object: " & TypeName(inputValue) + Case NULL_TYPE + response = "Null: " + Case ERROR_TYPE + response = "Error: " + Case VARIANT_TYPE + response = "Variant: " + Case DATA_OBJECT_TYPE + response = "Data Object: " & TypeName(inputValue) + Case Else + response = "Type Not Supported yet please inform xvba developer " + Debug.Print typeOfVar + Debug.Print inputValue + + End Select + + + createOutputMessage = response + +End Function + + +Private Function makeArrayTypeMessage(inputValue)As String + Dim nextItem As Variant + Dim response As String + Dim message As String + + For Each nextItem In inputValue + message = createOutputMessage(nextItem) + response = response & " [ " & message & " ]" & vbCrLf + Next nextItem + makeArrayTypeMessage = "Array: " & vbCrLf & response +End Function + + + +Private Function ErrorHanddler() As String + Dim errorDescription As String + Dim numberDescription As String + Dim lineError As String + Dim sourceError As String + Dim errorTitleMsg As String + Dim errorSourceMsg As String + + errorTitleMsg = vbCrLf & MESSAGE_SPACE & errorTitle + errorSourceMsg = vbCrLf & MESSAGE_SPACE & "Error Source: " & errorSource + + + Select Case Err.Number + Case 11 + numberDescription = vbCrLf & MESSAGE_SPACE & "Error Number: " & Err.Number + lineError = vbCrLf & MESSAGE_SPACE & "Error Line: " & Erl + errorDescription = vbCrLf & MESSAGE_SPACE & "Error Description: " & Err.Description + Case Else + numberDescription = vbCrLf & MESSAGE_SPACE & "Error Number: " & Err.Number + errorDescription = vbCrLf & MESSAGE_SPACE & "Error Description: " & Err.Description + End Select + + + ErrorHanddler = errorTitleMsg & lineError & errorSourceMsg & numberDescription & errorDescription + +End Function \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/Xdebug/images/immediate.gif b/XVBA/MSS/■事業計画VBA/xvba_modules/Xdebug/images/immediate.gif new file mode 100644 index 00000000..dd641693 Binary files /dev/null and b/XVBA/MSS/■事業計画VBA/xvba_modules/Xdebug/images/immediate.gif differ diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/Xdebug/xvba.package.json b/XVBA/MSS/■事業計画VBA/xvba_modules/Xdebug/xvba.package.json new file mode 100644 index 00000000..4a1da537 --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/xvba_modules/Xdebug/xvba.package.json @@ -0,0 +1,15 @@ +{ + "package": "Xdebug", + "version": "1.0.0", + "author": "Alberto Edaurdo", + "email": "alberto.aeraphe@gmail.com", + "license": "ISC", + "repository": { + "type": "git", + "url": "https://github.com/Aeraphe/xdebug.git" + }, + "description": "Creating amazing XVBA packages", + "dependencies": {}, + "dev_dependencies": {}, + "homepage": "www.xvba.dev" +} \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/CHANGELOG.md b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/CHANGELOG.md new file mode 100644 index 00000000..39a71ff4 --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/CHANGELOG.md @@ -0,0 +1,8 @@ +# Changelog +## excel@types (Under Construction) + +- This package provides a way to use auto-complete for excel class + + + + \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/README.md b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/README.md new file mode 100644 index 00000000..dcf0411e --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/README.md @@ -0,0 +1,51 @@ +# Excel VBA type Definitions Package (excel-types) + + - This package provides a way to use auto-complete for Excel VBA Class + - You can Create your own vba type definition packages our update this. + - Type definition packages are named like: name-types + - The packages are store in www.xvba.dev + - Ech excel vba class has your own file definition + - The files extension has to be filename.d.vb + - Auto-complete just expose Public types + + +## Create,install and share VBA Packages With Xvba-cli and Xvba Repository: + +- Xvba Repository : www.xvba.dev +- XVBA-CLI Command Line Interface for XVBA VSCode extension @localsmart/xvba-cli + +## Install + +- For instal excel-types just use XVBA-CLI install command + +``` + npx xvba install excel-types +``` +## Comments Block + +- Use comments blocks below for documenting class/methods/Subs/Functions/Properties +- The comments blocs has to start with '/* and ends with '*/ + +``` + +'/* +'Represents the entire Microsoft Excel application. +' +' +'*/ +Public Class Application() + +``` + +``` +'/* +'Returns a Range object that represents the active cell in the active window +'(the window on top) or in the specified window. If the window isn't displaying +'a worksheet, this property fails. Read-only. +' +'@type {Object.} +' +'*/ +Public Property ActiveCell As Range + +``` \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/application.d.vb b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/application.d.vb new file mode 100644 index 00000000..af74a242 --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/application.d.vb @@ -0,0 +1,147 @@ +'/* +'Represents the entire Microsoft Excel application. +' +' +'*/ +Public Class Application() + +'/* +'Returns an object that represents the active sheet (the sheet on top) +'in the active workbook or in the specified window or workbook. +'Returns Nothing if no sheet is active. +' +'*/ +Public Property ActiveSheet As Worksheet + +'/* +'Returns a Workbook object that represents the workbook in the +'active window (the window on top). +'Returns Nothing if there are no windows open or if either +'the Info window or the Clipboard window is the active window. Read-only. +' +' +'*/ +Public Property ActiveWorkbook As Workbook + +'/* +'True if Microsoft Excel displays certain alerts and messages while +'a macro is running. Read/write Boolean. +' +'Example +'Application.DisplayAlerts = False +'Workbooks("BOOK1.XLS").Close +'Application.DisplayAlerts = True +' +'*/ +Public Property DisplayAlerts As Boolean + + +'/* +'Returns or sets an XlCalculation value that represents the calculation mode. +' +'Example +'Application.Calculation = xlCalculationManual +'Application.Calculation = xlAutomatic +' +'@type {XlCalculation} +'*/ +Public Property Calculation As XlCalculation + +'/* +'True if events are enabled for the specified object. Read/write Boolean. +' +'@type {Boolean} +'*/ +Public Property EnableEvents As Boolean + +'/* +'True if screen updating is turned on. Read/write Boolean. +'@type {Boolean} +'*/ +Public Property ScreenUpdating As Boolean + + +'/* +'Returns a Range object that represents the active cell in the active window +'(the window on top) or in the specified window. If the window isn't displaying +'a worksheet, this property fails. Read-only. +' +'@type {Object.} +' +'*/ +Public Property ActiveCell As Range + +'/* +'Returns a Chart object that represents the active chart (either an embedded chart or a chart sheet). +'An embedded chart is considered active when it's either selected or activated. When no chart is active, +'this property returns Nothing. +' +'Example: +'ActiveChart.HasLegend = True +' +'@type {Object.} +'*/ +Public Property ActiveChart As Chart + +'/* +'Returns a Workbooks collection that represents all the open workbooks. Read-only. +' +'@type {Object.} Workbooks Collection +'*/ +Public Property ThisWorkbook As Workbook + +'/* +'Returns a Workbooks collection that represents all the open workbooks. Read-only. +' +'@type {Object.} Workbooks Collection +'*/ +Public Property Workbooks As Workbooks + +'/* +'Activates a Microsoft application. If the application is already running, +'this method activates the running application. +'If the application isn't running, this method starts a new instance of the application. +' +'Example: (This example starts and activates Word.) +' +'Application.ActivateMicrosoftApp xlMicrosoftWord +' +'@param {XlMSApplication} index +'*/ +Public Sub ActivateMicrosoftApp( index As XlMSApplication) + +End Sub + +'/* +'An event occurs when all pending refresh activity (both synchronous and asynchronous) +'and all of the resultant calculation activities have been completed. +' +'*/ +Public Event AfterCalculate() + +'/* +'Occurs when a new workbook is created. +' +'Example: +' +'Private Sub App_NewWorkbook(ByVal Wb As Workbook) +'Application.Windows.Arrange xlArrangeStyleTiled End Sub +' +'@param {Workbook} Wb +'*/ +Public Event NewWorkbook(ByVal Wb As Workbook) + +'/* +'Returns a Sheets collection that represents all the sheets in the specified workbook. Read-only Sheets object. +' +'Example: +'Set newSheet = Sheets.Add(Type:=xlWorksheet) +'For i = 1 To Sheets.Count +' newSheet.Cells(i, 1).Value = Sheets(i).Name +' Next i +' +'@type {Sheets} +'*/ +Public Property Sheets As Worksheets + +End Class \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/dictionary.d.vb b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/dictionary.d.vb new file mode 100644 index 00000000..6a580711 --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/dictionary.d.vb @@ -0,0 +1,109 @@ + + + +'/* +' +' +' +'/* +Public Class Scripting() + + +'/* +' +'Object that stores data key/item pairs. +' +'/* +Public Function Dictionary() + +End Function + +'/* +' +'Adds a new key/item pair to a Dictionary object. +' +'*/ +Public Sub Add() + +End Sub + +'/* +' +'Returns a Boolean value that indicates whether a specified key exists in the Dictionary object. +' +'*/ +Public Sub Exists() + +End Sub + +'/* +' +'Returns an array of all the items in a Dictionary object. +' +'*/ +Public Sub Items() + +End Sub + +'/* +' +'Returns an array of all the keys in a Dictionary object. +' +'*/ +Public Sub Keys() + +End Sub + +'/* +' +'Removes one specified key/item pair from the Dictionary object. +' +'*/ +Public Sub Remove() + +End Sub + +'/* +' +'Removes all the key/item pairs in the Dictionary object. +' +'*/ +Public Sub RemoveAll() + +End Sub + + + +'/* +'Sets or returns the comparison mode for comparing keys in a Dictionary object. +' +' +'*/ +Public Property CompareMode As Variant + + +'/* +'Returns the number of key/item pairs in a Dictionary object. +' +' +'*/ +Public Property Count As Long + + +'/* +'Sets or returns the value of an item in a Dictionary object. +' +' +'*/ +Public Property Item As Variant + +'/* +'Sets a new key value for an existing key value in a Dictionary object. +' +' +'*/ +Public Property Key As Variant + + + +End Class \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/err.d.vb b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/err.d.vb new file mode 100644 index 00000000..7115cac1 --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/err.d.vb @@ -0,0 +1,30 @@ +'/* +'Contains information about run-time errors. +' +' +'*/ +Public Class Err() + +'/* +'Returns or sets a string expression containing a +'descriptive string associated with an object. Read/write. +' +'*/ +Public Property Description As String + +'/* +'Returns or sets a numeric value specifying an error. +'Number is the Err object's default property. Read/write. +' +'*/ +Public Property Number As Integer + + +'/* +'Returns or sets a string expression specifying the name of +'the object or application that originally generated the error. Read/write. +' +'*/ +Public Property Source As String + +End Class \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/functions.d.vb b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/functions.d.vb new file mode 100644 index 00000000..38aba162 --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/functions.d.vb @@ -0,0 +1,547 @@ + +'/* +'[Conversion Func] +' +'*/ +Function Asc() +End Function + +'/* +'[Conversion Func] +'Returns a String containing the character associated +'with the specified character code. +' +'Example: +' +'Dim MyChar +'MyChar = Chr(65) ' Returns A. +'MyChar = Chr(97) ' Returns a. +'MyChar = Chr(62) ' Returns >. +'MyChar = Chr(37) ' Returns %. +'*/ +Function Chr() +End Function + +'/* +'[Conversion Func] +' +'*/ +Function Format() +End Function + +'/* +'[Conversion Func] +' +'*/ +Function Hex() +End Function + + +'/* +'[Conversion Func] +' +'*/ +Function Oct() +End Function + + +'/* +'[Conversion Func] +'Returns a Variant (String) representation of a number. +' +'Example: +'Dim MyString +'MyString = Str(459) ' Returns " 459". +'MyString = Str(-459.65) ' Returns "-459.65". +'MyString = Str(459.001) ' Returns " 459.001". +' +'*/ +Function Str() As Variant +End Function + + +'/* +'[Conversion Func] +'Returns the numbers contained in a string as +'a numeric value of appropriate type. +' +'Example: +' +'Dim MyValue +'MyValue = Val("2457") ' Returns 2457. +'MyValue = Val(" 2 45 7") ' Returns 2457. +'MyValue = Val("24 and 57") ' Returns 24. +'*/ +Function Val(String) +End Function + + + +Function CreateObject() +End Function + + +Function CurDir() +End Function + +'/* +'Returns a Variant (Date) containing the current system date. +' +'Example +' +'Dim MyDate +'MyDate = Date ' MyDate contains the current system date. +' +'*/ +Function Date() + +End Function + + + +Function DateDiff() +End Function + +Function DatePart() +End Function + +Function DateSerial() +End Function + +Function Day() +End Function + +Function DDB() +End Function + +Function Dir() +End Function + +Function DoEvents() +End Function + +Function Environ() +End Function + +Function EOF() +End Function + +Function Error() +End Function + + +Function FileAttr() +End Function + +Function FileDateTime() +End Function + +Function FileLen() +End Function + +Function Filter() +End Function + +Function FormatCurrency() +End Function + +Function FormatDateTime() +End Function + +Function FormatNumber() +End Function + +Function FormaPercent() +End Function + + +Function FreeFile() +End Function + +Function FV() +End Function + +Function GetAllSettings() +End Function + +Function GetAttr() +End Function + +Function GetObject() +End Function + +Function GetSetting() +End Function + + +Function Hour() +End Function + +Function IIf() +End Function + +Function IMEStatus() +End Function + +Function Input() +End Function + +Function InputBox() +End Function + +Function InStr() +End Function + +Function InStrRev() +End Function + +Function IPmt() +End Function + + + +Function IRR() +End Function + +Function IsArray() +End Function + +Function IsDate() +End Function + +'/* +' +'Returns a Boolean value indicating whether a variable has been initialized. +' +'*/ +Function IsEmpty() +End Function + + +Function IsError() +End Function + +Function IsMissing() +End Function + +Function IsNull() +End Function + +Function IsNumeric() +End Function + + +Function IsObject() +End Function + +'/* +'Returns a string created by joining a number of substrings contained in an array. +' +'*/ +Function Join() +End Function + + + +Function LBound() +End Function + +Function LCase() +End Function + +Function Left() +End Function + +Function Len() +End Function + + +Function Loc() +End Function + +Function LOF() +End Function + +Function LTrim() +End Function + +Function RTrim() +End Function + +Function Trim() +End Function + + +Function MacID() +End Function + + + +Function MacScript() +End Function + +'/* +'[Math Function] +'Returns a value of the same type that is passed to it specifying the absolute value of a number. +' +'*/ +Function Abs() +End Function + +'/* +'[Math Function] +'Returns a Double specifying the arctangent of a number. +' +'*/ +Function Atn() +End Function + + +'/* +'[Math Function] +' +'*/ +Function Cos() +End Function + +'/* +'[Math Function] +' +'*/ +Function Exp() +End Function + +'/* +'[Math Function] +' +'*/ +Function Int() +End Function + +'/* +'[Math Function] +' +'*/ +Function Fix() +End Function + +'/* +'[Math Function] +' +'*/ +Function Log() +End Function + + +'/* +'[Math Function] +' +'*/ +Function Rnd() +End Function + +'/* +'[Math Function] +' +'*/ +Function Sgn() +End Function + +'/* +'[Math Function] +' +'*/ +Function Sin() +End Function + +'/* +'[Math Function] +' +'*/ +Function Sqr() +End Function + +'/* +'[Math Function] +' +'*/ +Function Tan() +End Function + + + +Function Mid() +End Function + + +Function Minute() +End Function + + +Function MIRR() +End Function + + +Function Month() +End Function + +Function MonthName() +End Function + +'/* +'Displays a message in a dialog box, waits for the user to click a button, +'and returns an Integer indicating which button the user clicked. +' +'*/ +Function MsgBox(prompt, [ buttons, ] [ title, ] [ helpfile, context ]) +End Function + + +Function Now() +End Function + + +Function NPer() +End Function + + +Function NPV() +End Function + +Function PPmt() +End Function + + +Function QBColor() +End Function + + +Function Rate() +End Function + +'/* +'Returns a string, which is a substring of a string +'expression beginning at the start position (defaults to 1), +'in which a specified substring has been replaced with another +'substring a specified number of times. +' +'*/ +Function Replace(expression, find, replace, [ start, [ count, [ compare ]]]) +End Function + +Function RGB() +End Function + + +Function Right() +End Function + + +Function Round() +End Function + + +Function Second() +End Function + + + +Function Seek() +End Function + + +Function Shell() +End Function + + +Function SNL() +End Function + + +Function Space() +End Function + + +Function Spc() +End Function + + +Function Split() +End Function + + +Function StrComp() +End Function + + + +Function StrConv() +End Function + + +Function String() +End Function + + +Function StrReverse() +End Function + + + +Function Switch() +End Function + + +Function SYD() +End Function + + +Function Tab() +End Function + + +Function Time() +End Function + + + +Function Timer() +End Function + + +Function TimeSerial() +End Function + + +Function TimeValue() +End Function + + + +Function TypeName() +End Function + + +Function UBound() +End Function + + +Function Ucase() +End Function + + +Function VarType() +End Function + + + +Function Weekday() +End Function + + +Function WeekdayName() +End Function + + +Function Year() +End Function \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/range.d.vb b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/range.d.vb new file mode 100644 index 00000000..92a9c7d7 --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/range.d.vb @@ -0,0 +1,625 @@ +'/* +'Represents a cell, a row, a column, a selection of cells containing one or more contiguous blocks of cells, or a 3D range. +' +' +'*/ +Public Class Range() + +'/* +'(Range) +' +'Activates a single cell, which must be inside the current selection. +'To select a range of cells, use the Select method., +' +'Example +' +'This example selects cells A1:C3 on Sheet1 and then makes cell B2 the active cell. +' +' Worksheets("Sheet1").Activate +' Range("A1:C3").Select +' Range("B2").Activate +' +'*/ +Public Sub Activate() + +End Sub + + +'/* +'Adds a comment to the range. +' +'Example: +' +'Worksheets(1).Range("E5").AddComment "Current Sales" +' +'@param {String} text +'*/ +Public Sub AddComment(text As String) + +End Sub + +Public Sub AddCommentThreaded() + +End Sub + +Public Sub AdvancedFilter() + +End Sub + +Public Sub AllocateChanges() + +End Sub + +Public Sub ApplyName() + +End Sub + +Public Sub ApplyOutLineStyles() + +End Sub + +Public Sub AutoComplete() + +End Sub + +Public Sub AutoFill() + +End Sub + +Public Sub AutoFilter() + +End Sub + +Public Sub AutioFit() + +End Sub + +Public Sub AutoOutline() + +End Sub + +Public Sub BorderAround() + +End Sub + +Public Sub Calculate() + +End Sub + +Public Sub CalculateRowMajorOrder() + +End Sub + +Public Sub CheckSpelling() + +End Sub + +Public Sub Clear() + +End Sub + +Public Sub ClearComments() + +End Sub + +Public Sub ClearContents() + +End Sub + +Public Sub ClearFormats() + +End Sub + +Public Sub ClearHyperlinks() + +End Sub + +Public Sub ClearNotes() + +End Sub + +Public Sub ClearOutline() + +End Sub + +Public Sub ColumnDifferences() + +End Sub + +Public Sub Consolidate() + +End Sub + +Public Sub ConvertToLinkedDataType() + +End Sub + +Public Sub Copy() + +End Sub + +Public Sub CopyFromRecordset() + +End Sub + +Public Sub CopyPicture() + +End Sub + +Public Sub CreateNames() + +End Sub + +Public Sub Cut() + +End Sub + +Public Function DataSeries (Rowcol, Type, Date, Step, Stop, Trend) + +End Function + +Public Function DataTypeToText() + +End Function + +Public Function Delete (Shift) + +End Function + +Public Function DialogBox() + +End Function + +Public Function Dirty() + +End Function +Public Function DiscardChanges() + +End Function +Public Function EditionOptions (Type, Option, Name, Reference, Appearance, ChartSize, Format) + +End Function +Public Function ExportAsFixedFormat (Type, FileName, Quality, IncludeDocProperties, IgnorePrintAreas, From, To, OpenAfterPublish, FixedFormatExtClassPtr) + +End Function +Public Function FillDown() + +End Function +Public Function FillLeft() + +End Function + +Public Function FillRight() + +End Function + +Public Function FillUp() + +End Function + +Public Function Find (What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat) + +End Function + +Public Function FindNext (After) + +End Function + +Public Function FindPrevious (Before) + +End Function + +Public Function FlashFill () + +End Function + + +Public Function FunctionWizard () + +End Function + + +Public Function Group (Start, End, By, Periods) + +End Function + +Public Function Insert (Shift, CopyOrigin) + +End Function + + +Public Function InsertIndent (InsertAmount) + +End Function + + +Public Function Justify() + +End Function + + +Public Function ListNames() + +End Function + +Public Function Merge(Across) + +End Function + +Public Function NavigateArrow(TowardPrecedent, ArrowNumber, LinkNumber) + +End Function + +Public Function NoteText(Text, Start, Length) + +End Function + +Public Function Parse(ParseLine, Destination) + +End Function + +Public Function PasteSpecial(Paste, Operation, SkipBlanks, Transpose) + +End Function + + +Public Function PrintOut(From, To, Copies, Preview, ActivePrinter, PrintToFile, Collate, PrToFileName) + +End Function + +Public Function PrintPreview(EnableChanges) + +End Function + +Public Function RemoveDuplicates(Columns , Header) + +End Function + +Public Function RemoveSubtotal() + +End Function + + +Public Function Replace(What, Replacement, LookAt, SearchOrder, MatchCase, MatchByte, SearchFormat, ReplaceFormat) + +End Function + + +Public Function RowDifferences(Comparison) + +End Function + +Public Function Run(Arg1, Arg2, Arg3, Arg4, Arg5...) + +End Function + +Public Function Select() + +End Function + +Public Function SetCellDataTypeFromCell(Range, LanguageCulture) + +End Function + + +Public Function SetPhonetic() + +End Function + + +Public Function Show() + +End Function + + +Public Function ShowCard() + +End Function + + +Public Function ShowDependents(Remove) + +End Function + + +Public Function ShowErrors() + +End Function + + +Public Function ShowPrecedents(Remove) + +End Function + + +Public Function Sort(Key1, Order1, Key2, Type, Order2, Key3, Order3, Header, OrderCustom, MatchCase, Orientation, SortMethod, DataOption1, DataOption2, DataOption3) + +End Function + + +Public Function SortSpecial(SortMethod, Key1, Order1, Type, Key2, Order2, Key3, Order3, Header, OrderCustom, MatchCase, Orientation, DataOption1, DataOption2, DataOption3) + +End Function + +Public Function Speak(SpeakDirection, SpeakFormulas) + +End Function + + +Public Function SpecialCells(Type, Value) + +End Function + +Public Function SubscribeTo(Edition, Format) + +End Function + +Public Function Subtotal(GroupBy, Function, TotalList, Replace, PageBreaks, SummaryBelowData) + +End Function + + +Public Function Table(RowInput, ColumnInput) + +End Function + + +Public Function TextToColumns(Destination, DataType, TextQualifier, ConsecutiveDelimiter, Tab, Semicolon, Comma, Space, Other, OtherChar, FieldInfo, DecimalSeparator, ThousandsSeparator, TrailingMinusNumbers + +End Function + + +Public Function Ungroup() + +End Function + + +Public Function UnMerge() + +End Function + +Public Property AddIndent As Variant + +Public Function Address(RowAbsolute, ColumnAbsolute, ReferenceStyle, External, RelativeTo) As Variant +End Function + +Public Function AddressLocal(RowAbsolute, ColumnAbsolute, ReferenceStyle, External, RelativeTo) As Range +End Function + +Public Property Application As Application + +Public Property Areas As Areas + +Public Property Borders As Variant + +Public Property Cells As Range + +Public Function Characters(Start, Length) As Variant +End Function + +Public Property Column As Long + +Public Property Columns As Long + +Public Property ColumnWidth As Variant + +Public Property Comment As Variant + +Public Property CommentThreaded As Variant + + +Public Property Count As Long + + +Public Property CountLarge As Variant + + +Public Property Creator As Integer + + +Public Property CurrentArray As Range + +'/* +'Returns a Range object that represents the current region. +'The current region is a range bounded by any combination of blank rows and blank columns. Read-only. +' +'Example +'Worksheets("Sheet1").Activate +'ActiveCell.CurrentRegion.Select +'*/ +Public Property CurrentRegion As Range + +Public Property Dependents As Range + +Public Property DirectDependents As Range + +Public Property DirectPrecedents As Range + +Public Property DisplayFormat As Object + + +Public Function End(Direction) As Object +End Function + +Public Property EntireColumn As Range + + +Public Property EntireRow As Range + + +Public Property Errors As Errors + + +Public Property Font As Font + + +Public Property FormatConditions As Range + +Public Property Formula As Variant + +Public Property FormulaArray As Variant + +Public Property FormulaHidden As Variant + + +Public Property FormulaLocal As Object + +Public Property FormulaR1C1 As Varaint + +Public Property FormulaR1C1Local As Varaint + +Public Property HasArray As Varaint + +Public Property HasFormula As Varaint + +Public Property HasRichDataType As Varaint + +Public Property Height As Double + +Public Property Hidden As Variant + +Public Property HorizontalAlignment As Variant + +Public Property Hyperlinks As Object + +Public Property ID As String + +Public Property IndentLevel As Variant + +Public Property Interior As Double + +Public Function Item (RowIndex, ColumnIndex) As Range +End Function + + +Public Property Left As Variant + + +Public Property LinkedDataTypeState As Variant + +Public Property ListHeaderRows As Variant + + +Public Property ListObject As Object + +Public Property LocationInTable As Variant + +Public Property Locked As Variant + +Public Property MDX As String + +Public Property MergeArea As Range + +Public Property MergeCells As Boolean + +Public Property Name As Variant + +Public Property Next As Range + +Public Property NumberFormat As Variant + +Public Property NumberFormatLocal As Variant + +Public Function Offset (RowOffset, ColumnOffset) As Range + +End Function + + +Public Property Orientation As Variant + +Public Property OutlineLevel As Variant + +Public Property PageBreak As Variant + +Public Property Parent As Variant + +Public Property Phonetic As Variant + +Public Property Phonetics As Variant + +Public Property PivotCell As Variant + + +Public Property PivotField As Variant + + +Public Property PivotItem As Variant + +Public Property PivotTable As Variant + +Public Property Precedents As Range + +Public Property PrefixCharacter As Variant + + +Public Property Previous As Range + +Public Property QueryTable As Variant + +Public Function Range (Cell1, Cell2) As Range +End Function + +Public Property ReadingOrder As Variant + +Public Function Resize (RowSize, ColumnSize) As Range +End Function + + +Public Property Row As Long + +Public Property RowHeight As Double + +Public Property Rows As Range + +Public Property ServerActions As Variant + + +Public Property ShowDetail As Variant + + +Public Property ShrinkToFit As Variant + + +Public Property SoundNote As Variant + + +Public Property SparklineGroups As Variant + + +Public Property Style As Variant + +Public Property Summary As Variant + + +Public Property Text As String + +Public Property Top As Variant + +Public Property UseStandardHeight As Variant + +Public Property UseStandardWidth As Variant + +Public Property Validation As Variant + +Public Function Value (RangeValueDataType) As Variant +End Function + +Public Property Value2 As Variant + + +Public Property VerticalAlignment As Variant + +Public Property Width As Double + + + +Public Property Worksheet As Worksheet + + +Public Property WrapText As Variant + +Public Property XPath As XPath + + + +End Class diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/workbook.d.vb b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/workbook.d.vb new file mode 100644 index 00000000..55764e2b --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/workbook.d.vb @@ -0,0 +1,157 @@ +'/* +'Represents a Microsoft Excel workbook. +' +' +'*/ +Public Class Workbook() + +'/* +'Returns a String that represents the complete path to the +'workbook/file that this workbook object represents. +' +'*/ +Public Property Path As String + + +Public Property Worksheets As Worksheet + +'/* +'True if a backup file is created when this file is saved. Read-only Boolean. +' +'@type {Boolean} +'*/ +Public Property CreateBackup As Boolean + +'/* +'Returns a String value that represents the name of the object. +' +'@type {Boolean} +'*/ +Public Property Name As String + +'/* +'True if no changes have been made to the specified workbook since it was last saved. Read/write Boolean. +' +'Example: +'If Not ActiveWorkbook.Saved Then +' MsgBox "This workbook contains unsaved changes." +'End If +' +'@type {Boolean} +'*/ +Public Property Saved As String + +'/* +'Returns a Sheets collection that represents all the sheets in the specified workbook. Read-only Sheets object. +' +'Example: +'Set newSheet = Sheets.Add(Type:=xlWorksheet) +'For i = 1 To Sheets.Count +' newSheet.Cells(i, 1).Value = Sheets(i).Name +' Next i +' +'@type {Sheets} +'*/ +Public Property Sheets As Worksheets + + +'/* +' +'Activates the first window associated with the workbook. +' +'*/ +Public Function Activate() + +End Function + +'/* +' +'Closes the object. +' +'Example +' +'Workbooks("BOOK1.XLS").Close SaveChanges:=False +' +'@param {Variant} SaveChanges:[Optional] True or false +'@param {Variant} FileName:[Optional] Saves changes under this file name. +'@param {Variant} RouteWorkbook:[Optional] True or False +'*/ +Public Function Close(SaveChanges,FileName,RouteWorkbook) + +End Function + +'/* +'Saves changes to the specified workbook. +'*/ +Public Function Save() + +End Function + +'/* +'Saves changes to the workbook in a different file. +' +'@param {Variant} FileName:[Optional] +'@param {Variant} FileFormat:[Optional] +'@param {Variant} Password:[Optional] +'@param {Variant} WriteResPassword:[Optional] +'@param {Variant} ReadOnlyRecommended:[Optional] +'@param {Variant} CreateBackup:[Optional] +'@param {Variant} AccessMode:[Optional] +'@param {Variant} ConflictResolution:[Optional] +'@param {Variant} AddToMru:[Optional] +'@param {Variant} TextCodepage:[Optional] +'@param {Variant} TextVisualLayout:[Optional] +'@param {Variant} Local:[Optional] +'*/ +Public Function SaveAs(FileName, FileFormat, Password, WriteResPassword, ReadOnlyRecommended, CreateBackup, AccessMode, ConflictResolution, AddToMru, TextCodepage, TextVisualLayout, Local) + +End Function + + +'/* +'Exports the data that has been mapped to the specified XML schema map to an XML data file. +' +'@param {String} FileName:[Required] +'@param {XmlMap} Map:[Required] +'*/ +Public Function SaveAsXMLData(FileName, Map) + +End Function + + +'/* +'Saves a copy of the workbook to a file but doesn't modify the open workbook in memory. +' +'Example +'ActiveWorkbook.SaveCopyAs "C:\TEMP\XXXX.XLS" +' +'@param {Variant} FileName:[Required] +'*/ +Public Function SaveCopyAs(FileName, Map) + +End Function + +'/* +'Sends the workbook by using the installed mail system. +' +'Example +'ActiveWorkbook.SendMail recipients:="Jean Selva" +' +'@param {Variant} Recipients:[Required] +'@param {Variant} Subject:[Optional] +'@param {Variant} ReturnReceipt:[Optional] +'*/ +Public Function SendMail(Recipients, Subject, ReturnReceipt) + +End Function + +'/* +' +'The ExportAsFixedFormat method is used to publish +'a workbook to either the PDF or XPS format. +' +'*/ +Public Function ExportAsFixedFormat(Type, FileName, Quality, IncludeDocProperties, IgnorePrintAreas, From, To, OpenAfterPublish, FixedFormatExtClassPtr) +End Function + +End Class \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/workbooks.d.vb b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/workbooks.d.vb new file mode 100644 index 00000000..07f71c5f --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/workbooks.d.vb @@ -0,0 +1,109 @@ +'/* +'A collection of all the Workbook objects that are currently open in the Microsoft Excel application. +' +'*/ +Public Class Workbooks() + +'/* +'Creates a new workbook. The new workbook becomes the active workbook. +' +'@param {Variant} Template:[Optional] Determines how the new workbook is created. +'If this argument is a string specifying the name of an existing Microsoft Excel file, +'the new workbook is created with the specified file as a template. +'*/ +Public Function Add(Template) + +End Function + + +'/* +'True if Microsoft Excel can check out a specified workbook from a server. +'Read/write Boolean. +' +'@param {String} FileName:[Required] The name of the file to check out. +' +'*/ +Public Function CanCheckOut (FileName) + +End Function + + +Public Function CheckOut (FileName) + +End Function + + +Public Function Close () + +End Function + +'/* +' +'Opens a workbook. +' +'Example +'Workbooks.Open "ANALYSIS.XLS" +'ActiveWorkbook.RunAutoMacros xlAutoOpen +'*/ +Public Function Open (FileName, UpdateLinks, ReadOnly, Format, Password, WriteResPassword, IgnoreReadOnlyRecommended, Origin, Delimiter, Editable, Notify, Converter, AddToMru, Local, CorruptLoad) As Workbook + +End Function + +'/* +'Returns a Workbook object representing a database. +'*/ +Public Function OpenDatabase (FileName, CommandText, CommandType, BackgroundQuery, ImportDataAs) + +End Function + + +'/* +'Loads and parses a text file as a new workbook with a single sheet that contains the parsed text-file data. +'*/ +Public Function (FileName, Origin, StartRow, DataType, TextQualifier, ConsecutiveDelimiter, Tab, Semicolon, Comma, Space, Other, OtherChar, FieldInfo, TextVisualLayout, DecimalSeparator, ThousandsSeparator, TrailingMinusNumbers, Local) + +End Function + +'/* +'Opens an XML data file. Returns a Workbook object. +'*/ +Public Function OpenXML (FileName, Stylesheets, LoadOption) + +End Function + + +'/* +'When used without an object qualifier, this property returns an +'Application object that represents the Microsoft Excel application. +' +'*/ +Public Property Application As Application + + +'/* +'Returns a Long value that represents the number of objects in the collection. +' +'*/ +Public Property Count As Long + +'/* +'Returns a 32-bit integer that indicates the application in which this object was created. Read-only Long. +' +'*/ +Public Property Creator As Integer + + + +'/* +'Returns a single object from a collection. +' +'*/ +Public Property Item(Index) As Object + +'/* +'Returns the parent object for the specified object. Read-only. +' +'*/ +Public Property Parent As Object + +End Class \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/worksheet.d.vb b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/worksheet.d.vb new file mode 100644 index 00000000..24a02271 --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/worksheet.d.vb @@ -0,0 +1,86 @@ +'/* +'Represents a worksheet. +' +'Example +' +'Worksheets(1).Visible = False +' +'*/ +Public Class Worksheet() + + +'/* +'Makes the current sheet the active sheet. +' +'Example +'ActiveWorkbook.SendMail recipients:="Jean Selva" +'*/ +Public Sub Activate() + +End Sub + + +Public Sub Calculate() + +End Sub + +Public Sub Copy() + +End Sub + +Public Sub Delete() +End Sub + +Public Sub Move() + +End Sub + +Public Sub Past() + +End Sub + +Public Sub PastSpecial() + +End Sub + +Public Sub Select() +End Sub + +Public Sub SaveAs() + +End Sub + +'/* +' +'Returns a Range object that represents a cell or a range of cells. +' +'Example: +' +'Worksheets("Sheet1").Range("A1").Value = 3.14159 +' +'*/ +Public Property Range As Range + + +'/* +' +'Returns a Range object that represents all the rows on the specified worksheet. +' +'Example: +' +'Worksheets("Sheet1").Rows(3).Delete +' +'*/ +Public Property Row As Range + + +'/* +' +'Returns a Long value that represents the index number of the +'object within the collection of similar objects.orksheets("Sheet1").Rows(3).Delete +' +'*/ +Public Property Index As Long + + +End Class \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/worksheets.d.vb b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/worksheets.d.vb new file mode 100644 index 00000000..7d775495 --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/worksheets.d.vb @@ -0,0 +1,54 @@ +'/* +'A collection of all the Worksheet objects in the specified or active workbook. Each Worksheet object represents a worksheet. +' +'Example +' +'Worksheets(1).Visible = False +' +'*/ +Public Class Worksheets() + +'/* +'Constructor +' +'*/ +Public Sub New(Name As String) As Worksheet + +End Sub + +Public Sub Add() + +End Sub + + +Public Sub Add2() + +End Sub + +Public Sub Copy() + +End Sub + +Public Sub Delete() +End Sub + +Public Sub Move() + +End Sub + +Public Sub FillAcrossSheets() + +End Sub + +Public Sub PrintOut() + +End Sub + +Public Sub PrintPreview() +End Sub + +Public Sub Select() + +End Sub + +End Class \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/xvba.package.json b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/xvba.package.json new file mode 100644 index 00000000..2fb972d9 --- /dev/null +++ b/XVBA/MSS/■事業計画VBA/xvba_modules/excel-types/xvba.package.json @@ -0,0 +1,15 @@ +{ + "package": "excel-types", + "version": "1.0.0", + "author": "Alberto Oliveira", + "email": "alberto.aeraph@gmail.comn", + "license": "ISC", + "repository": { + "type": "git", + "url": "https://github.com/Aeraphe/excel-types.git" + }, + "description": "Creating amazing XVBA packages", + "dependencies": {}, + "dev_dependencies": {}, + "homepage": "https://github.com/Aeraphe/xvba-cli" +} \ No newline at end of file diff --git a/XVBA/MSS/■事業計画VBA/【2025経営計画】新・事業計画集計v3.5.xlsm b/XVBA/MSS/■事業計画VBA/【2025経営計画】新・事業計画集計v3.5.xlsm new file mode 100644 index 00000000..eeafd148 Binary files /dev/null and b/XVBA/MSS/■事業計画VBA/【2025経営計画】新・事業計画集計v3.5.xlsm differ diff --git a/XVBA/MSS/■事業計画VBA/事業計画集計v3.2.xlsm b/XVBA/MSS/■事業計画VBA/事業計画集計v3.2.xlsm new file mode 100644 index 00000000..b1024484 Binary files /dev/null and b/XVBA/MSS/■事業計画VBA/事業計画集計v3.2.xlsm differ diff --git a/XVBA/汎用ツール/.vscode/settings.json b/XVBA/汎用ツール/.vscode/settings.json new file mode 100644 index 00000000..49431ab8 --- /dev/null +++ b/XVBA/汎用ツール/.vscode/settings.json @@ -0,0 +1,3 @@ +{ + "files.encoding": "shiftjis" +} \ No newline at end of file diff --git a/XVBA/汎用ツール/config.json b/XVBA/汎用ツール/config.json new file mode 100644 index 00000000..cdf6e5e7 --- /dev/null +++ b/XVBA/汎用ツール/config.json @@ -0,0 +1,14 @@ +{ + "app_name": "XVBA", + "description": "", + "author": "", + "email": "", + "create_ate": "Thu May 29 2025 16:42:04 GMT+0900 (日本標準時)", + "excel_file": "データ取得汎用ツール.xlsm", + "vba_folder": "vba-files", + "ribbon_file": "customUI14", + "ribbon_folder": "ribbons", + "logs": "on", + "xvba_packages": {}, + "xvba_dev_packages": {} +} \ No newline at end of file diff --git a/XVBA/汎用ツール/package.json b/XVBA/汎用ツール/package.json new file mode 100644 index 00000000..a8deae27 --- /dev/null +++ b/XVBA/汎用ツール/package.json @@ -0,0 +1,15 @@ +{ + "name": "xvba-app", + "version": "1.0.0", + "description": "A XVBA App", + "main": "index.js", + "author": "LocalSmart", + "license": "ISC", + "dependencies": { + "excel-types": "1.0.0", + "Xlog": "1.0.0" + }, + "devDependencies": { + "@localsmart/xvba-cli": "^1.0.2" + } +} \ No newline at end of file diff --git a/XVBA/汎用ツール/vba-files/Class/Sheet1.cls b/XVBA/汎用ツール/vba-files/Class/Sheet1.cls new file mode 100644 index 00000000..34122d33 --- /dev/null +++ b/XVBA/汎用ツール/vba-files/Class/Sheet1.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "Sheet1" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/汎用ツール/vba-files/Class/ThisWorkbook.cls b/XVBA/汎用ツール/vba-files/Class/ThisWorkbook.cls new file mode 100644 index 00000000..6e197c86 --- /dev/null +++ b/XVBA/汎用ツール/vba-files/Class/ThisWorkbook.cls @@ -0,0 +1,11 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ThisWorkbook" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = True +Option Explicit + diff --git a/XVBA/汎用ツール/vba-files/Module/JsonConverter.bas b/XVBA/汎用ツール/vba-files/Module/JsonConverter.bas new file mode 100644 index 00000000..876b8650 --- /dev/null +++ b/XVBA/汎用ツール/vba-files/Module/JsonConverter.bas @@ -0,0 +1,1123 @@ +Attribute VB_Name = "JsonConverter" +'' +' VBA-JSON v2.3.1 +' (c) Tim Hall - https://github.com/VBA-tools/VBA-JSON +' +' JSON Converter for VBA +' +' Errors: +' 10001 - JSON parse error +' +' @class JsonConverter +' @author tim.hall.engr@gmail.com +' @license MIT (http://www.opensource.org/licenses/mit-license.php) +'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' +' +' Based originally on vba-json (with extensive changes) +' BSD license included below +' +' JSONLib, http://code.google.com/p/vba-json/ +' +' Copyright (c) 2013, Ryo Yokoyama +' All rights reserved. +' +' Redistribution and use in source and binary forms, with or without +' modification, are permitted provided that the following conditions are met: +' * Redistributions of source code must retain the above copyright +' notice, this list of conditions and the following disclaimer. +' * Redistributions in binary form must reproduce the above copyright +' notice, this list of conditions and the following disclaimer in the +' documentation and/or other materials provided with the distribution. +' * Neither the name of the nor the +' names of its contributors may be used to endorse or promote products +' derived from this software without specific prior written permission. +' +' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +' ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +' DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +' DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +' (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +' LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +' ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +' (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +' SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' +Option Explicit + +' === VBA-UTC Headers +#If Mac Then + +#If VBA7 Then + +' 64-bit Mac (2016) +Private Declare PtrSafe Function utc_popen Lib "/usr/lib/libc.dylib" Alias "popen" _ + (ByVal utc_Command As String, ByVal utc_Mode As String) As LongPtr +Private Declare PtrSafe Function utc_pclose Lib "/usr/lib/libc.dylib" Alias "pclose" _ + (ByVal utc_File As LongPtr) As LongPtr +Private Declare PtrSafe Function utc_fread Lib "/usr/lib/libc.dylib" Alias "fread" _ + (ByVal utc_Buffer As String, ByVal utc_Size As LongPtr, ByVal utc_Number As LongPtr, ByVal utc_File As LongPtr) As LongPtr +Private Declare PtrSafe Function utc_feof Lib "/usr/lib/libc.dylib" Alias "feof" _ + (ByVal utc_File As LongPtr) As LongPtr + +#Else + +' 32-bit Mac +Private Declare Function utc_popen Lib "libc.dylib" Alias "popen" _ + (ByVal utc_Command As String, ByVal utc_Mode As String) As Long +Private Declare Function utc_pclose Lib "libc.dylib" Alias "pclose" _ + (ByVal utc_File As Long) As Long +Private Declare Function utc_fread Lib "libc.dylib" Alias "fread" _ + (ByVal utc_Buffer As String, ByVal utc_Size As Long, ByVal utc_Number As Long, ByVal utc_File As Long) As Long +Private Declare Function utc_feof Lib "libc.dylib" Alias "feof" _ + (ByVal utc_File As Long) As Long + +#End If + +#ElseIf VBA7 Then + +' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724421.aspx +' http://msdn.microsoft.com/en-us/library/windows/desktop/ms724949.aspx +' http://msdn.microsoft.com/en-us/library/windows/desktop/ms725485.aspx +Private Declare PtrSafe Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long +Private Declare PtrSafe Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long +Private Declare PtrSafe Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long + +#Else + +Private Declare Function utc_GetTimeZoneInformation Lib "kernel32" Alias "GetTimeZoneInformation" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION) As Long +Private Declare Function utc_SystemTimeToTzSpecificLocalTime Lib "kernel32" Alias "SystemTimeToTzSpecificLocalTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpUniversalTime As utc_SYSTEMTIME, utc_lpLocalTime As utc_SYSTEMTIME) As Long +Private Declare Function utc_TzSpecificLocalTimeToSystemTime Lib "kernel32" Alias "TzSpecificLocalTimeToSystemTime" _ + (utc_lpTimeZoneInformation As utc_TIME_ZONE_INFORMATION, utc_lpLocalTime As utc_SYSTEMTIME, utc_lpUniversalTime As utc_SYSTEMTIME) As Long + +#End If + +#If Mac Then + +#If VBA7 Then +Private Type utc_ShellResult + utc_Output As String + utc_ExitCode As LongPtr +End Type + +#Else + +Private Type utc_ShellResult + utc_Output As String + utc_ExitCode As Long +End Type + +#End If + +#Else + +Private Type utc_SYSTEMTIME + utc_wYear As Integer + utc_wMonth As Integer + utc_wDayOfWeek As Integer + utc_wDay As Integer + utc_wHour As Integer + utc_wMinute As Integer + utc_wSecond As Integer + utc_wMilliseconds As Integer +End Type + +Private Type utc_TIME_ZONE_INFORMATION + utc_Bias As Long + utc_StandardName(0 To 31) As Integer + utc_StandardDate As utc_SYSTEMTIME + utc_StandardBias As Long + utc_DaylightName(0 To 31) As Integer + utc_DaylightDate As utc_SYSTEMTIME + utc_DaylightBias As Long +End Type + +#End If +' === End VBA-UTC + +Private Type json_Options + ' VBA only stores 15 significant digits, so any numbers larger than that are truncated + ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits + ' See: http://support.microsoft.com/kb/269370 + ' + ' By default, VBA-JSON will use String for numbers longer than 15 characters that contain only digits + ' to override set `JsonConverter.JsonOptions.UseDoubleForLargeNumbers = True` + UseDoubleForLargeNumbers As Boolean + + ' The JSON standard requires object keys to be quoted (" or '), use this option to allow unquoted keys + AllowUnquotedKeys As Boolean + + ' The solidus (/) is not required to be escaped, use this option to escape them as \/ in ConvertToJson + EscapeSolidus As Boolean +End Type +Public JsonOptions As json_Options + +' ============================================= ' +' Public Methods +' ============================================= ' + +'' +' Convert JSON string to object (Dictionary/Collection) +' +' @method ParseJson +' @param {String} json_String +' @return {Object} (Dictionary or Collection) +' @throws 10001 - JSON parse error +'' +Public Function ParseJson(ByVal JsonString As String) As Object + Dim json_Index As Long + json_Index = 1 + + ' Remove vbCr, vbLf, and vbTab from json_String + JsonString = VBA.Replace(VBA.Replace(VBA.Replace(JsonString, VBA.vbCr, ""), VBA.vbLf, ""), VBA.vbTab, "") + + json_SkipSpaces JsonString, json_Index + Select Case VBA.Mid$(JsonString, json_Index, 1) + Case "{" + Set ParseJson = json_ParseObject(JsonString, json_Index) + Case "[" + Set ParseJson = json_ParseArray(JsonString, json_Index) + Case Else + ' Error: Invalid JSON string + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(JsonString, json_Index, "Expecting '{' or '['") + End Select +End Function + +'' +' Convert object (Dictionary/Collection/Array) to JSON +' +' @method ConvertToJson +' @param {Variant} JsonValue (Dictionary, Collection, or Array) +' @param {Integer|String} Whitespace "Pretty" print json with given number of spaces per indentation (Integer) or given string +' @return {String} +'' +Public Function ConvertToJson(ByVal JsonValue As Variant, Optional ByVal Whitespace As Variant, Optional ByVal json_CurrentIndentation As Long = 0) As String + Dim json_Buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long + Dim json_Index As Long + Dim json_LBound As Long + Dim json_UBound As Long + Dim json_IsFirstItem As Boolean + Dim json_Index2D As Long + Dim json_LBound2D As Long + Dim json_UBound2D As Long + Dim json_IsFirstItem2D As Boolean + Dim json_Key As Variant + Dim json_Value As Variant + Dim json_DateStr As String + Dim json_Converted As String + Dim json_SkipItem As Boolean + Dim json_PrettyPrint As Boolean + Dim json_Indentation As String + Dim json_InnerIndentation As String + + json_LBound = -1 + json_UBound = -1 + json_IsFirstItem = True + json_LBound2D = -1 + json_UBound2D = -1 + json_IsFirstItem2D = True + json_PrettyPrint = Not IsMissing(Whitespace) + + Select Case VBA.VarType(JsonValue) + Case VBA.vbNull + ConvertToJson = "null" + Case VBA.vbDate + ' Date + json_DateStr = ConvertToIso(VBA.CDate(JsonValue)) + + ConvertToJson = """" & json_DateStr & """" + Case VBA.vbString + ' String (or large number encoded as string) + If Not JsonOptions.UseDoubleForLargeNumbers And json_StringIsLargeNumber(JsonValue) Then + ConvertToJson = JsonValue + Else + ConvertToJson = """" & json_Encode(JsonValue) & """" + End If + Case VBA.vbBoolean + If JsonValue Then + ConvertToJson = "true" + Else + ConvertToJson = "false" + End If + Case VBA.vbArray To VBA.vbArray + VBA.vbByte + If json_PrettyPrint Then + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) + json_InnerIndentation = VBA.String$(json_CurrentIndentation + 2, Whitespace) + Else + json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) + json_InnerIndentation = VBA.Space$((json_CurrentIndentation + 2) * Whitespace) + End If + End If + + ' Array + json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength + + On Error Resume Next + + json_LBound = LBound(JsonValue, 1) + json_UBound = UBound(JsonValue, 1) + json_LBound2D = LBound(JsonValue, 2) + json_UBound2D = UBound(JsonValue, 2) + + If json_LBound >= 0 And json_UBound >= 0 Then + For json_Index = json_LBound To json_UBound + If json_IsFirstItem Then + json_IsFirstItem = False + Else + ' Append comma to previous line + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength + End If + + If json_LBound2D >= 0 And json_UBound2D >= 0 Then + ' 2D Array + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + End If + json_BufferAppend json_Buffer, json_Indentation & "[", json_BufferPosition, json_BufferLength + + For json_Index2D = json_LBound2D To json_UBound2D + If json_IsFirstItem2D Then + json_IsFirstItem2D = False + Else + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength + End If + + json_Converted = ConvertToJson(JsonValue(json_Index, json_Index2D), Whitespace, json_CurrentIndentation + 2) + + ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If json_Converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(JsonValue(json_Index, json_Index2D)) Then + json_Converted = "null" + End If + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_InnerIndentation & json_Converted + End If + + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength + Next json_Index2D + + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + End If + + json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + json_IsFirstItem2D = True + Else + ' 1D Array + json_Converted = ConvertToJson(JsonValue(json_Index), Whitespace, json_CurrentIndentation + 1) + + ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If json_Converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(JsonValue(json_Index)) Then + json_Converted = "null" + End If + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_Indentation & json_Converted + End If + + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength + End If + Next json_Index + End If + + On Error GoTo 0 + + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) + Else + json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) + End If + End If + + json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + + ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) + + ' Dictionary or Collection + Case VBA.vbObject + If json_PrettyPrint Then + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation + 1, Whitespace) + Else + json_Indentation = VBA.Space$((json_CurrentIndentation + 1) * Whitespace) + End If + End If + + ' Dictionary + If VBA.TypeName(JsonValue) = "Dictionary" Then + json_BufferAppend json_Buffer, "{", json_BufferPosition, json_BufferLength + For Each json_Key In JsonValue.Keys + ' For Objects, undefined (Empty/Nothing) is not added to object + json_Converted = ConvertToJson(JsonValue(json_Key), Whitespace, json_CurrentIndentation + 1) + If json_Converted = "" Then + json_SkipItem = json_IsUndefined(JsonValue(json_Key)) + Else + json_SkipItem = False + End If + + If Not json_SkipItem Then + If json_IsFirstItem Then + json_IsFirstItem = False + Else + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_Indentation & """" & json_Key & """: " & json_Converted + Else + json_Converted = """" & json_Key & """:" & json_Converted + End If + + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength + End If + Next json_Key + + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) + Else + json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) + End If + End If + + json_BufferAppend json_Buffer, json_Indentation & "}", json_BufferPosition, json_BufferLength + + ' Collection + ElseIf VBA.TypeName(JsonValue) = "Collection" Then + json_BufferAppend json_Buffer, "[", json_BufferPosition, json_BufferLength + For Each json_Value In JsonValue + If json_IsFirstItem Then + json_IsFirstItem = False + Else + json_BufferAppend json_Buffer, ",", json_BufferPosition, json_BufferLength + End If + + json_Converted = ConvertToJson(json_Value, Whitespace, json_CurrentIndentation + 1) + + ' For Arrays/Collections, undefined (Empty/Nothing) is treated as null + If json_Converted = "" Then + ' (nest to only check if converted = "") + If json_IsUndefined(json_Value) Then + json_Converted = "null" + End If + End If + + If json_PrettyPrint Then + json_Converted = vbNewLine & json_Indentation & json_Converted + End If + + json_BufferAppend json_Buffer, json_Converted, json_BufferPosition, json_BufferLength + Next json_Value + + If json_PrettyPrint Then + json_BufferAppend json_Buffer, vbNewLine, json_BufferPosition, json_BufferLength + + If VBA.VarType(Whitespace) = VBA.vbString Then + json_Indentation = VBA.String$(json_CurrentIndentation, Whitespace) + Else + json_Indentation = VBA.Space$(json_CurrentIndentation * Whitespace) + End If + End If + + json_BufferAppend json_Buffer, json_Indentation & "]", json_BufferPosition, json_BufferLength + End If + + ConvertToJson = json_BufferToString(json_Buffer, json_BufferPosition) + Case VBA.vbInteger, VBA.vbLong, VBA.vbSingle, VBA.vbDouble, VBA.vbCurrency, VBA.vbDecimal + ' Number (use decimals for numbers) + ConvertToJson = VBA.Replace(JsonValue, ",", ".") + Case Else + ' vbEmpty, vbError, vbDataObject, vbByte, vbUserDefinedType + ' Use VBA's built-in to-string + On Error Resume Next + ConvertToJson = JsonValue + On Error GoTo 0 + End Select +End Function + +' ============================================= ' +' Private Functions +' ============================================= ' + +Private Function json_ParseObject(json_String As String, ByRef json_Index As Long) As Dictionary + Dim json_Key As String + Dim json_NextChar As String + + Set json_ParseObject = New Dictionary + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) <> "{" Then + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '{'") + Else + json_Index = json_Index + 1 + + Do + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) = "}" Then + json_Index = json_Index + 1 + Exit Function + ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then + json_Index = json_Index + 1 + json_SkipSpaces json_String, json_Index + End If + + json_Key = json_ParseKey(json_String, json_Index) + json_NextChar = json_Peek(json_String, json_Index) + If json_NextChar = "[" Or json_NextChar = "{" Then + Set json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) + Else + json_ParseObject.Item(json_Key) = json_ParseValue(json_String, json_Index) + End If + Loop + End If +End Function + +Private Function json_ParseArray(json_String As String, ByRef json_Index As Long) As Collection + Set json_ParseArray = New Collection + + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) <> "[" Then + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '['") + Else + json_Index = json_Index + 1 + + Do + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) = "]" Then + json_Index = json_Index + 1 + Exit Function + ElseIf VBA.Mid$(json_String, json_Index, 1) = "," Then + json_Index = json_Index + 1 + json_SkipSpaces json_String, json_Index + End If + + json_ParseArray.Add json_ParseValue(json_String, json_Index) + Loop + End If +End Function + +Private Function json_ParseValue(json_String As String, ByRef json_Index As Long) As Variant + json_SkipSpaces json_String, json_Index + Select Case VBA.Mid$(json_String, json_Index, 1) + Case "{" + Set json_ParseValue = json_ParseObject(json_String, json_Index) + Case "[" + Set json_ParseValue = json_ParseArray(json_String, json_Index) + Case """", "'" + json_ParseValue = json_ParseString(json_String, json_Index) + Case Else + If VBA.Mid$(json_String, json_Index, 4) = "true" Then + json_ParseValue = True + json_Index = json_Index + 4 + ElseIf VBA.Mid$(json_String, json_Index, 5) = "false" Then + json_ParseValue = False + json_Index = json_Index + 5 + ElseIf VBA.Mid$(json_String, json_Index, 4) = "null" Then + json_ParseValue = Null + json_Index = json_Index + 4 + ElseIf VBA.InStr("+-0123456789", VBA.Mid$(json_String, json_Index, 1)) Then + json_ParseValue = json_ParseNumber(json_String, json_Index) + Else + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting 'STRING', 'NUMBER', null, true, false, '{', or '['") + End If + End Select +End Function + +Private Function json_ParseString(json_String As String, ByRef json_Index As Long) As String + Dim json_Quote As String + Dim json_Char As String + Dim json_Code As String + Dim json_Buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long + + json_SkipSpaces json_String, json_Index + + ' Store opening quote to look for matching closing quote + json_Quote = VBA.Mid$(json_String, json_Index, 1) + json_Index = json_Index + 1 + + Do While json_Index > 0 And json_Index <= Len(json_String) + json_Char = VBA.Mid$(json_String, json_Index, 1) + + Select Case json_Char + Case "\" + ' Escaped string, \\, or \/ + json_Index = json_Index + 1 + json_Char = VBA.Mid$(json_String, json_Index, 1) + + Select Case json_Char + Case """", "\", "/", "'" + json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "b" + json_BufferAppend json_Buffer, vbBack, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "f" + json_BufferAppend json_Buffer, vbFormFeed, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "n" + json_BufferAppend json_Buffer, vbCrLf, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "r" + json_BufferAppend json_Buffer, vbCr, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "t" + json_BufferAppend json_Buffer, vbTab, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + Case "u" + ' Unicode character escape (e.g. \u00a9 = Copyright) + json_Index = json_Index + 1 + json_Code = VBA.Mid$(json_String, json_Index, 4) + json_BufferAppend json_Buffer, VBA.ChrW(VBA.Val("&h" + json_Code)), json_BufferPosition, json_BufferLength + json_Index = json_Index + 4 + End Select + Case json_Quote + json_ParseString = json_BufferToString(json_Buffer, json_BufferPosition) + json_Index = json_Index + 1 + Exit Function + Case Else + json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength + json_Index = json_Index + 1 + End Select + Loop +End Function + +Private Function json_ParseNumber(json_String As String, ByRef json_Index As Long) As Variant + Dim json_Char As String + Dim json_Value As String + Dim json_IsLargeNumber As Boolean + + json_SkipSpaces json_String, json_Index + + Do While json_Index > 0 And json_Index <= Len(json_String) + json_Char = VBA.Mid$(json_String, json_Index, 1) + + If VBA.InStr("+-0123456789.eE", json_Char) Then + ' Unlikely to have massive number, so use simple append rather than buffer here + json_Value = json_Value & json_Char + json_Index = json_Index + 1 + Else + ' Excel only stores 15 significant digits, so any numbers larger than that are truncated + ' This can lead to issues when BIGINT's are used (e.g. for Ids or Credit Cards), as they will be invalid above 15 digits + ' See: http://support.microsoft.com/kb/269370 + ' + ' Fix: Parse -> String, Convert -> String longer than 15/16 characters containing only numbers and decimal points -> Number + ' (decimal doesn't factor into significant digit count, so if present check for 15 digits + decimal = 16) + json_IsLargeNumber = IIf(InStr(json_Value, "."), Len(json_Value) >= 17, Len(json_Value) >= 16) + If Not JsonOptions.UseDoubleForLargeNumbers And json_IsLargeNumber Then + json_ParseNumber = json_Value + Else + ' VBA.Val does not use regional settings, so guard for comma is not needed + json_ParseNumber = VBA.Val(json_Value) + End If + Exit Function + End If + Loop +End Function + +Private Function json_ParseKey(json_String As String, ByRef json_Index As Long) As String + ' Parse key with single or double quotes + If VBA.Mid$(json_String, json_Index, 1) = """" Or VBA.Mid$(json_String, json_Index, 1) = "'" Then + json_ParseKey = json_ParseString(json_String, json_Index) + ElseIf JsonOptions.AllowUnquotedKeys Then + Dim json_Char As String + Do While json_Index > 0 And json_Index <= Len(json_String) + json_Char = VBA.Mid$(json_String, json_Index, 1) + If (json_Char <> " ") And (json_Char <> ":") Then + json_ParseKey = json_ParseKey & json_Char + json_Index = json_Index + 1 + Else + Exit Do + End If + Loop + Else + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting '""' or '''") + End If + + ' Check for colon and skip if present or throw if not present + json_SkipSpaces json_String, json_Index + If VBA.Mid$(json_String, json_Index, 1) <> ":" Then + Err.Raise 10001, "JSONConverter", json_ParseErrorMessage(json_String, json_Index, "Expecting ':'") + Else + json_Index = json_Index + 1 + End If +End Function + +Private Function json_IsUndefined(ByVal json_Value As Variant) As Boolean + ' Empty / Nothing -> undefined + Select Case VBA.VarType(json_Value) + Case VBA.vbEmpty + json_IsUndefined = True + Case VBA.vbObject + Select Case VBA.TypeName(json_Value) + Case "Empty", "Nothing" + json_IsUndefined = True + End Select + End Select +End Function + +Private Function json_Encode(ByVal json_Text As Variant) As String + ' Reference: http://www.ietf.org/rfc/rfc4627.txt + ' Escape: ", \, /, backspace, form feed, line feed, carriage return, tab + Dim json_Index As Long + Dim json_Char As String + Dim json_AscCode As Long + Dim json_Buffer As String + Dim json_BufferPosition As Long + Dim json_BufferLength As Long + + For json_Index = 1 To VBA.Len(json_Text) + json_Char = VBA.Mid$(json_Text, json_Index, 1) + json_AscCode = VBA.AscW(json_Char) + + ' When AscW returns a negative number, it returns the twos complement form of that number. + ' To convert the twos complement notation into normal binary notation, add 0xFFF to the return result. + ' https://support.microsoft.com/en-us/kb/272138 + If json_AscCode < 0 Then + json_AscCode = json_AscCode + 65536 + End If + + ' From spec, ", \, and control characters must be escaped (solidus is optional) + + Select Case json_AscCode + Case 34 + ' " -> 34 -> \" + json_Char = "\""" + Case 92 + ' \ -> 92 -> \\ + json_Char = "\\" + Case 47 + ' / -> 47 -> \/ (optional) + If JsonOptions.EscapeSolidus Then + json_Char = "\/" + End If + Case 8 + ' backspace -> 8 -> \b + json_Char = "\b" + Case 12 + ' form feed -> 12 -> \f + json_Char = "\f" + Case 10 + ' line feed -> 10 -> \n + json_Char = "\n" + Case 13 + ' carriage return -> 13 -> \r + json_Char = "\r" + Case 9 + ' tab -> 9 -> \t + json_Char = "\t" + Case 0 To 31, 127 To 65535 + ' Non-ascii characters -> convert to 4-digit hex + json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4) + End Select + + json_BufferAppend json_Buffer, json_Char, json_BufferPosition, json_BufferLength + Next json_Index + + json_Encode = json_BufferToString(json_Buffer, json_BufferPosition) +End Function + +Private Function json_Peek(json_String As String, ByVal json_Index As Long, Optional json_NumberOfCharacters As Long = 1) As String + ' "Peek" at the next number of characters without incrementing json_Index (ByVal instead of ByRef) + json_SkipSpaces json_String, json_Index + json_Peek = VBA.Mid$(json_String, json_Index, json_NumberOfCharacters) +End Function + +Private Sub json_SkipSpaces(json_String As String, ByRef json_Index As Long) + ' Increment index to skip over spaces + Do While json_Index > 0 And json_Index <= VBA.Len(json_String) And VBA.Mid$(json_String, json_Index, 1) = " " + json_Index = json_Index + 1 + Loop +End Sub + +Private Function json_StringIsLargeNumber(json_String As Variant) As Boolean + ' Check if the given string is considered a "large number" + ' (See json_ParseNumber) + + Dim json_Length As Long + Dim json_CharIndex As Long + json_Length = VBA.Len(json_String) + + ' Length with be at least 16 characters and assume will be less than 100 characters + If json_Length >= 16 And json_Length <= 100 Then + Dim json_CharCode As String + + json_StringIsLargeNumber = True + + For json_CharIndex = 1 To json_Length + json_CharCode = VBA.Asc(VBA.Mid$(json_String, json_CharIndex, 1)) + Select Case json_CharCode + ' Look for .|0-9|E|e + Case 46, 48 To 57, 69, 101 + ' Continue through characters + Case Else + json_StringIsLargeNumber = False + Exit Function + End Select + Next json_CharIndex + End If +End Function + +Private Function json_ParseErrorMessage(json_String As String, ByRef json_Index As Long, ErrorMessage As String) + ' Provide detailed parse error message, including details of where and what occurred + ' + ' Example: + ' Error parsing JSON: + ' {"abcde":True} + ' ^ + ' Expecting 'STRING', 'NUMBER', null, true, false, '{', or '[' + + Dim json_StartIndex As Long + Dim json_StopIndex As Long + + ' Include 10 characters before and after error (if possible) + json_StartIndex = json_Index - 10 + json_StopIndex = json_Index + 10 + If json_StartIndex <= 0 Then + json_StartIndex = 1 + End If + If json_StopIndex > VBA.Len(json_String) Then + json_StopIndex = VBA.Len(json_String) + End If + + json_ParseErrorMessage = "Error parsing JSON:" & VBA.vbNewLine & _ + VBA.Mid$(json_String, json_StartIndex, json_StopIndex - json_StartIndex + 1) & VBA.vbNewLine & _ + VBA.Space$(json_Index - json_StartIndex) & "^" & VBA.vbNewLine & _ + ErrorMessage +End Function + +Private Sub json_BufferAppend(ByRef json_Buffer As String, _ + ByRef json_Append As Variant, _ + ByRef json_BufferPosition As Long, _ + ByRef json_BufferLength As Long) + ' VBA can be slow to append strings due to allocating a new string for each append + ' Instead of using the traditional append, allocate a large empty string and then copy string at append position + ' + ' Example: + ' Buffer: "abc " + ' Append: "def" + ' Buffer Position: 3 + ' Buffer Length: 5 + ' + ' Buffer position + Append length > Buffer length -> Append chunk of blank space to buffer + ' Buffer: "abc " + ' Buffer Length: 10 + ' + ' Put "def" into buffer at position 3 (0-based) + ' Buffer: "abcdef " + ' + ' Approach based on cStringBuilder from vbAccelerator + ' http://www.vbaccelerator.com/home/VB/Code/Techniques/RunTime_Debug_Tracing/VB6_Tracer_Utility_zip_cStringBuilder_cls.asp + ' + ' and clsStringAppend from Philip Swannell + ' https://github.com/VBA-tools/VBA-JSON/pull/82 + + Dim json_AppendLength As Long + Dim json_LengthPlusPosition As Long + + json_AppendLength = VBA.Len(json_Append) + json_LengthPlusPosition = json_AppendLength + json_BufferPosition + + If json_LengthPlusPosition > json_BufferLength Then + ' Appending would overflow buffer, add chunk + ' (double buffer length or append length, whichever is bigger) + Dim json_AddedLength As Long + json_AddedLength = IIf(json_AppendLength > json_BufferLength, json_AppendLength, json_BufferLength) + + json_Buffer = json_Buffer & VBA.Space$(json_AddedLength) + json_BufferLength = json_BufferLength + json_AddedLength + End If + + ' Note: Namespacing with VBA.Mid$ doesn't work properly here, throwing compile error: + ' Function call on left-hand side of assignment must return Variant or Object + Mid$(json_Buffer, json_BufferPosition + 1, json_AppendLength) = CStr(json_Append) + json_BufferPosition = json_BufferPosition + json_AppendLength +End Sub + +Private Function json_BufferToString(ByRef json_Buffer As String, ByVal json_BufferPosition As Long) As String + If json_BufferPosition > 0 Then + json_BufferToString = VBA.Left$(json_Buffer, json_BufferPosition) + End If +End Function + +'' +' VBA-UTC v1.0.6 +' (c) Tim Hall - https://github.com/VBA-tools/VBA-UtcConverter +' +' UTC/ISO 8601 Converter for VBA +' +' Errors: +' 10011 - UTC parsing error +' 10012 - UTC conversion error +' 10013 - ISO 8601 parsing error +' 10014 - ISO 8601 conversion error +' +' @module UtcConverter +' @author tim.hall.engr@gmail.com +' @license MIT (http://www.opensource.org/licenses/mit-license.php) +'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' + +' (Declarations moved to top) + +' ============================================= ' +' Public Methods +' ============================================= ' + +'' +' Parse UTC date to local date +' +' @method ParseUtc +' @param {Date} UtcDate +' @return {Date} Local date +' @throws 10011 - UTC parsing error +'' +Public Function ParseUtc(utc_UtcDate As Date) As Date + On Error GoTo utc_ErrorHandling + +#If Mac Then + ParseUtc = utc_ConvertDate(utc_UtcDate) +#Else + Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION + Dim utc_LocalDate As utc_SYSTEMTIME + + utc_GetTimeZoneInformation utc_TimeZoneInfo + utc_SystemTimeToTzSpecificLocalTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_UtcDate), utc_LocalDate + + ParseUtc = utc_SystemTimeToDate(utc_LocalDate) +#End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10011, "UtcConverter.ParseUtc", "UTC parsing error: " & Err.Number & " - " & Err.Description +End Function + +'' +' Convert local date to UTC date +' +' @method ConvertToUrc +' @param {Date} utc_LocalDate +' @return {Date} UTC date +' @throws 10012 - UTC conversion error +'' +Public Function ConvertToUtc(utc_LocalDate As Date) As Date + On Error GoTo utc_ErrorHandling + +#If Mac Then + ConvertToUtc = utc_ConvertDate(utc_LocalDate, utc_ConvertToUtc:=True) +#Else + Dim utc_TimeZoneInfo As utc_TIME_ZONE_INFORMATION + Dim utc_UtcDate As utc_SYSTEMTIME + + utc_GetTimeZoneInformation utc_TimeZoneInfo + utc_TzSpecificLocalTimeToSystemTime utc_TimeZoneInfo, utc_DateToSystemTime(utc_LocalDate), utc_UtcDate + + ConvertToUtc = utc_SystemTimeToDate(utc_UtcDate) +#End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10012, "UtcConverter.ConvertToUtc", "UTC conversion error: " & Err.Number & " - " & Err.Description +End Function + +'' +' Parse ISO 8601 date string to local date +' +' @method ParseIso +' @param {Date} utc_IsoString +' @return {Date} Local date +' @throws 10013 - ISO 8601 parsing error +'' +Public Function ParseIso(utc_IsoString As String) As Date + On Error GoTo utc_ErrorHandling + + Dim utc_Parts() As String + Dim utc_DateParts() As String + Dim utc_TimeParts() As String + Dim utc_OffsetIndex As Long + Dim utc_HasOffset As Boolean + Dim utc_NegativeOffset As Boolean + Dim utc_OffsetParts() As String + Dim utc_Offset As Date + + utc_Parts = VBA.Split(utc_IsoString, "T") + utc_DateParts = VBA.Split(utc_Parts(0), "-") + ParseIso = VBA.DateSerial(VBA.CInt(utc_DateParts(0)), VBA.CInt(utc_DateParts(1)), VBA.CInt(utc_DateParts(2))) + + If UBound(utc_Parts) > 0 Then + If VBA.InStr(utc_Parts(1), "Z") Then + utc_TimeParts = VBA.Split(VBA.Replace(utc_Parts(1), "Z", ""), ":") + Else + utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "+") + If utc_OffsetIndex = 0 Then + utc_NegativeOffset = True + utc_OffsetIndex = VBA.InStr(1, utc_Parts(1), "-") + End If + + If utc_OffsetIndex > 0 Then + utc_HasOffset = True + utc_TimeParts = VBA.Split(VBA.Left$(utc_Parts(1), utc_OffsetIndex - 1), ":") + utc_OffsetParts = VBA.Split(VBA.Right$(utc_Parts(1), Len(utc_Parts(1)) - utc_OffsetIndex), ":") + + Select Case UBound(utc_OffsetParts) + Case 0 + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), 0, 0) + Case 1 + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), 0) + Case 2 + ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues + utc_Offset = TimeSerial(VBA.CInt(utc_OffsetParts(0)), VBA.CInt(utc_OffsetParts(1)), Int(VBA.Val(utc_OffsetParts(2)))) + End Select + + If utc_NegativeOffset Then: utc_Offset = -utc_Offset + Else + utc_TimeParts = VBA.Split(utc_Parts(1), ":") + End If + End If + + Select Case UBound(utc_TimeParts) + Case 0 + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), 0, 0) + Case 1 + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), 0) + Case 2 + ' VBA.Val does not use regional settings, use for seconds to avoid decimal/comma issues + ParseIso = ParseIso + VBA.TimeSerial(VBA.CInt(utc_TimeParts(0)), VBA.CInt(utc_TimeParts(1)), Int(VBA.Val(utc_TimeParts(2)))) + End Select + + ParseIso = ParseUtc(ParseIso) + + If utc_HasOffset Then + ParseIso = ParseIso - utc_Offset + End If + End If + + Exit Function + +utc_ErrorHandling: + Err.Raise 10013, "UtcConverter.ParseIso", "ISO 8601 parsing error for " & utc_IsoString & ": " & Err.Number & " - " & Err.Description +End Function + +'' +' Convert local date to ISO 8601 string +' +' @method ConvertToIso +' @param {Date} utc_LocalDate +' @return {Date} ISO 8601 string +' @throws 10014 - ISO 8601 conversion error +'' +Public Function ConvertToIso(utc_LocalDate As Date) As String + On Error GoTo utc_ErrorHandling + + ConvertToIso = VBA.Format$(ConvertToUtc(utc_LocalDate), "yyyy-mm-ddTHH:mm:ss.000Z") + + Exit Function + +utc_ErrorHandling: + Err.Raise 10014, "UtcConverter.ConvertToIso", "ISO 8601 conversion error: " & Err.Number & " - " & Err.Description +End Function + +' ============================================= ' +' Private Functions +' ============================================= ' + +#If Mac Then + +Private Function utc_ConvertDate(utc_Value As Date, Optional utc_ConvertToUtc As Boolean = False) As Date + Dim utc_ShellCommand As String + Dim utc_Result As utc_ShellResult + Dim utc_Parts() As String + Dim utc_DateParts() As String + Dim utc_TimeParts() As String + + If utc_ConvertToUtc Then + utc_ShellCommand = "date -ur `date -jf '%Y-%m-%d %H:%M:%S' " & _ + "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & "' " & _ + " +'%s'` +'%Y-%m-%d %H:%M:%S'" + Else + utc_ShellCommand = "date -jf '%Y-%m-%d %H:%M:%S %z' " & _ + "'" & VBA.Format$(utc_Value, "yyyy-mm-dd HH:mm:ss") & " +0000' " & _ + "+'%Y-%m-%d %H:%M:%S'" + End If + + utc_Result = utc_ExecuteInShell(utc_ShellCommand) + + If utc_Result.utc_Output = "" Then + Err.Raise 10015, "UtcConverter.utc_ConvertDate", "'date' command failed" + Else + utc_Parts = Split(utc_Result.utc_Output, " ") + utc_DateParts = Split(utc_Parts(0), "-") + utc_TimeParts = Split(utc_Parts(1), ":") + + utc_ConvertDate = DateSerial(utc_DateParts(0), utc_DateParts(1), utc_DateParts(2)) + _ + TimeSerial(utc_TimeParts(0), utc_TimeParts(1), utc_TimeParts(2)) + End If +End Function + +Private Function utc_ExecuteInShell(utc_ShellCommand As String) As utc_ShellResult +#If VBA7 Then + Dim utc_File As LongPtr + Dim utc_Read As LongPtr +#Else + Dim utc_File As Long + Dim utc_Read As Long +#End If + + Dim utc_Chunk As String + + On Error GoTo utc_ErrorHandling + utc_File = utc_popen(utc_ShellCommand, "r") + + If utc_File = 0 Then: Exit Function + + Do While utc_feof(utc_File) = 0 + utc_Chunk = VBA.Space$(50) + utc_Read = CLng(utc_fread(utc_Chunk, 1, Len(utc_Chunk) - 1, utc_File)) + If utc_Read > 0 Then + utc_Chunk = VBA.Left$(utc_Chunk, CLng(utc_Read)) + utc_ExecuteInShell.utc_Output = utc_ExecuteInShell.utc_Output & utc_Chunk + End If + Loop + +utc_ErrorHandling: + utc_ExecuteInShell.utc_ExitCode = CLng(utc_pclose(utc_File)) +End Function + +#Else + +Private Function utc_DateToSystemTime(utc_Value As Date) As utc_SYSTEMTIME + utc_DateToSystemTime.utc_wYear = VBA.Year(utc_Value) + utc_DateToSystemTime.utc_wMonth = VBA.Month(utc_Value) + utc_DateToSystemTime.utc_wDay = VBA.Day(utc_Value) + utc_DateToSystemTime.utc_wHour = VBA.Hour(utc_Value) + utc_DateToSystemTime.utc_wMinute = VBA.Minute(utc_Value) + utc_DateToSystemTime.utc_wSecond = VBA.Second(utc_Value) + utc_DateToSystemTime.utc_wMilliseconds = 0 +End Function + +Private Function utc_SystemTimeToDate(utc_Value As utc_SYSTEMTIME) As Date + utc_SystemTimeToDate = DateSerial(utc_Value.utc_wYear, utc_Value.utc_wMonth, utc_Value.utc_wDay) + _ + TimeSerial(utc_Value.utc_wHour, utc_Value.utc_wMinute, utc_Value.utc_wSecond) +End Function + +#End If diff --git a/XVBA/汎用ツール/vba-files/Module/Module1.bas b/XVBA/汎用ツール/vba-files/Module/Module1.bas new file mode 100644 index 00000000..0e0cc670 --- /dev/null +++ b/XVBA/汎用ツール/vba-files/Module/Module1.bas @@ -0,0 +1,61 @@ + +Attribute VB_Name = "Module1" +Option Explicit + + +'Web APIJSONp[^t^ăf[^擾֐ +Public Sub FetchDataFromWebAPI(recordId As String) + 'APIL[ݒ + Dim apiKey As String + apiKey = "6504c8a807677a3a576e10327f3c19876c55736ee45d4a845796b9e7f5e087bfd4bd0d8184863da8cf1733ca635111432ab334aea59102b06a96ee6d2c05190d" + + Dim http As Object + Dim url As String + Dim response As String + Dim jsonBody As String + Dim postData As Object + Dim jsonRes As Object + + 'VBA-JSONDictionary𗘗p + Set postData = CreateObject("Scripting.Dictionary") + postData("ApiVersion") = "1.1" + postData("ApiKey") = apiKey + + 'JsonConverter.ConvertToJsonJSONɕϊ + jsonBody = JsonConverter.ConvertToJson(postData) + + 'url = "https://jsonplaceholder.typicode.com/todos" " POSTp̃Gh|Cg + url = "https://nextoffice.Next-hd.co.jp/pleasanter/api/items/" & recordId & "/Get" + + Debug.Print "URL: " & url + Debug.Print "JSON Body: " & jsonBody + + Set http = CreateObject("MSXML2.XMLHTTP") + http.Open "POST", url, False + http.setRequestHeader "Content-Type", "application/json" + http.send jsonBody + + Debug.Print http.Status & " " & http.statusText + + + If http.Status = 201 Or http.Status = 200 Then + response = http.responseText + 'X|XJSONƂăp[X + Set jsonRes = JsonConverter.ParseJson(response) + Debug.Print "擾f[^: " & jsonRes("Response")("Data")(1)("Title") + + Else + MsgBox "G[: " & http.Status & " - " & http.statusText + + End If + + Set http = Nothing +End Sub + +'FetchDataFromWebAPIĂяo +Public Sub TestFetchData() + Dim recordId As String + recordId = "119261" 'K؂ȃR[hIDɒuĂ + FetchDataFromWebAPI recordId + +End Sub diff --git a/XVBA/汎用ツール/xvba_modules/Xdebug/CHANGELOG.md b/XVBA/汎用ツール/xvba_modules/Xdebug/CHANGELOG.md new file mode 100644 index 00000000..f1f3ad96 --- /dev/null +++ b/XVBA/汎用ツール/xvba_modules/Xdebug/CHANGELOG.md @@ -0,0 +1,13 @@ +# Changelog +## Xdebug (Under Construction) + +- This package provides a way to simulate VBA Immediate Window in Output VSCode window + +## [1.0.0b0] - 2020-09-16 +### Added + - Create XDebug.printx + - Create XDebug.printError + + + + \ No newline at end of file diff --git a/XVBA/汎用ツール/xvba_modules/Xdebug/README.md b/XVBA/汎用ツール/xvba_modules/Xdebug/README.md new file mode 100644 index 00000000..9d8b74f0 --- /dev/null +++ b/XVBA/汎用ツール/xvba_modules/Xdebug/README.md @@ -0,0 +1,58 @@ +# Xdebug (VBA Immediate Window in Output VSCode Window) + +## Description + - This package provides a way to simulate VBA Immediate Window in Output VSCode window + - Find the Output window (VBA Immediate Window) + + ## Methods + +

+VBA immediate Window +

+ + + ### Xdebug.printx + +- This method print any type os variable + + +``` + +Public Sub index() + + + Dim test(1) As Variant + + 'Add an Object + Set test(0) = Sheets(1) + 'Add a String + test(1) = "Test Xdebug Output" + + Xdebug.printx test + +End Sub + +``` + + + ### Xdebug.printError + +- This method is use for print error + + +``` + Public Sub index() + + On Error GoTo ErrorHandle: + 'throw an error + d = 1/0 + 'Your code here + + + ErrorHandle: + Xdebug.errorSource = "pageConsoller.index" + Xdebug.printError + + End Sub +``` + diff --git a/XVBA/汎用ツール/xvba_modules/Xdebug/Xdebug.cls b/XVBA/汎用ツール/xvba_modules/Xdebug/Xdebug.cls new file mode 100644 index 00000000..0856356e --- /dev/null +++ b/XVBA/汎用ツール/xvba_modules/Xdebug/Xdebug.cls @@ -0,0 +1,241 @@ +VERSION 1.0 CLASS +BEGIN +MultiUse = -1 'True +END +Attribute VB_Name = "Xdebug" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False + +'namespace=xvba_modules\Xdebug + +Public env As String + +'Example of Package Create by XVBA-CLI + +Private OS_TMP__FOLDER_PATH As String + +Private IMMEDIATE_FOLDER As String + +Private IMMEDIATE_FILE As String + +Private DEBUG_FILE_PATH As String + +Const EMPTY_TYPE = 0 +Const NULL_TYPE = 1 +Const ERROR_TYPE = 10 +Const INTEGER_TYPE = 2 +Const LONG_TYPE = 3 +Const SINGLE_TYPE = 4 +Const DOUBLE_TYPE = 5 +Const CURRENCY_TYPE = 6 +Const DATE_TYPE = 7 +Const DECIMAL_TYPE = 14 +Const LONG_LONG_TYPE = 20 +Const BOOLEAN_TYPE = 11 +Const STRING_TYPE = 8 +Const ARRAY_TYPE = 8204 +Const OBJECT_TYPE = 9 +Const VARIANT_TYPE = 12 +Const DATA_OBJECT_TYPE = 13 +Private Const MESSAGE_SPACE = " " + +Public errorSource As String +Public errorTitle As String + +'/* +'Flag for Actrive os Deactive VBA Debug.Print +'*/ +Public vbaDebugPrintActive As Boolean + +Private Sub class_initialize() + + Dim fso As Object + Set fso = CreateObject("Scripting.FileSystemObject") + OS_TMP__FOLDER_PATH = fso.GetSpecialFolder(2) + IMMEDIATE_FOLDER = "xvba_immediate" + IMMEDIATE_FILE = "immediate.txt" + vbaDebugPrintActive = True + errorSource = "" + errorTitle = "XVBA: New Error Was Found" + env = "DEV" + + DEBUG_FILE_PATH = OS_TMP__FOLDER_PATH & "\" & IMMEDIATE_FOLDER & "\" & IMMEDIATE_FILE + +End Sub + + + + +Public Function printx(inputValue As Variant,Optional messageType As Integer = 1) + + if(env="DEV") Then + Dim messageText As String + + messageText = createOutputMessage(inputValue) + + Call writeDebugFileContent(messageText,messageType) + End If +End Function + +'/* +'Print A Error +' +'*/ +Public Function printError() + if(env="DEV") Then + + Dim message As String + + message = ErrorHanddler() + + Call writeDebugFileContent(message,0) + + End If +End Function + + +'/* +' +'Write Debug ino on File +' +' +'*/ +Private Function writeDebugFileContent(messageText,messageType) + + Dim filePath As String + Dim FileNum As Integer + Dim PREFIX As String + + filePath = DEBUG_FILE_PATH + + FileNum = FreeFile + + PREFIX = Now & " - " + + Open filePath For Append As #FileNum + + Dim debugMessage As String + Select Case messageType + + Case 0 'Error Message + + debugMessage= PREFIX & "Error:" & messageText + Case 1 'Success + debugMessage= PREFIX & messageText + Case Else 'No Type Set + + debugMessage= PREFIX & "Info:" & messageText + End Select + + Print #FileNum,debugMessage + + Close #FileNum + + If (vbaDebugPrintActive) Then + + Debug.Print debugMessage + + End If +End Function + + +Private Function createOutputMessage(inputValue) As String + + Dim typeOfVar As Integer + Dim response As String + + typeOfVar = VarType(inputValue) + + + 'Set Error Source Macro/Function name + Err.Source="createOutputMessage" + Select Case typeOfVar + Case STRING_TYPE + response = "String: " & inputValue + Case INTEGER_TYPE + response = "Integer: " & CStr(inputValue) + Case LONG_TYPE + response = "Long: " & CStr(inputValue) + Case SINGLE_TYPE + response = "Single: " & CStr(inputValue) + Case DOUBLE_TYPE + response = "Double: " & CStr(inputValue) + Case CURRENCY_TYPE + response = "Currenty: " & CStr(inputValue) + Case DATE_TYPE + response = "Date: " & CStr(inputValue) + Case DECIMAL_TYPE + response = "Decimal: " & CStr(inputValue) + Case LONG_LONG_TYPE + response = "LongLong: " & CStr(inputValue) + Case BOOLEAN_TYPE + response = "Boolean: " & CStr(inputValue) + Case ARRAY_TYPE + response = makeArrayTypeMessage(inputValue) + Case EMPTY_TYPE + response = "Empty: " + Case OBJECT_TYPE + response = "Object: " & TypeName(inputValue) + Case NULL_TYPE + response = "Null: " + Case ERROR_TYPE + response = "Error: " + Case VARIANT_TYPE + response = "Variant: " + Case DATA_OBJECT_TYPE + response = "Data Object: " & TypeName(inputValue) + Case Else + response = "Type Not Supported yet please inform xvba developer " + Debug.Print typeOfVar + Debug.Print inputValue + + End Select + + + createOutputMessage = response + +End Function + + +Private Function makeArrayTypeMessage(inputValue)As String + Dim nextItem As Variant + Dim response As String + Dim message As String + + For Each nextItem In inputValue + message = createOutputMessage(nextItem) + response = response & " [ " & message & " ]" & vbCrLf + Next nextItem + makeArrayTypeMessage = "Array: " & vbCrLf & response +End Function + + + +Private Function ErrorHanddler() As String + Dim errorDescription As String + Dim numberDescription As String + Dim lineError As String + Dim sourceError As String + Dim errorTitleMsg As String + Dim errorSourceMsg As String + + errorTitleMsg = vbCrLf & MESSAGE_SPACE & errorTitle + errorSourceMsg = vbCrLf & MESSAGE_SPACE & "Error Source: " & errorSource + + + Select Case Err.Number + Case 11 + numberDescription = vbCrLf & MESSAGE_SPACE & "Error Number: " & Err.Number + lineError = vbCrLf & MESSAGE_SPACE & "Error Line: " & Erl + errorDescription = vbCrLf & MESSAGE_SPACE & "Error Description: " & Err.Description + Case Else + numberDescription = vbCrLf & MESSAGE_SPACE & "Error Number: " & Err.Number + errorDescription = vbCrLf & MESSAGE_SPACE & "Error Description: " & Err.Description + End Select + + + ErrorHanddler = errorTitleMsg & lineError & errorSourceMsg & numberDescription & errorDescription + +End Function \ No newline at end of file diff --git a/XVBA/汎用ツール/xvba_modules/Xdebug/images/immediate.gif b/XVBA/汎用ツール/xvba_modules/Xdebug/images/immediate.gif new file mode 100644 index 00000000..dd641693 Binary files /dev/null and b/XVBA/汎用ツール/xvba_modules/Xdebug/images/immediate.gif differ diff --git a/XVBA/汎用ツール/xvba_modules/Xdebug/xvba.package.json b/XVBA/汎用ツール/xvba_modules/Xdebug/xvba.package.json new file mode 100644 index 00000000..4a1da537 --- /dev/null +++ b/XVBA/汎用ツール/xvba_modules/Xdebug/xvba.package.json @@ -0,0 +1,15 @@ +{ + "package": "Xdebug", + "version": "1.0.0", + "author": "Alberto Edaurdo", + "email": "alberto.aeraphe@gmail.com", + "license": "ISC", + "repository": { + "type": "git", + "url": "https://github.com/Aeraphe/xdebug.git" + }, + "description": "Creating amazing XVBA packages", + "dependencies": {}, + "dev_dependencies": {}, + "homepage": "www.xvba.dev" +} \ No newline at end of file diff --git a/XVBA/汎用ツール/xvba_modules/excel-types/CHANGELOG.md b/XVBA/汎用ツール/xvba_modules/excel-types/CHANGELOG.md new file mode 100644 index 00000000..39a71ff4 --- /dev/null +++ b/XVBA/汎用ツール/xvba_modules/excel-types/CHANGELOG.md @@ -0,0 +1,8 @@ +# Changelog +## excel@types (Under Construction) + +- This package provides a way to use auto-complete for excel class + + + + \ No newline at end of file diff --git a/XVBA/汎用ツール/xvba_modules/excel-types/README.md b/XVBA/汎用ツール/xvba_modules/excel-types/README.md new file mode 100644 index 00000000..dcf0411e --- /dev/null +++ b/XVBA/汎用ツール/xvba_modules/excel-types/README.md @@ -0,0 +1,51 @@ +# Excel VBA type Definitions Package (excel-types) + + - This package provides a way to use auto-complete for Excel VBA Class + - You can Create your own vba type definition packages our update this. + - Type definition packages are named like: name-types + - The packages are store in www.xvba.dev + - Ech excel vba class has your own file definition + - The files extension has to be filename.d.vb + - Auto-complete just expose Public types + + +## Create,install and share VBA Packages With Xvba-cli and Xvba Repository: + +- Xvba Repository : www.xvba.dev +- XVBA-CLI Command Line Interface for XVBA VSCode extension @localsmart/xvba-cli + +## Install + +- For instal excel-types just use XVBA-CLI install command + +``` + npx xvba install excel-types +``` +## Comments Block + +- Use comments blocks below for documenting class/methods/Subs/Functions/Properties +- The comments blocs has to start with '/* and ends with '*/ + +``` + +'/* +'Represents the entire Microsoft Excel application. +' +' +'*/ +Public Class Application() + +``` + +``` +'/* +'Returns a Range object that represents the active cell in the active window +'(the window on top) or in the specified window. If the window isn't displaying +'a worksheet, this property fails. Read-only. +' +'@type {Object.} +' +'*/ +Public Property ActiveCell As Range + +``` \ No newline at end of file diff --git a/XVBA/汎用ツール/xvba_modules/excel-types/application.d.vb b/XVBA/汎用ツール/xvba_modules/excel-types/application.d.vb new file mode 100644 index 00000000..af74a242 --- /dev/null +++ b/XVBA/汎用ツール/xvba_modules/excel-types/application.d.vb @@ -0,0 +1,147 @@ +'/* +'Represents the entire Microsoft Excel application. +' +' +'*/ +Public Class Application() + +'/* +'Returns an object that represents the active sheet (the sheet on top) +'in the active workbook or in the specified window or workbook. +'Returns Nothing if no sheet is active. +' +'*/ +Public Property ActiveSheet As Worksheet + +'/* +'Returns a Workbook object that represents the workbook in the +'active window (the window on top). +'Returns Nothing if there are no windows open or if either +'the Info window or the Clipboard window is the active window. Read-only. +' +' +'*/ +Public Property ActiveWorkbook As Workbook + +'/* +'True if Microsoft Excel displays certain alerts and messages while +'a macro is running. Read/write Boolean. +' +'Example +'Application.DisplayAlerts = False +'Workbooks("BOOK1.XLS").Close +'Application.DisplayAlerts = True +' +'*/ +Public Property DisplayAlerts As Boolean + + +'/* +'Returns or sets an XlCalculation value that represents the calculation mode. +' +'Example +'Application.Calculation = xlCalculationManual +'Application.Calculation = xlAutomatic +' +'@type {XlCalculation} +'*/ +Public Property Calculation As XlCalculation + +'/* +'True if events are enabled for the specified object. Read/write Boolean. +' +'@type {Boolean} +'*/ +Public Property EnableEvents As Boolean + +'/* +'True if screen updating is turned on. Read/write Boolean. +'@type {Boolean} +'*/ +Public Property ScreenUpdating As Boolean + + +'/* +'Returns a Range object that represents the active cell in the active window +'(the window on top) or in the specified window. If the window isn't displaying +'a worksheet, this property fails. Read-only. +' +'@type {Object.} +' +'*/ +Public Property ActiveCell As Range + +'/* +'Returns a Chart object that represents the active chart (either an embedded chart or a chart sheet). +'An embedded chart is considered active when it's either selected or activated. When no chart is active, +'this property returns Nothing. +' +'Example: +'ActiveChart.HasLegend = True +' +'@type {Object.} +'*/ +Public Property ActiveChart As Chart + +'/* +'Returns a Workbooks collection that represents all the open workbooks. Read-only. +' +'@type {Object.} Workbooks Collection +'*/ +Public Property ThisWorkbook As Workbook + +'/* +'Returns a Workbooks collection that represents all the open workbooks. Read-only. +' +'@type {Object.} Workbooks Collection +'*/ +Public Property Workbooks As Workbooks + +'/* +'Activates a Microsoft application. If the application is already running, +'this method activates the running application. +'If the application isn't running, this method starts a new instance of the application. +' +'Example: (This example starts and activates Word.) +' +'Application.ActivateMicrosoftApp xlMicrosoftWord +' +'@param {XlMSApplication} index +'*/ +Public Sub ActivateMicrosoftApp( index As XlMSApplication) + +End Sub + +'/* +'An event occurs when all pending refresh activity (both synchronous and asynchronous) +'and all of the resultant calculation activities have been completed. +' +'*/ +Public Event AfterCalculate() + +'/* +'Occurs when a new workbook is created. +' +'Example: +' +'Private Sub App_NewWorkbook(ByVal Wb As Workbook) +'Application.Windows.Arrange xlArrangeStyleTiled End Sub +' +'@param {Workbook} Wb +'*/ +Public Event NewWorkbook(ByVal Wb As Workbook) + +'/* +'Returns a Sheets collection that represents all the sheets in the specified workbook. Read-only Sheets object. +' +'Example: +'Set newSheet = Sheets.Add(Type:=xlWorksheet) +'For i = 1 To Sheets.Count +' newSheet.Cells(i, 1).Value = Sheets(i).Name +' Next i +' +'@type {Sheets} +'*/ +Public Property Sheets As Worksheets + +End Class \ No newline at end of file diff --git a/XVBA/汎用ツール/xvba_modules/excel-types/dictionary.d.vb b/XVBA/汎用ツール/xvba_modules/excel-types/dictionary.d.vb new file mode 100644 index 00000000..6a580711 --- /dev/null +++ b/XVBA/汎用ツール/xvba_modules/excel-types/dictionary.d.vb @@ -0,0 +1,109 @@ + + + +'/* +' +' +' +'/* +Public Class Scripting() + + +'/* +' +'Object that stores data key/item pairs. +' +'/* +Public Function Dictionary() + +End Function + +'/* +' +'Adds a new key/item pair to a Dictionary object. +' +'*/ +Public Sub Add() + +End Sub + +'/* +' +'Returns a Boolean value that indicates whether a specified key exists in the Dictionary object. +' +'*/ +Public Sub Exists() + +End Sub + +'/* +' +'Returns an array of all the items in a Dictionary object. +' +'*/ +Public Sub Items() + +End Sub + +'/* +' +'Returns an array of all the keys in a Dictionary object. +' +'*/ +Public Sub Keys() + +End Sub + +'/* +' +'Removes one specified key/item pair from the Dictionary object. +' +'*/ +Public Sub Remove() + +End Sub + +'/* +' +'Removes all the key/item pairs in the Dictionary object. +' +'*/ +Public Sub RemoveAll() + +End Sub + + + +'/* +'Sets or returns the comparison mode for comparing keys in a Dictionary object. +' +' +'*/ +Public Property CompareMode As Variant + + +'/* +'Returns the number of key/item pairs in a Dictionary object. +' +' +'*/ +Public Property Count As Long + + +'/* +'Sets or returns the value of an item in a Dictionary object. +' +' +'*/ +Public Property Item As Variant + +'/* +'Sets a new key value for an existing key value in a Dictionary object. +' +' +'*/ +Public Property Key As Variant + + + +End Class \ No newline at end of file diff --git a/XVBA/汎用ツール/xvba_modules/excel-types/err.d.vb b/XVBA/汎用ツール/xvba_modules/excel-types/err.d.vb new file mode 100644 index 00000000..7115cac1 --- /dev/null +++ b/XVBA/汎用ツール/xvba_modules/excel-types/err.d.vb @@ -0,0 +1,30 @@ +'/* +'Contains information about run-time errors. +' +' +'*/ +Public Class Err() + +'/* +'Returns or sets a string expression containing a +'descriptive string associated with an object. Read/write. +' +'*/ +Public Property Description As String + +'/* +'Returns or sets a numeric value specifying an error. +'Number is the Err object's default property. Read/write. +' +'*/ +Public Property Number As Integer + + +'/* +'Returns or sets a string expression specifying the name of +'the object or application that originally generated the error. Read/write. +' +'*/ +Public Property Source As String + +End Class \ No newline at end of file diff --git a/XVBA/汎用ツール/xvba_modules/excel-types/functions.d.vb b/XVBA/汎用ツール/xvba_modules/excel-types/functions.d.vb new file mode 100644 index 00000000..38aba162 --- /dev/null +++ b/XVBA/汎用ツール/xvba_modules/excel-types/functions.d.vb @@ -0,0 +1,547 @@ + +'/* +'[Conversion Func] +' +'*/ +Function Asc() +End Function + +'/* +'[Conversion Func] +'Returns a String containing the character associated +'with the specified character code. +' +'Example: +' +'Dim MyChar +'MyChar = Chr(65) ' Returns A. +'MyChar = Chr(97) ' Returns a. +'MyChar = Chr(62) ' Returns >. +'MyChar = Chr(37) ' Returns %. +'*/ +Function Chr() +End Function + +'/* +'[Conversion Func] +' +'*/ +Function Format() +End Function + +'/* +'[Conversion Func] +' +'*/ +Function Hex() +End Function + + +'/* +'[Conversion Func] +' +'*/ +Function Oct() +End Function + + +'/* +'[Conversion Func] +'Returns a Variant (String) representation of a number. +' +'Example: +'Dim MyString +'MyString = Str(459) ' Returns " 459". +'MyString = Str(-459.65) ' Returns "-459.65". +'MyString = Str(459.001) ' Returns " 459.001". +' +'*/ +Function Str() As Variant +End Function + + +'/* +'[Conversion Func] +'Returns the numbers contained in a string as +'a numeric value of appropriate type. +' +'Example: +' +'Dim MyValue +'MyValue = Val("2457") ' Returns 2457. +'MyValue = Val(" 2 45 7") ' Returns 2457. +'MyValue = Val("24 and 57") ' Returns 24. +'*/ +Function Val(String) +End Function + + + +Function CreateObject() +End Function + + +Function CurDir() +End Function + +'/* +'Returns a Variant (Date) containing the current system date. +' +'Example +' +'Dim MyDate +'MyDate = Date ' MyDate contains the current system date. +' +'*/ +Function Date() + +End Function + + + +Function DateDiff() +End Function + +Function DatePart() +End Function + +Function DateSerial() +End Function + +Function Day() +End Function + +Function DDB() +End Function + +Function Dir() +End Function + +Function DoEvents() +End Function + +Function Environ() +End Function + +Function EOF() +End Function + +Function Error() +End Function + + +Function FileAttr() +End Function + +Function FileDateTime() +End Function + +Function FileLen() +End Function + +Function Filter() +End Function + +Function FormatCurrency() +End Function + +Function FormatDateTime() +End Function + +Function FormatNumber() +End Function + +Function FormaPercent() +End Function + + +Function FreeFile() +End Function + +Function FV() +End Function + +Function GetAllSettings() +End Function + +Function GetAttr() +End Function + +Function GetObject() +End Function + +Function GetSetting() +End Function + + +Function Hour() +End Function + +Function IIf() +End Function + +Function IMEStatus() +End Function + +Function Input() +End Function + +Function InputBox() +End Function + +Function InStr() +End Function + +Function InStrRev() +End Function + +Function IPmt() +End Function + + + +Function IRR() +End Function + +Function IsArray() +End Function + +Function IsDate() +End Function + +'/* +' +'Returns a Boolean value indicating whether a variable has been initialized. +' +'*/ +Function IsEmpty() +End Function + + +Function IsError() +End Function + +Function IsMissing() +End Function + +Function IsNull() +End Function + +Function IsNumeric() +End Function + + +Function IsObject() +End Function + +'/* +'Returns a string created by joining a number of substrings contained in an array. +' +'*/ +Function Join() +End Function + + + +Function LBound() +End Function + +Function LCase() +End Function + +Function Left() +End Function + +Function Len() +End Function + + +Function Loc() +End Function + +Function LOF() +End Function + +Function LTrim() +End Function + +Function RTrim() +End Function + +Function Trim() +End Function + + +Function MacID() +End Function + + + +Function MacScript() +End Function + +'/* +'[Math Function] +'Returns a value of the same type that is passed to it specifying the absolute value of a number. +' +'*/ +Function Abs() +End Function + +'/* +'[Math Function] +'Returns a Double specifying the arctangent of a number. +' +'*/ +Function Atn() +End Function + + +'/* +'[Math Function] +' +'*/ +Function Cos() +End Function + +'/* +'[Math Function] +' +'*/ +Function Exp() +End Function + +'/* +'[Math Function] +' +'*/ +Function Int() +End Function + +'/* +'[Math Function] +' +'*/ +Function Fix() +End Function + +'/* +'[Math Function] +' +'*/ +Function Log() +End Function + + +'/* +'[Math Function] +' +'*/ +Function Rnd() +End Function + +'/* +'[Math Function] +' +'*/ +Function Sgn() +End Function + +'/* +'[Math Function] +' +'*/ +Function Sin() +End Function + +'/* +'[Math Function] +' +'*/ +Function Sqr() +End Function + +'/* +'[Math Function] +' +'*/ +Function Tan() +End Function + + + +Function Mid() +End Function + + +Function Minute() +End Function + + +Function MIRR() +End Function + + +Function Month() +End Function + +Function MonthName() +End Function + +'/* +'Displays a message in a dialog box, waits for the user to click a button, +'and returns an Integer indicating which button the user clicked. +' +'*/ +Function MsgBox(prompt, [ buttons, ] [ title, ] [ helpfile, context ]) +End Function + + +Function Now() +End Function + + +Function NPer() +End Function + + +Function NPV() +End Function + +Function PPmt() +End Function + + +Function QBColor() +End Function + + +Function Rate() +End Function + +'/* +'Returns a string, which is a substring of a string +'expression beginning at the start position (defaults to 1), +'in which a specified substring has been replaced with another +'substring a specified number of times. +' +'*/ +Function Replace(expression, find, replace, [ start, [ count, [ compare ]]]) +End Function + +Function RGB() +End Function + + +Function Right() +End Function + + +Function Round() +End Function + + +Function Second() +End Function + + + +Function Seek() +End Function + + +Function Shell() +End Function + + +Function SNL() +End Function + + +Function Space() +End Function + + +Function Spc() +End Function + + +Function Split() +End Function + + +Function StrComp() +End Function + + + +Function StrConv() +End Function + + +Function String() +End Function + + +Function StrReverse() +End Function + + + +Function Switch() +End Function + + +Function SYD() +End Function + + +Function Tab() +End Function + + +Function Time() +End Function + + + +Function Timer() +End Function + + +Function TimeSerial() +End Function + + +Function TimeValue() +End Function + + + +Function TypeName() +End Function + + +Function UBound() +End Function + + +Function Ucase() +End Function + + +Function VarType() +End Function + + + +Function Weekday() +End Function + + +Function WeekdayName() +End Function + + +Function Year() +End Function \ No newline at end of file diff --git a/XVBA/汎用ツール/xvba_modules/excel-types/range.d.vb b/XVBA/汎用ツール/xvba_modules/excel-types/range.d.vb new file mode 100644 index 00000000..92a9c7d7 --- /dev/null +++ b/XVBA/汎用ツール/xvba_modules/excel-types/range.d.vb @@ -0,0 +1,625 @@ +'/* +'Represents a cell, a row, a column, a selection of cells containing one or more contiguous blocks of cells, or a 3D range. +' +' +'*/ +Public Class Range() + +'/* +'(Range) +' +'Activates a single cell, which must be inside the current selection. +'To select a range of cells, use the Select method., +' +'Example +' +'This example selects cells A1:C3 on Sheet1 and then makes cell B2 the active cell. +' +' Worksheets("Sheet1").Activate +' Range("A1:C3").Select +' Range("B2").Activate +' +'*/ +Public Sub Activate() + +End Sub + + +'/* +'Adds a comment to the range. +' +'Example: +' +'Worksheets(1).Range("E5").AddComment "Current Sales" +' +'@param {String} text +'*/ +Public Sub AddComment(text As String) + +End Sub + +Public Sub AddCommentThreaded() + +End Sub + +Public Sub AdvancedFilter() + +End Sub + +Public Sub AllocateChanges() + +End Sub + +Public Sub ApplyName() + +End Sub + +Public Sub ApplyOutLineStyles() + +End Sub + +Public Sub AutoComplete() + +End Sub + +Public Sub AutoFill() + +End Sub + +Public Sub AutoFilter() + +End Sub + +Public Sub AutioFit() + +End Sub + +Public Sub AutoOutline() + +End Sub + +Public Sub BorderAround() + +End Sub + +Public Sub Calculate() + +End Sub + +Public Sub CalculateRowMajorOrder() + +End Sub + +Public Sub CheckSpelling() + +End Sub + +Public Sub Clear() + +End Sub + +Public Sub ClearComments() + +End Sub + +Public Sub ClearContents() + +End Sub + +Public Sub ClearFormats() + +End Sub + +Public Sub ClearHyperlinks() + +End Sub + +Public Sub ClearNotes() + +End Sub + +Public Sub ClearOutline() + +End Sub + +Public Sub ColumnDifferences() + +End Sub + +Public Sub Consolidate() + +End Sub + +Public Sub ConvertToLinkedDataType() + +End Sub + +Public Sub Copy() + +End Sub + +Public Sub CopyFromRecordset() + +End Sub + +Public Sub CopyPicture() + +End Sub + +Public Sub CreateNames() + +End Sub + +Public Sub Cut() + +End Sub + +Public Function DataSeries (Rowcol, Type, Date, Step, Stop, Trend) + +End Function + +Public Function DataTypeToText() + +End Function + +Public Function Delete (Shift) + +End Function + +Public Function DialogBox() + +End Function + +Public Function Dirty() + +End Function +Public Function DiscardChanges() + +End Function +Public Function EditionOptions (Type, Option, Name, Reference, Appearance, ChartSize, Format) + +End Function +Public Function ExportAsFixedFormat (Type, FileName, Quality, IncludeDocProperties, IgnorePrintAreas, From, To, OpenAfterPublish, FixedFormatExtClassPtr) + +End Function +Public Function FillDown() + +End Function +Public Function FillLeft() + +End Function + +Public Function FillRight() + +End Function + +Public Function FillUp() + +End Function + +Public Function Find (What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat) + +End Function + +Public Function FindNext (After) + +End Function + +Public Function FindPrevious (Before) + +End Function + +Public Function FlashFill () + +End Function + + +Public Function FunctionWizard () + +End Function + + +Public Function Group (Start, End, By, Periods) + +End Function + +Public Function Insert (Shift, CopyOrigin) + +End Function + + +Public Function InsertIndent (InsertAmount) + +End Function + + +Public Function Justify() + +End Function + + +Public Function ListNames() + +End Function + +Public Function Merge(Across) + +End Function + +Public Function NavigateArrow(TowardPrecedent, ArrowNumber, LinkNumber) + +End Function + +Public Function NoteText(Text, Start, Length) + +End Function + +Public Function Parse(ParseLine, Destination) + +End Function + +Public Function PasteSpecial(Paste, Operation, SkipBlanks, Transpose) + +End Function + + +Public Function PrintOut(From, To, Copies, Preview, ActivePrinter, PrintToFile, Collate, PrToFileName) + +End Function + +Public Function PrintPreview(EnableChanges) + +End Function + +Public Function RemoveDuplicates(Columns , Header) + +End Function + +Public Function RemoveSubtotal() + +End Function + + +Public Function Replace(What, Replacement, LookAt, SearchOrder, MatchCase, MatchByte, SearchFormat, ReplaceFormat) + +End Function + + +Public Function RowDifferences(Comparison) + +End Function + +Public Function Run(Arg1, Arg2, Arg3, Arg4, Arg5...) + +End Function + +Public Function Select() + +End Function + +Public Function SetCellDataTypeFromCell(Range, LanguageCulture) + +End Function + + +Public Function SetPhonetic() + +End Function + + +Public Function Show() + +End Function + + +Public Function ShowCard() + +End Function + + +Public Function ShowDependents(Remove) + +End Function + + +Public Function ShowErrors() + +End Function + + +Public Function ShowPrecedents(Remove) + +End Function + + +Public Function Sort(Key1, Order1, Key2, Type, Order2, Key3, Order3, Header, OrderCustom, MatchCase, Orientation, SortMethod, DataOption1, DataOption2, DataOption3) + +End Function + + +Public Function SortSpecial(SortMethod, Key1, Order1, Type, Key2, Order2, Key3, Order3, Header, OrderCustom, MatchCase, Orientation, DataOption1, DataOption2, DataOption3) + +End Function + +Public Function Speak(SpeakDirection, SpeakFormulas) + +End Function + + +Public Function SpecialCells(Type, Value) + +End Function + +Public Function SubscribeTo(Edition, Format) + +End Function + +Public Function Subtotal(GroupBy, Function, TotalList, Replace, PageBreaks, SummaryBelowData) + +End Function + + +Public Function Table(RowInput, ColumnInput) + +End Function + + +Public Function TextToColumns(Destination, DataType, TextQualifier, ConsecutiveDelimiter, Tab, Semicolon, Comma, Space, Other, OtherChar, FieldInfo, DecimalSeparator, ThousandsSeparator, TrailingMinusNumbers + +End Function + + +Public Function Ungroup() + +End Function + + +Public Function UnMerge() + +End Function + +Public Property AddIndent As Variant + +Public Function Address(RowAbsolute, ColumnAbsolute, ReferenceStyle, External, RelativeTo) As Variant +End Function + +Public Function AddressLocal(RowAbsolute, ColumnAbsolute, ReferenceStyle, External, RelativeTo) As Range +End Function + +Public Property Application As Application + +Public Property Areas As Areas + +Public Property Borders As Variant + +Public Property Cells As Range + +Public Function Characters(Start, Length) As Variant +End Function + +Public Property Column As Long + +Public Property Columns As Long + +Public Property ColumnWidth As Variant + +Public Property Comment As Variant + +Public Property CommentThreaded As Variant + + +Public Property Count As Long + + +Public Property CountLarge As Variant + + +Public Property Creator As Integer + + +Public Property CurrentArray As Range + +'/* +'Returns a Range object that represents the current region. +'The current region is a range bounded by any combination of blank rows and blank columns. Read-only. +' +'Example +'Worksheets("Sheet1").Activate +'ActiveCell.CurrentRegion.Select +'*/ +Public Property CurrentRegion As Range + +Public Property Dependents As Range + +Public Property DirectDependents As Range + +Public Property DirectPrecedents As Range + +Public Property DisplayFormat As Object + + +Public Function End(Direction) As Object +End Function + +Public Property EntireColumn As Range + + +Public Property EntireRow As Range + + +Public Property Errors As Errors + + +Public Property Font As Font + + +Public Property FormatConditions As Range + +Public Property Formula As Variant + +Public Property FormulaArray As Variant + +Public Property FormulaHidden As Variant + + +Public Property FormulaLocal As Object + +Public Property FormulaR1C1 As Varaint + +Public Property FormulaR1C1Local As Varaint + +Public Property HasArray As Varaint + +Public Property HasFormula As Varaint + +Public Property HasRichDataType As Varaint + +Public Property Height As Double + +Public Property Hidden As Variant + +Public Property HorizontalAlignment As Variant + +Public Property Hyperlinks As Object + +Public Property ID As String + +Public Property IndentLevel As Variant + +Public Property Interior As Double + +Public Function Item (RowIndex, ColumnIndex) As Range +End Function + + +Public Property Left As Variant + + +Public Property LinkedDataTypeState As Variant + +Public Property ListHeaderRows As Variant + + +Public Property ListObject As Object + +Public Property LocationInTable As Variant + +Public Property Locked As Variant + +Public Property MDX As String + +Public Property MergeArea As Range + +Public Property MergeCells As Boolean + +Public Property Name As Variant + +Public Property Next As Range + +Public Property NumberFormat As Variant + +Public Property NumberFormatLocal As Variant + +Public Function Offset (RowOffset, ColumnOffset) As Range + +End Function + + +Public Property Orientation As Variant + +Public Property OutlineLevel As Variant + +Public Property PageBreak As Variant + +Public Property Parent As Variant + +Public Property Phonetic As Variant + +Public Property Phonetics As Variant + +Public Property PivotCell As Variant + + +Public Property PivotField As Variant + + +Public Property PivotItem As Variant + +Public Property PivotTable As Variant + +Public Property Precedents As Range + +Public Property PrefixCharacter As Variant + + +Public Property Previous As Range + +Public Property QueryTable As Variant + +Public Function Range (Cell1, Cell2) As Range +End Function + +Public Property ReadingOrder As Variant + +Public Function Resize (RowSize, ColumnSize) As Range +End Function + + +Public Property Row As Long + +Public Property RowHeight As Double + +Public Property Rows As Range + +Public Property ServerActions As Variant + + +Public Property ShowDetail As Variant + + +Public Property ShrinkToFit As Variant + + +Public Property SoundNote As Variant + + +Public Property SparklineGroups As Variant + + +Public Property Style As Variant + +Public Property Summary As Variant + + +Public Property Text As String + +Public Property Top As Variant + +Public Property UseStandardHeight As Variant + +Public Property UseStandardWidth As Variant + +Public Property Validation As Variant + +Public Function Value (RangeValueDataType) As Variant +End Function + +Public Property Value2 As Variant + + +Public Property VerticalAlignment As Variant + +Public Property Width As Double + + + +Public Property Worksheet As Worksheet + + +Public Property WrapText As Variant + +Public Property XPath As XPath + + + +End Class diff --git a/XVBA/汎用ツール/xvba_modules/excel-types/workbook.d.vb b/XVBA/汎用ツール/xvba_modules/excel-types/workbook.d.vb new file mode 100644 index 00000000..55764e2b --- /dev/null +++ b/XVBA/汎用ツール/xvba_modules/excel-types/workbook.d.vb @@ -0,0 +1,157 @@ +'/* +'Represents a Microsoft Excel workbook. +' +' +'*/ +Public Class Workbook() + +'/* +'Returns a String that represents the complete path to the +'workbook/file that this workbook object represents. +' +'*/ +Public Property Path As String + + +Public Property Worksheets As Worksheet + +'/* +'True if a backup file is created when this file is saved. Read-only Boolean. +' +'@type {Boolean} +'*/ +Public Property CreateBackup As Boolean + +'/* +'Returns a String value that represents the name of the object. +' +'@type {Boolean} +'*/ +Public Property Name As String + +'/* +'True if no changes have been made to the specified workbook since it was last saved. Read/write Boolean. +' +'Example: +'If Not ActiveWorkbook.Saved Then +' MsgBox "This workbook contains unsaved changes." +'End If +' +'@type {Boolean} +'*/ +Public Property Saved As String + +'/* +'Returns a Sheets collection that represents all the sheets in the specified workbook. Read-only Sheets object. +' +'Example: +'Set newSheet = Sheets.Add(Type:=xlWorksheet) +'For i = 1 To Sheets.Count +' newSheet.Cells(i, 1).Value = Sheets(i).Name +' Next i +' +'@type {Sheets} +'*/ +Public Property Sheets As Worksheets + + +'/* +' +'Activates the first window associated with the workbook. +' +'*/ +Public Function Activate() + +End Function + +'/* +' +'Closes the object. +' +'Example +' +'Workbooks("BOOK1.XLS").Close SaveChanges:=False +' +'@param {Variant} SaveChanges:[Optional] True or false +'@param {Variant} FileName:[Optional] Saves changes under this file name. +'@param {Variant} RouteWorkbook:[Optional] True or False +'*/ +Public Function Close(SaveChanges,FileName,RouteWorkbook) + +End Function + +'/* +'Saves changes to the specified workbook. +'*/ +Public Function Save() + +End Function + +'/* +'Saves changes to the workbook in a different file. +' +'@param {Variant} FileName:[Optional] +'@param {Variant} FileFormat:[Optional] +'@param {Variant} Password:[Optional] +'@param {Variant} WriteResPassword:[Optional] +'@param {Variant} ReadOnlyRecommended:[Optional] +'@param {Variant} CreateBackup:[Optional] +'@param {Variant} AccessMode:[Optional] +'@param {Variant} ConflictResolution:[Optional] +'@param {Variant} AddToMru:[Optional] +'@param {Variant} TextCodepage:[Optional] +'@param {Variant} TextVisualLayout:[Optional] +'@param {Variant} Local:[Optional] +'*/ +Public Function SaveAs(FileName, FileFormat, Password, WriteResPassword, ReadOnlyRecommended, CreateBackup, AccessMode, ConflictResolution, AddToMru, TextCodepage, TextVisualLayout, Local) + +End Function + + +'/* +'Exports the data that has been mapped to the specified XML schema map to an XML data file. +' +'@param {String} FileName:[Required] +'@param {XmlMap} Map:[Required] +'*/ +Public Function SaveAsXMLData(FileName, Map) + +End Function + + +'/* +'Saves a copy of the workbook to a file but doesn't modify the open workbook in memory. +' +'Example +'ActiveWorkbook.SaveCopyAs "C:\TEMP\XXXX.XLS" +' +'@param {Variant} FileName:[Required] +'*/ +Public Function SaveCopyAs(FileName, Map) + +End Function + +'/* +'Sends the workbook by using the installed mail system. +' +'Example +'ActiveWorkbook.SendMail recipients:="Jean Selva" +' +'@param {Variant} Recipients:[Required] +'@param {Variant} Subject:[Optional] +'@param {Variant} ReturnReceipt:[Optional] +'*/ +Public Function SendMail(Recipients, Subject, ReturnReceipt) + +End Function + +'/* +' +'The ExportAsFixedFormat method is used to publish +'a workbook to either the PDF or XPS format. +' +'*/ +Public Function ExportAsFixedFormat(Type, FileName, Quality, IncludeDocProperties, IgnorePrintAreas, From, To, OpenAfterPublish, FixedFormatExtClassPtr) +End Function + +End Class \ No newline at end of file diff --git a/XVBA/汎用ツール/xvba_modules/excel-types/workbooks.d.vb b/XVBA/汎用ツール/xvba_modules/excel-types/workbooks.d.vb new file mode 100644 index 00000000..07f71c5f --- /dev/null +++ b/XVBA/汎用ツール/xvba_modules/excel-types/workbooks.d.vb @@ -0,0 +1,109 @@ +'/* +'A collection of all the Workbook objects that are currently open in the Microsoft Excel application. +' +'*/ +Public Class Workbooks() + +'/* +'Creates a new workbook. The new workbook becomes the active workbook. +' +'@param {Variant} Template:[Optional] Determines how the new workbook is created. +'If this argument is a string specifying the name of an existing Microsoft Excel file, +'the new workbook is created with the specified file as a template. +'*/ +Public Function Add(Template) + +End Function + + +'/* +'True if Microsoft Excel can check out a specified workbook from a server. +'Read/write Boolean. +' +'@param {String} FileName:[Required] The name of the file to check out. +' +'*/ +Public Function CanCheckOut (FileName) + +End Function + + +Public Function CheckOut (FileName) + +End Function + + +Public Function Close () + +End Function + +'/* +' +'Opens a workbook. +' +'Example +'Workbooks.Open "ANALYSIS.XLS" +'ActiveWorkbook.RunAutoMacros xlAutoOpen +'*/ +Public Function Open (FileName, UpdateLinks, ReadOnly, Format, Password, WriteResPassword, IgnoreReadOnlyRecommended, Origin, Delimiter, Editable, Notify, Converter, AddToMru, Local, CorruptLoad) As Workbook + +End Function + +'/* +'Returns a Workbook object representing a database. +'*/ +Public Function OpenDatabase (FileName, CommandText, CommandType, BackgroundQuery, ImportDataAs) + +End Function + + +'/* +'Loads and parses a text file as a new workbook with a single sheet that contains the parsed text-file data. +'*/ +Public Function (FileName, Origin, StartRow, DataType, TextQualifier, ConsecutiveDelimiter, Tab, Semicolon, Comma, Space, Other, OtherChar, FieldInfo, TextVisualLayout, DecimalSeparator, ThousandsSeparator, TrailingMinusNumbers, Local) + +End Function + +'/* +'Opens an XML data file. Returns a Workbook object. +'*/ +Public Function OpenXML (FileName, Stylesheets, LoadOption) + +End Function + + +'/* +'When used without an object qualifier, this property returns an +'Application object that represents the Microsoft Excel application. +' +'*/ +Public Property Application As Application + + +'/* +'Returns a Long value that represents the number of objects in the collection. +' +'*/ +Public Property Count As Long + +'/* +'Returns a 32-bit integer that indicates the application in which this object was created. Read-only Long. +' +'*/ +Public Property Creator As Integer + + + +'/* +'Returns a single object from a collection. +' +'*/ +Public Property Item(Index) As Object + +'/* +'Returns the parent object for the specified object. Read-only. +' +'*/ +Public Property Parent As Object + +End Class \ No newline at end of file diff --git a/XVBA/汎用ツール/xvba_modules/excel-types/worksheet.d.vb b/XVBA/汎用ツール/xvba_modules/excel-types/worksheet.d.vb new file mode 100644 index 00000000..24a02271 --- /dev/null +++ b/XVBA/汎用ツール/xvba_modules/excel-types/worksheet.d.vb @@ -0,0 +1,86 @@ +'/* +'Represents a worksheet. +' +'Example +' +'Worksheets(1).Visible = False +' +'*/ +Public Class Worksheet() + + +'/* +'Makes the current sheet the active sheet. +' +'Example +'ActiveWorkbook.SendMail recipients:="Jean Selva" +'*/ +Public Sub Activate() + +End Sub + + +Public Sub Calculate() + +End Sub + +Public Sub Copy() + +End Sub + +Public Sub Delete() +End Sub + +Public Sub Move() + +End Sub + +Public Sub Past() + +End Sub + +Public Sub PastSpecial() + +End Sub + +Public Sub Select() +End Sub + +Public Sub SaveAs() + +End Sub + +'/* +' +'Returns a Range object that represents a cell or a range of cells. +' +'Example: +' +'Worksheets("Sheet1").Range("A1").Value = 3.14159 +' +'*/ +Public Property Range As Range + + +'/* +' +'Returns a Range object that represents all the rows on the specified worksheet. +' +'Example: +' +'Worksheets("Sheet1").Rows(3).Delete +' +'*/ +Public Property Row As Range + + +'/* +' +'Returns a Long value that represents the index number of the +'object within the collection of similar objects.orksheets("Sheet1").Rows(3).Delete +' +'*/ +Public Property Index As Long + + +End Class \ No newline at end of file diff --git a/XVBA/汎用ツール/xvba_modules/excel-types/worksheets.d.vb b/XVBA/汎用ツール/xvba_modules/excel-types/worksheets.d.vb new file mode 100644 index 00000000..7d775495 --- /dev/null +++ b/XVBA/汎用ツール/xvba_modules/excel-types/worksheets.d.vb @@ -0,0 +1,54 @@ +'/* +'A collection of all the Worksheet objects in the specified or active workbook. Each Worksheet object represents a worksheet. +' +'Example +' +'Worksheets(1).Visible = False +' +'*/ +Public Class Worksheets() + +'/* +'Constructor +' +'*/ +Public Sub New(Name As String) As Worksheet + +End Sub + +Public Sub Add() + +End Sub + + +Public Sub Add2() + +End Sub + +Public Sub Copy() + +End Sub + +Public Sub Delete() +End Sub + +Public Sub Move() + +End Sub + +Public Sub FillAcrossSheets() + +End Sub + +Public Sub PrintOut() + +End Sub + +Public Sub PrintPreview() +End Sub + +Public Sub Select() + +End Sub + +End Class \ No newline at end of file diff --git a/XVBA/汎用ツール/xvba_modules/excel-types/xvba.package.json b/XVBA/汎用ツール/xvba_modules/excel-types/xvba.package.json new file mode 100644 index 00000000..2fb972d9 --- /dev/null +++ b/XVBA/汎用ツール/xvba_modules/excel-types/xvba.package.json @@ -0,0 +1,15 @@ +{ + "package": "excel-types", + "version": "1.0.0", + "author": "Alberto Oliveira", + "email": "alberto.aeraph@gmail.comn", + "license": "ISC", + "repository": { + "type": "git", + "url": "https://github.com/Aeraphe/excel-types.git" + }, + "description": "Creating amazing XVBA packages", + "dependencies": {}, + "dev_dependencies": {}, + "homepage": "https://github.com/Aeraphe/xvba-cli" +} \ No newline at end of file diff --git a/XVBA/汎用ツール/データ取得汎用ツール.xlsm b/XVBA/汎用ツール/データ取得汎用ツール.xlsm new file mode 100644 index 00000000..714f0dd0 Binary files /dev/null and b/XVBA/汎用ツール/データ取得汎用ツール.xlsm differ