ÿÿCHHVBScriptEngineÿþÿ (Allgemein)ÿþÿ(Deklarationen)ÿþÿ'(Deklarationen) ÿþÿÿ&J'Remark: Digital Data - WebService Aufruf zur Umbuchung von Ausprägungen bei Waren (Bsp: Ausprägung "A" zu "B"). 'VB Script Document ' 'Digital Data 'Ludwig-Rinn-Straße 16 '35452 Heuchelheim 'Tel.: 0641 / 202360 'E-Mail: info-flow(at)digitaldata.works ' 'Version Number: 1.1.0.0 'Version Date: 31.08.2020 On Error Resume Next '########## get parameter ######### 'Necessary to get parameters in the code. Do not change! params = MParameters 'First call parameter = Artikelnummer inkl Seriennummer paramProductNumber = params(20) 'Second call parameter = Zielausprägung paramProductTargetShape = params(21) '################################## '########## set constants ######### 'Get current MandantorNr, like "500M". MandatorNr = CWLStart.CurrentCompany.Nr 'Get current meso year, like 1440 ((2020 - 1900) * 12 = 1440). CurrentYear = CWLStart.CurrentCompany.CompanyYear 'Get current username like "meso". CurrentUser = CWLStart.CurrentUser.Account 'Get current WinLine exe path WinLineAppPath = CWLStart.Application.AppPath 'Get current date and time. Timestamp = Now 'Basic SQL where for mandator and curruent mesoyear SQLQuery_BasicWhere = " and (mesocomp = '" & MandatorNr &"') and (mesoyear = " & CurrentYear & ")" 'Präfix für die Laufnummer des erzeugten Belegs RUNNING_NUMBER_PREFIX = "IU-" '################################## '########## set variables ######### 'Debug (Debug Meldungen anzeigen) DEBUG_ON = false DEBUG_MESSAGE = "" DebugMode = "disEnabled" 'Messageboxen DEFAULT_TITLE = "Umbuchungs-Vorgang" DEBUG_TITLE = "DEBUG - " & DEFAULT_TITLE 'Set path for Digital Data Modules. Default: Mandator additional field 10 (IF-ModulPfad-DigitalData) = CWLStart.CurrentCompany.Value(209) ModuleDefaultSourcePath = CWLStart.CurrentCompany.Value(209) 'Set to "Enabled" if Script should ask, before sending WebService Request SummaryQuestion = "Enabled" 'Set creditor (vendor) account number AccountNr = 714021 'Set "Belegart" for the document DocumentType = 701 'Set the Seperator for a full product number (eg the "~" for WARE~B~0000003) ProductShapeSeperator = "~" 'Über das Attribut option= kann gesteuert werden, wie der Beleg In der WinLine behandelt werden soll, wobei es folgende Möglichkeiten gibt: '0 = neuen Beleg erstellen; 1 = Lieferschein zu Auftragsbestätigung; 2 = Rechnung zu Lieferschein; 3 = Beleg editieren; 4 = Beleg stornieren WEB_OPTION = "0" 'Dieses Attribut steuert die Option "Ausprägungen anlegen". Dabei gibt es folgende Möglichkeiten: '0 = Nein; 1 = Ja, wenn nicht vorhanden; 2 = Ja, auch wenn vorhanden inkl Ident und Chargen Ausprägungen. WEB_EXTENTRY = "2" 'Damit kann definiert werden, ob und in welcher Stufe ein importierter Beleg gedruckt werden soll. Gültige Werte sind: '0 = nicht drucken; 1 = Angebot; 2 = Auftrag; 3 = Lieferschein; 4 = Rechnung WEB_PRINT = "3" 'Server & Authentication WEB_SERVER = CWLStart.CurrentCompany.Value(210) WEB_USER = CWLStart.CurrentCompany.Value(211) WEB_PASS = CWLStart.CurrentCompany.Value(212) WEB_COMPANY = MandatorNr 'Import Template Name WEB_VORLAGE = "EXIM-InterneUmbuchung" 'Type of Template '1 = Personenkonten; 2 = Sachkonten; 3 = Interessenten; 4 = Artikel; 5 = Preise; 6 = Arbeitnehmer A; 7 = Kontakte; 8 = Anlagen; 9 = Kostenstellen; 10 = Kostenarten '11 = Kostenträger; 14 = Arbeitnehmer D; 15 = Projekte; 17 = Bankverbindungen; 19 = Lagerort - Zuordnung; 30 = Belege; 31 = Buchungsstapel; 34 = CRM; 38 = Lagerbuchungen '39 = Kommissionierung; 40 = Produktionsauftrag; 41 = Inventur WEB_TYPE = "30" 'Possible Values: '1 = Import; 0 = Check only WEB_ACTIONCODE = "1" '################################## '########## functions and subs ######### 'Function to load VBS modules Public Function LoadVBSModule(VBSModuleParams) 'SYNOPSIS 'Function will load external - additional - VBS Modules into current Script. 'DESCRIPTION 'By working With Modules, this Function Is necessary To load external Modul Functions into the current VB-Script. 'Call parameter must be an array, because VB-Script functions cannot handle optional Parameters. 'In develepment and Test Enviroment it is possible, to work with distributed Folders with different Modules. Therefor the Parameter '"VBSModuleParams(1)" (which is the ModuleOverrideSourcePath) and the preset Variable "ModuleDefaultSourcePath" are made for. 'After a successful Import of a Module, Function will Return True, otherwise a False. 'REQUIREMENT General 'VBS must be enabled 'REQUIREMENT Assembly '<NONE> 'REQUIREMENT Variables 'FSOModule, Module, ModuleCode 'REQUIREMENT Variables preSet '<NONE> 'REQUIREMENT Functions '<NONE> 'VERSION 'Number: 1.3.0.0 / Date: 25.08.2020 'PARAMETER VBSModuleParams(0) = ModuleName 'Give the Module Name, you want to load into the current VB-Script. 'PARAMETER VBSModuleParams(1) = ModuleOverrideSourcePath 'Optional Parameter. By giving the ModuleOverrideSourcePath, Function will not check other Paths for the Function you want to load. 'EXAMPLE 'Dim VBSModuleParams 'Redim VBSModuleParams(0) 'VBSModuleParams(0) = Module 'LoadVBSModule(VBSModuleParams) 'EXAMPLE 'Dim VBSModuleParams 'Redim VBSModuleParams(1) 'VBSModuleParams(0) = Module 'VBSModuleParams(1) = "D:\ScriptFiles\Modules" 'LoadVBSModule(VBSModuleParams) On Error Resume Next 'Clear Error Variable Err.Clear Dim FSOModule, Module, ModuleName, ModuleCode, ModulePath, WshShell, ModuleAutoSourcePath Set FSOModule = CreateObject("Scripting.FileSystemObject") 'How many parameters are given in the array If (UBound(VBSModuleParams) = 0) Then ModuleName = VBSModuleParams(0) If FSOModule.FolderExists(ModuleDefaultSourcePath) Then 'If global var is set, take it! ModulePath = ModuleDefaultSourcePath ELSE 'Getting the current dir, when ModuleDefaultSourcePath does not exist Set WshShell = CreateObject("WScript.Shell") ModuleAutoSourcePath = WshShell.CurrentDirectory 'By this parameter way the path is more variable ModulePath = ModuleAutoSourcePath & "\" & "Modules" If (DEBUG_ON = True) Or (DebugMode = "Enabled") Then MSGBOX "Parameter1 = " & VBSModuleParams(0) & vbCrlf & _ "ModuleDefaultSourcePath = " & ModuleDefaultSourcePath,,"DEBUG Info: Parameter Values in Array - VBSModuleParams" End If End if ElseIf (UBound(VBSModuleParams) = 1) Then ModuleName = VBSModuleParams(0) ModulePath = VBSModuleParams(1) If (DEBUG_ON = True) Or (DebugMode = "Enabled") Then MSGBOX "Parameter1 = " & VBSModuleParams(0) & vbCrlf & _ "Parameter2 = " & VBSModuleParams(1),,"DEBUG Info: Parameter Values in Array - VBSModuleParams" End If Else msgbox "Invalid function call!" & vbCrlf & _ "Please check the parameters!" & vbCrlf & _ "...then restart this Script!",vbExclamation ,"LoadVBSModule: Parameter Error!" End if 'Checking folder paths 'Check if given path is valid, if not create it If Not FSOModule.FolderExists(ModulePath) Then FSOModule.CreateFolder(ModulePath) msgbox "The ModulePath doesnt exist, trying to create!" & vbCrlf & _ "Please place your Modules there: " & vbCrlf & _ ModulePath & vbCrlf & vbCrlf & _ "...then restart this Script!",vbExclamation ,"LoadVBSModule: Modules / ModulePath is missing!" Else 'Clear Error Variable Err.Clear 'Building full module path and name ModuleFullName = ModulePath & "\" & Modulename & ".vbs" 'does the file exist? If Not FSOModule.FileExists(ModuleFullName) Then If Err.Number <> 0 Then MSGBOX "Error Code: "& Err.Number & vbCrlf & _ "Error Description: "& Err.Description,,"ERROR: Module does not exist! " Err.Clear LoadVBSModule = "False" End If Else 'Open file Set Module = FSOModule.OpenTextFile(ModuleFullName, 1) 'Get file content ModuleCode = Module.ReadAll 'Close file handle Module.Close 'Execute the file content ExecuteGlobal ModuleCode If Err.Number <> 0 Then MSGBOX "Error Code: "& Err.Number & vbCrlf & _ "Error Description: "& Err.Description,,"ERROR: Module cannot be loaded!" Err.Clear LoadVBSModule = "False" Else LoadVBSModule = "True" End If End If End If End Function 'LoadVBSModule '########## preparing part ########## 'Reset Error Var Err.Clear 'Display debug infos, if enabled If DebugMode = "Enabled" Then AddDebugLine "CurrentUser: " & CurrentUser AddDebugLine "MandatorNr: " & MandatorNr AddDebugLine "CurrentYear: " & CurrentYear AddDebugLine "Timestamp: " & Timestamp ShowDebugBox "Runtime Variables" End If 'Prepare Array (Arrays are zero based!) Modules = Array("AddDebugLine","ShowDebugBox","GetLeftPad","SendHTTPRequest","SwitchWinLineGoToMacros","GetWinLineInternalProductNumber","GetWinLineStorageLocation","ConvertFromSecureString") Dim Module 'Load external Modules. For Each Module In Modules 'Create the array to pass in to our function Dim VBSModuleParams 'Call the subroutine with two arguments Redim VBSModuleParams(0) 'Change to 1, for 2 values VBSModuleParams(0) = Module 'VBSModuleParams(1) = "" LoadVBSModuleResult = LoadVBSModule(VBSModuleParams) If (LoadVBSModuleResult <> "True") Then 'Set WScript = CreateObject("WScript.Shell") MSGBOX "Module: " & Module & " was Not succesful been loaded!" & vbCrlf & _ "Please load the Module and try again, running this Function/Module!" & vbCrlf & _ "Exiting, because of this Issue." & vbCrlf & _ Err.Description, vbCritical, "DEBUG Info: Cannot load Module!" 'WScript.Quit = not possible in Winline enviroment End If Next 'end for each If (paramProductNumber <> "") And (paramProductTargetShape <> "") Then ProductNumber_Items = Split(paramProductNumber, ProductShapeSeperator) ProductNumber = ProductNumber_Items(0) ProductCurrentShape = ProductNumber_Items(1) ProductSerialNumber = ProductNumber_Items(2) ProductTargetShape = paramProductTargetShape InternalProductNumber = GetWinLineInternalProductNumber(ProductNumber, ProductSerialNumber) ProductStorageLocation = GetWinLineStorageLocation(ProductNumber, ProductSerialNumber, IsSerialNumberArticle) 'If no StorageLocation can be found set it to zero, so WebServie call wont fail If (ProductStorageLocation = "") Or (ProductStorageLocation = " ") Then ProductStorageLocation = 0 End If If DEBUG_ON = True Then AddDebugLine "Splitting input ProductNr: " & paramProductNumber & vbNewline & vbNewline AddDebugLine "ProductNumber: " & ProductNumber & vbNewline AddDebugLine "ProductCurrentShape: " & ProductCurrentShape & vbNewline AddDebugLine "ProductTargetShape: " & ProductTargetShape & vbNewline AddDebugLine "ProductSerialNumber: " & ProductSerialNumber & vbNewline & vbNewline AddDebugLine "InternalProductNumber: " & InternalProductNumber & vbNewline AddDebugLine "ProductStorageLocation: " & ProductStorageLocation ShowDebugBox "Splitting values by: " & ProductShapeSeperator End If Else Msgbox "Achtung: Die Artikelnummer sowie Zielausprägung müssen angegeben werden.", vbExclamation, DEFAULT_TITLE & " - Fehlende Werte festgestellt" End If 'Decrypt password for WebService User WEB_PASS = ConvertFromSecureString(WEB_PASS) '########## main part ########## If (ProductNumber <> "") And ((ProductTargetShape <> "") And (ProductTargetShape <> ProductCurrentShape)) And (ProductSerialNumber <> "") And (InternalProductNumber <> "") And (ProductStorageLocation <> "") Then If (SummaryQuestion = "Enabled") Then 'Return Value 6 = Yes; 7 = No SummaryQuestionResult = MSGBOX("Soll die Artikel-Umbuchung durchgeführt werden?" & vbCrlf & vbCrlf & _ "Wenn ja, wird der ursp. Artikel deaktiviert (nicht gelöscht): " & vbCrlf & _ paramProductNumber & vbCrlf & vbCrlf & _ "Und der folgende Artikel wird angelegt und gebucht: " & vbCrlf & _ ProductNumber & ProductShapeSeperator & ProductTargetShape & ProductShapeSeperator & ProductSerialNumber & vbCrlf & vbCrlf & _ "Der Vorgang kann nicht Rückgängig gemacht werden.", vbYesno + vbQuestion, DEFAULT_TITLE & " - Frage") End If If ((SummaryQuestion = "Enabled") And (SummaryQuestionResult = 6)) Or ((SummaryQuestion <> "Enabled")) Then ' ============================ XML ============================ Dim Request, URL, XML Dim DObj : DObj = Now Dim DateString : DateString = Year(DObj) & "-" & GetLeftPad(Month(DObj)) & "-" & GetLeftPad(Day(DObj)) 'Set unique "Belegkey" during the import procedure (max. 10 numerics) SequenceKey = (Month(Timestamp)) & (Day(Timestamp)) & (Hour(Timestamp)) & (Minute(Timestamp)) & (Second(Timestamp)) 'Set unique "Laufnummer" for this document RunningNumber = RUNNING_NUMBER_PREFIX & Year(DObj) & (Month(DObj)) & (Day(DObj)) & (Hour(DObj)) & (Minute(DObj)) & (Second(DObj)) XML = "" XML = XML & "<?xml version=""1.0"" encoding=""UTF-8""?>" XML = XML & "<MESOWebService TemplateType=""__TYPE__"" Template=""__VORLAGE__"" option=""__OPTION__"" extEntry=""__EXTENTRY__"" printVoucher=""__PRINT__"">" 'XML Kopf XML = XML & "<__VORLAGE__T025>" XML = XML & "<BELEGKEY>" & SequenceKey & "</BELEGKEY>" XML = XML & "<Kontonummer>" & AccountNr & "</Kontonummer>" XML = XML & "<Laufnummer>" & RunningNumber & "</Laufnummer>" XML = XML & "<Datum_Lieferschein>" & DateString & "</Datum_Lieferschein>" XML = XML & "<Belegart>" & DocumentType & "</Belegart>" XML = XML & "</__VORLAGE__T025>" 'XML Mitte für Abbuchung XML = XML & "<__VORLAGE__T026>" XML = XML & "<BELEGKEY>" & SequenceKey & "</BELEGKEY>" XML = XML & "<Artikelnummer>" & InternalProductNumber & "</Artikelnummer>" XML = XML & "<Hauptartikelnummer>" & ProductNumber & "</Hauptartikelnummer>" XML = XML & "<Datentyp>" & 1 & "</Datentyp>" XML = XML & "<Mengegeliefert>" & -1 & "</Mengegeliefert>" XML = XML & "<Auspr.2>" & ProductCurrentShape & "</Auspr.2>" XML = XML & "<ChargeIdentnummer>" & ProductSerialNumber & "</ChargeIdentnummer>" XML = XML & "<Lagerort>" & ProductStorageLocation & "</Lagerort>" XML = XML & "</__VORLAGE__T026>" 'XML Mitte für Zubuchung XML = XML & "<__VORLAGE__T026>" XML = XML & "<BELEGKEY>" & SequenceKey & "</BELEGKEY>" XML = XML & "<Artikelnummer>" & ProductNumber & "</Artikelnummer>" XML = XML & "<Hauptartikelnummer>" & ProductNumber & "</Hauptartikelnummer>" XML = XML & "<Datentyp>" & 1 & "</Datentyp>" XML = XML & "<Mengegeliefert>" & 1 & "</Mengegeliefert>" XML = XML & "<Auspr.2>" & ProductTargetShape & "</Auspr.2>" XML = XML & "<ChargeIdentnummer>" & ProductSerialNumber & "</ChargeIdentnummer>" XML = XML & "<Lagerort>" & ProductStorageLocation & "</Lagerort>" XML = XML & "</__VORLAGE__T026>" XML = XML & "</MESOWebService>" XML = Replace(XML, "__VORLAGE__", WEB_VORLAGE) XML = Replace(XML, "__TYPE__", WEB_TYPE) XML = Replace(XML, "__OPTION__", WEB_OPTION) XML = Replace(XML, "__EXTENTRY__", WEB_EXTENTRY) XML = Replace(XML, "__PRINT__", WEB_PRINT) URL = "http://__SERVER__/ewlservice/import?User=__USER__&Password=__PASSWORD__&Company=__COMPANY__&Type=30&Vorlage=__VORLAGE__&Actioncode=__ACTIONCODE__&byref=0&Data=__DATA__" URL = Replace(URL, "__SERVER__", WEB_SERVER) URL = Replace(URL, "__USER__", WEB_USER) URL = Replace(URL, "__PASSWORD__", WEB_PASS) URL = Replace(URL, "__COMPANY__", WEB_COMPANY) URL = Replace(URL, "__VORLAGE__", WEB_VORLAGE) URL = Replace(URL, "__ACTIONCODE__", WEB_ACTIONCODE) URL = Replace(URL, "__DATA__", XML) If DEBUG_ON = True Then AddDebugLine "Sending Request to WebServices.." AddDebugLine "URL: " & URL ShowDebugBox "WebServices" End If ' ======================= ENDE XML ======================= ' ===================== HTTP REQUEST ===================== HTTPRequest = SendHTTPRequest(URL) ' =================== ENDE HTTP REQUEST ================== Error = False Message = "" If HTTPRequest(1) = 200 Then If InStr(HTTPRequest(0), "<OverallSuccess>true</OverallSuccess>") > 0 Then Message = "Der Umbuchungs-Lieferschein wurde erzeugt!" & vbCrlf & _ "Laufnummer: " & RunningNumber & vbCrlf & vbCrlf & _ "Der ursp. Artikel wurde deaktiviert: " & vbCrlf & _ paramProductNumber & vbCrlf & vbCrlf & _ "Der folgende Artikel wurde angelegt: " & vbCrlf & _ ProductNumber & ProductShapeSeperator & ProductTargetShape & ProductShapeSeperator & ProductSerialNumber Else Error = True Message = "Der Umbuchungs-Lieferschein wurde nicht erzeugt! Fehlerdetails: " & vbNewline & vbNewline & HTTPRequest(0) End If Else Error = True Message = "Fehler beim Zugriff auf Webservices aufgetreten" & vbNewline & "Status: " & HTTPRequest(1) End If If Error = False Then MsgBox Message, vbInformation, DEFAULT_TITLE & " - Abschluss erfolgreich" Else MsgBox Message, vbExclamation, DEFAULT_TITLE & " - Fehler bei Abschluss" End If Else msgbox "Die Verarbeitung wurde abgebrochen!", vbExclamation, DEFAULT_TITLE & " - Vorgang abgebrochen!" End If 'end SummaryQuestion 'If TargetShape is the same as the CurrentShape of the Product, Script should do nothing! Elseif (ProductTargetShape = ProductCurrentShape) Then If (DEBUG_ON = True) Or (DebugMode = "Enabled") Then MSGBOX "Cannot go on, ProductTargetShape = ProductCurrentShape",,"DEBUG Info: Shape Check" End If 'If GetWinLineStorageLocation function returns nothing Elseif (ProductStorageLocation = "") Then msgbox "Es scheint kein Lagerbestand vorhanden zu sein!", vbOkonly+vbCritical, DEFAULT_TITLE & " - Vorgang abgebrochen!" 'Falls nicht alle Pflichtparameter übergeben wurden Else MSGBOX "Es wurden nicht alle Werte gefunden oder übergeben: " & vbCrlf & vbCrlf & _ "ProductNumber: " & ProductNumber & vbCrlf & _ "ProductTargetShape: " & ProductTargetShape & vbCrlf & vbCrlf & _ "Über den Debug Modus die einzelen Werte prüfen!", vbOkonly+vbCritical, "Fehler beim Aufruf!" End If '################################## '########### final part ########### 'if DebugMode enabled or DebugOn is true, go to the Macro Window SwitchWinLineGoToMacros '################################## ÿþÿ'Ende von (Deklarationen)