Questo email hack utilizza GPT-4 per rendere il suono più intelligente al lavoro

Come professionisti, trascorriamo innumerevoli ore a redigere e-mail, a volte ripetendoli più volte per prendere il tono giusto. Sfruttando l'API di OpenAI, WordRaider trasforma senza sforzo il tuo testo grezzo in prosa pulita, coinvolgente e professionale - risparmiando tempo prezioso e assicurando chiarezza nelle tue comunicazioni. WordRaider Che cosa è WordRaider? WordRaider è una macro VBA integrata direttamente in Microsoft Outlook. Con un solo clic, tocca i potenti modelli linguistici di OpenAI, riscrivendo istantaneamente qualsiasi testo selezionato all'interno dei vostri disegni di posta elettronica. La macro migliora la chiarezza, la leggibilità e il flusso mantenendo la vostra intenzione del messaggio originale. Perché usare WordRaider? Efficienza: riduce drasticamente il tempo di redazione e modifica delle email. Professionalità: Assicura comunicazioni pulite e articolate ogni volta. Facilità d'uso: Completamente integrato in Outlook, attivato con un solo clic. Come funziona WordRaider? Integrazione perfetta con OpenAI WordRaider chiama l'API di OpenAI (come GPT-4) per migliorare il tuo testo basato su un prompt predefinito progettato per la chiarezza e il tono professionale. Facile selezione e reinserimento Basta evidenziare il testo nel tuo progetto di posta elettronica, fare clic sul pulsante WordRaider personalizzato e guardare la magia accadere istantaneamente. Installazione di WordRaider Passo 1: Impostare la macro Aprire Outlook e premere ALT + F11 per aprire l'editor VBA. Fare clic a destra su "Moduli", selezionare "Inserisci" e selezionare "Modulo". Incollare il codice WordRaider VBA fornito in questo nuovo modulo. Passo 2: Includere JSONConverter WordRaider richiede una versione modificata di JsonConverter (fornita separatamente) per gestire le risposte API: All'interno dell'editor VBA, fare nuovamente clic destro su "Moduli", selezionare "Inserisci" e selezionare "Modulo". Incollare l'intero codice JsonConverter fornito in questo nuovo modulo. Passo 3: modificare la configurazione Personalizza queste aree chiave nel codice VBA: API Key: Const OPENAI_API_KEY As String = "YOUR_API_KEY_HERE" Replace with your actual OpenAI API key. YOUR_API_KEY_HERE Prompt & Model: payload = "{""model"":""gpt-4o"",""messages"":[{""role"":""system"",""content"":""Your custom prompt here.""}, {""role"":""user"",""content"":""" & cleanedText & """}],""max_tokens"":1000,""temperature"":0.6}" Adjust the model (e.g., ) and customize the prompt if needed. gpt-4o Passo 4: Aggiungere WordRaider alla striscia di Outlook Fare clic destro sulla striscia di Outlook e selezionare "Customize the Ribbon". Creare un nuovo gruppo (ad esempio, chiamato "WordRaider") sotto la scheda preferita. Dal dropdown, selezionare "Macro", trovare "RewriteSelectedText" e aggiungerlo al gruppo personalizzato. Rinominare il pulsante macro a "WordRaider" e selezionare un'icona per una facile identificazione. Passo 5: attivare le macro Le macro sono abilitate: File > Opzioni > Trust Center > Impostazioni del Trust Center > Impostazioni macro. Selezionare un livello di sicurezza appropriato in base alle politiche dell'organizzazione. Utilizzo di WordRaider Selezionare il testo all'interno della posta elettronica che si desidera riscrivere. Fai clic sul pulsante "WordRaider" sulla tua striscia. Il tuo testo viene immediatamente sostituito da una versione migliorata, riprodotta professionalmente. Creazione di WordRaider Sentitevi liberi di personalizzare WordRaider per soddisfare le vostre esigenze specifiche: Modifica delle istruzioni di riscrivere nel codice VBA. Selezione dei modelli: sperimentazione con diversi modelli OpenAI per risultati variabili. Impostazione della temperatura: regolare per ripetizioni più creative o conservatrici. Vantaggi dell'utilizzo di WordRaider E-mail chiari e professionali: ogni messaggio inviato riflette chiarezza, professionalità e precisione. Risparmio di tempo significativo: riduce i processi ripetitivi di editing e redazione. Ease of Mind: Assicura una comunicazione coerente e di alta qualità senza sforzo manuale. WordRaider è più di una macro - è il tuo guerriero di editing di posta elettronica personale, trasformando incessantemente le tue comunicazioni alla perfezione. Sfrutta il potere di WordRaider e domina la chiarezza della tua e-mail oggi! Il Modulo: Option Explicit ' set a reference to "Microsoft Scripting Runtime". Const OPENAI_API_KEY As String = "Enter your OPENAI API Key here" Function RewriteText(selectedText As String) As String Dim http As Object Dim url As String Dim payload As String Dim response As String Dim statusCode As Integer Dim cleanedText As String Dim jsonResponse As Object Dim choices As Object Dim choice As Object Dim rewrittenText As String ' Clean the selected text by escaping special characters for JSON cleanedText = JsonEscape(selectedText) ' Set the API URL for chat completions ' Make sure the model name is correct; gpt-4 is valid. url = "https://api.openai.com/v1/chat/completions" ' Create the request body payload = "{""model"":""gpt-4o-mini"",""messages"":[{""role"":""system"",""content"":""Please rewrite the following text to improve clarity, flow, and overall quality while keeping the original meaning intact. Ensure the language is engaging and professional.""}, " & _ "{""role"":""user"",""content"":""" & cleanedText & """}],""max_tokens"":1000,""temperature"":0.6}" ' Create the HTTP request Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0") http.Open "POST", url, False http.setRequestHeader "Content-Type", "application/json" http.setRequestHeader "Authorization", "Bearer " & OPENAI_API_KEY http.Send payload ' Get the response status code statusCode = http.Status ' Get the response response = http.responseText Debug.Print "Response: " & response If statusCode = 200 Then ' Parse JSON response On Error GoTo JsonError Set jsonResponse = JsonConverter.ParseJson(response) On Error GoTo 0 ' The assistant messages are in jsonResponse("choices")(x)("message")("content") Set choices = jsonResponse("choices") If choices.Count > 0 Then Set choice = choices(1) ' Choices are 1-based in some JSON libraries, but VBA-JSON is zero-based. If error, try choices(0). On Error Resume Next Set choice = choices(0) On Error GoTo 0 rewrittenText = choice("message")("content") rewrittenText = JsonUnescape(rewrittenText) RewriteText = rewrittenText Else MsgBox "No choices returned by the API.", vbExclamation RewriteText = "" End If Else ' If the request was not successful, show the error with the response MsgBox "HTTP Error: " & statusCode & ". Response: " & response, vbCritical Debug.Print "Error Response: " & response RewriteText = "" End If Exit Function JsonError: MsgBox "Error parsing JSON: " & Err.Description, vbCritical Debug.Print "Error parsing JSON: " & Err.Description RewriteText = "" End Function ' Function to escape special characters for JSON Function JsonEscape(str As String) As String Dim i As Long Dim c As String Dim res As String Dim code As Integer res = "" For i = 1 To Len(str) c = Mid(str, i, 1) Select Case c Case """" res = res & "\""" Case "\" res = res & "\\" Case "/" res = res & "\/" Case vbBack res = res & "\b" Case vbFormFeed res = res & "\f" Case vbLf res = res & "\n" Case vbCr res = res & "\r" Case vbTab res = res & "\t" Case Else code = AscW(c) If code 126 Then ' Escape non-printable characters as Unicode res = res & "\u" & Right("000" & Hex(code), 4) Else res = res & c End If End Select Next i JsonEscape = res End Function ' Function to unescape JSON strings Function JsonUnescape(str As String) As String ' Replace escaped characters with actual characters str = Replace(str, "\""", """") str = Replace(str, "\\", "\") str = Replace(str, "\/", "/") str = Replace(str, "\b", vbBack) str = Replace(str, "\f", vbFormFeed) str = Replace(str, "\n", vbLf) str = Replace(str, "\r", vbCr) str = Replace(str, "\t", vbTab) ' Handle Unicode escape sequences (e.g., \uXXXX) Dim re As Object Dim matches As Object Dim match As Object Dim unicodeChar As String Set re = CreateObject("VBScript.RegExp") re.Pattern = "\\u([0-9a-fA-F]{4})" re.Global = True Set matches = re.Execute(str) For Each match In matches unicodeChar = ChrW("&H" & match.SubMatches(0)) str = Replace(str, match.Value, unicodeChar) Next match JsonUnescape = str End Function ' Subroutine to rewrite selected text in the email Sub RewriteSelectedText() Dim mailItem As Outlook.mailItem Dim wdDoc As Object Dim wdSelection As Object Dim wdRange As Object Dim selectedText As String Dim rewrittenText As String ' Get the current mail item On Error Resume Next Set mailItem = Application.ActiveInspector.CurrentItem On Error GoTo 0 ' Check if there is an active email If Not mailItem Is Nothing Then ' Get the Word editor object Set wdDoc = mailItem.GetInspector.WordEditor Set wdSelection = wdDoc.Application.Selection ' Get the selected text selectedText = wdSelection.Text ' Check if any text is selected If Len(selectedText) > 0 Then ' Call the function to rewrite the selected text rewrittenText = RewriteText(selectedText) ' Replace the selected text with the rewritten text If Len(rewrittenText) > 0 Then Set wdRange = wdSelection.Range ' Attempt to unprotect the document if it is protected If wdDoc.ProtectionType <> -1 Then ' -1 corresponds to wdNoProtection On Error Resume Next wdDoc.UnProtect On Error GoTo 0 End If ' Try replacing the text in the range On Error Resume Next wdRange.Text = rewrittenText If Err.Number <> 0 Then Err.Clear ' If setting text fails, try deleting and typing wdSelection.Delete wdSelection.TypeText rewrittenText End If On Error GoTo 0 Else MsgBox "Failed to get a rewritten version of the selected text.", vbExclamation End If Else MsgBox "Please select some text to rewrite.", vbExclamation End If Else MsgBox "No email is currently open.", vbExclamation End If End Sub Convertitore di JSON: 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 Object Dim json_Key As String Dim json_NextChar As String ' Use late-binding so no external reference is required Set json_ParseObject = CreateObject("Scripting.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 " ") 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 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 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