So i am totally new to VBS, never used it. I am trying to create multiple shares and i found a Microsoft VBS script that can do this(http://gallery.technet.microsoft.com/scriptcenter/6309d93b-fcc3-4586-b102-a71415244712) My question is, this script only allows for one domain group or user to be added for permissions where i am needing to add a couple with different permissions(got that figured out) Below is the script that i have modified for my needs but just need to add in the second group with the other permissions. If there is an easier way to do this please let me know.
'ShareSetup.vbs
'==========================================================================
Option Explicit
Const FILE_SHARE = 0
Const MAXIMUM_CONNECTIONS = 25
Dim strComputer
Dim objWMIService
Dim objNewShare
strComputer = "."
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set objNewShare = objWMIService.Get("Win32_Share")
Call sharesec ("C:\Published Apps\Logs01", "Logs01", "Log01", "Support")
Call sharesec2 ("C:\Published Apps\Logs01", "Logs01", "Log01", "Domain Admins")
Sub sharesec(Fname,shr,info,account)
'Fname = Folder path, shr = Share name, info = Share Description, account = account or group you are assigning share permissions to
Dim FSO
Dim Services
Dim SecDescClass
Dim SecDesc
Dim Trustee
Dim ACE
Dim Share
Dim InParam
Dim Network
Dim FolderName
Dim AdminServer
Dim ShareName
FolderName = Fname
AdminServer = "\\" & strComputer
ShareName = shr
Set Services = GetObject("WINMGMTS:{impersonationLevel=impersonate,(Security)}!" & AdminServer & "\ROOT\CIMV2")
Set SecDescClass = Services.Get("Win32_SecurityDescriptor")
Set SecDesc = SecDescClass.SpawnInstance_()
'Set Trustee = Services.Get("Win32_Trustee").SpawnInstance_
'Trustee.Domain = Null
'Trustee.Name = "EVERYONE"
'Trustee.Properties_.Item("SID") = Array(1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0)
Set Trustee = SetGroupTrustee("domain", account) 'Replace ACME with your domain name.
'To assign permissions to individual accounts use SetAccountTrustee rather than SetGroupTrustee
Set ACE = Services.Get("Win32_Ace").SpawnInstance_
ACE.Properties_.Item("AccessMask") = 1179817
ACE.Properties_.Item("AceFlags") = 3
ACE.Properties_.Item("AceType") = 0
ACE.Properties_.Item("Trustee") = Trustee
SecDesc.Properties_.Item("DACL") = Array(ACE)
Set Share = Services.Get("Win32_Share")
Set InParam = Share.Methods_("Create").InParameters.SpawnInstance_()
InParam.Properties_.Item("Access") = SecDesc
InParam.Properties_.Item("Description") = "Public Share"
InParam.Properties_.Item("Name") = ShareName
InParam.Properties_.Item("Path") = FolderName
InParam.Properties_.Item("Type") = 0
Share.ExecMethod_ "Create", InParam
End Sub
Sub sharesec2(Fname,shr,info,account)
'Fname = Folder path, shr = Share name, info = Share Description, account = account or group you are assigning share permissions to
Dim FSO
Dim Services
Dim SecDescClass
Dim SecDesc
Dim Trustee
Dim ACE2
Dim Share
Dim InParam
Dim Network
Dim FolderName
Dim AdminServer
Dim ShareName
FolderName = Fname
AdminServer = "\\" & strComputer
ShareName = shr
Set Services = GetObject("WINMGMTS:{impersonationLevel=impersonate,(Security)}!" & AdminServer & "\ROOT\CIMV2")
Set SecDescClass = Services.Get("Win32_SecurityDescriptor")
Set SecDesc = SecDescClass.SpawnInstance_()
'Set Trustee = Services.Get("Win32_Trustee").SpawnInstance_
'Trustee.Domain = Null
'Trustee.Name = "EVERYONE"
'Trustee.Properties_.Item("SID") = Array(1, 1, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0)
Set Trustee = SetGroupTrustee("domain", account) 'Replace ACME with your domain name.
'To assign permissions to individual accounts use SetAccountTrustee rather than SetGroupTrustee
Set ACE2 = Services.Get("Win32_Ace").SpawnInstance_
ACE2.Properties_.Item("AccessMask") = 1179817
ACE2.Properties_.Item("AceFlags") = 3
ACE2.Properties_.Item("AceType") = 0
ACE2.Properties_.Item("Trustee") = Trustee
SecDesc.Properties_.Item("DACL") = Array(ACE2)
End Sub
Function SetAccountTrustee(strDomain, strName)
set objTrustee = getObject("Winmgmts: {impersonationlevel=impersonate}!root/cimv2:Win32_Trustee").Spawninstance_
set account = getObject("Winmgmts: {impersonationlevel=impersonate}!root/cimv2:Win32_Account.Name='" & strName & "',Domain='" & strDomain &"'")
set accountSID = getObject("Winmgmts: {impersonationlevel=impersonate}!root/cimv2:Win32_SID.SID='" & account.SID &"'")
objTrustee.Domain = strDomain
objTrustee.Name = strName
objTrustee.Properties_.item("SID") = accountSID.BinaryRepresentation
set accountSID = nothing
set account = nothing
set SetAccountTrustee = objTrustee
End Function
Function SetGroupTrustee(strDomain, strName)
Dim objTrustee
Dim account
Dim accountSID
set objTrustee = getObject("Winmgmts: {impersonationlevel=impersonate}!root/cimv2:Win32_Trustee").Spawninstance_
set account = getObject("Winmgmts:{impersonationlevel=impersonate}!root/cimv2:Win32_Group.Name='" & strName & "',Domain='" & strDomain &"'")
set accountSID = getObject("Winmgmts: {impersonationlevel=impersonate}!root/cimv2:Win32_SID.SID='" & account.SID &"'")
objTrustee.Domain = strDomain
objTrustee.Name = strName
objTrustee.Properties_.item("SID") = accountSID.BinaryRepresentation
set accountSID = nothing
set account = nothing
set SetGroupTrustee = objTrustee
End Function
I think you will find it easier to script the permissions at NTFS level using icacls rather than at share level using VBS and simply assign all users full access in your VBScript.
You may also wish to look into using powershell to create the shares, there is some guidance on this here: http://blogs.technet.com/b/heyscriptingguy/archive/2010/09/16/how-to-use-powershell-to-create-shared-folders-in-windows-7.aspx
In the future we will be able to do this in powershell with cmdlet new-smbshare :-) http://technet.microsoft.com/en-us/library/jj635726.aspx
Call sharesec ("C:\Published Apps\Logs01", "Logs01", "Log01", "Support")
Call sharesec2 ("C:\Published Apps\Logs01", "Logs01", "Log01", "Domain Admins")
I am assuming for some reasons you create the extra function sharesec2 for some odd reason, but that is the wrong thing to do. You are basically trying to create the share twice. Which doesn't make sense. Duplicating that function has no valid purpose.
What you would really have to do is re-work that function. For example you might change the fourth parameter of the sharesec so that it accepts an array. Then You need to loop over the array and build up your discretionary access control list (DACL) for the share. With one access control entry (ACE) per user/group.
I am not going to write the code for you since I abhor VBS, but this is the section would want to loop over this section and build up the DACL.
' loop over the list of users
` create ACE for single user/group
Set Trustee = SetGroupTrustee("domain", account) 'Replace ACME with your domain name.
'To assign permissions to individual accounts use SetAccountTrustee rather than SetGroupTrustee
Set ACE2 = Services.Get("Win32_Ace").SpawnInstance_
ACE2.Properties_.Item("AccessMask") = 1179817
ACE2.Properties_.Item("AceFlags") = 3
ACE2.Properties_.Item("AceType") = 0
ACE2.Properties_.Item("Trustee") = Trustee
` add ace to an array that represents the dacl
` end loop
` add the DACL_array
SecDesc.Properties_.Item("DACL") = DACL_array
In any case, I strongly suggest you look at Powershell instead.
Related
I have a script to iterate through my calendar events that day and produce in a separate email a list in the following format:
Event 1:
Subject:
When:
Attendees:
The function, which lists all attendees:
Function listAttendees(ByRef item As Variant, myself As String, ByRef nicknames As Scripting.Dictionary) As String
listAttendees = ""
'Dim pa As Outlook.PropertyAccessor
Dim sAtt As String
For i = 1 To item.Recipients.Count
sAtt = item.Recipients.item(i).AddressEntry.GetExchangeUser().FirstName & " " & item.Recipients.item(i).AddressEntry.GetExchangeUser().LastName
sAtt = cleanName(sAtt)
If nicknames.Exists(sAtt) Then
sAtt = nicknames(sAtt)
End If
If sAtt <> myself Then
If listAttendees <> "" Then
listAttendees = listAttendees & ", "
End If
listAttendees = listAttendees & "[[" & sAtt & "]]"
End If
Next
End Function
I get
Runtime error 91 - object variable or with block variable not set
The error points to:
sAtt = item.Recipients.item(i).AddressEntry.GetExchangeUser().FirstName & " " & item.Recipients.item(i).AddressEntry.GetExchangeUser().LastName
This script was working a few days ago.
The GetExchangeUser method should be called only if the AddressEntry.AddressEntryUserType property is set to the olExchangeUserAddressEntry value. Here is what MSDN states for the property:
AddressEntryUserType provides a level of granularity for user types that is finer than that of AddressEntry.DisplayType. The DisplayType property does not distinguish users with different types of AddressEntry, such as an AddressEntry that has a Simple Mail Transfer Protocol (SMTP) email address, a Lightweight Directory Access Protocol (LDAP) address, an Exchange user address, or an AddressEntry in the Outlook Contacts Address Book. All these entires have olUser as their AddressEntry.DisplayType.
For illustration purposes take a look how it can be used in the code:
Sub DemoAE()
Dim colAL As Outlook.AddressLists
Dim oAL As Outlook.AddressList
Dim colAE As Outlook.AddressEntries
Dim oAE As Outlook.AddressEntry
Dim oExUser As Outlook.ExchangeUser
Set colAL = Application.Session.AddressLists
For Each oAL In colAL
'Address list is an Exchange Global Address List
If oAL.AddressListType = olExchangeGlobalAddressList Then
Set colAE = oAL.AddressEntries
For Each oAE In colAE
If oAE.AddressEntryUserType = olExchangeUserAddressEntry Then
Set oExUser = oAE.GetExchangeUser
Debug.Print(oExUser.JobTitle)
Debug.Print(oExUser.OfficeLocation)
Debug.Print(oExUser.BusinessTelephoneNumber)
End If
Next
End If
Next
End Sub
I have two calendars, one is mine and the other is shared. Both are opened in outlook as below.
How can i get selected apointment calendar's email adress?
I saw AppointmentItem has GetOrganizer to find who created the appointment but I don't find any method or property about the user of the calendar in witch the appointment is...
So I tried Application.ActiveExplorer.CurrentFolder to get the selected folder and then get the AdressEntry but I can't get the folder's store because it's a shared calendar (and then folder.store returns null).
Following Dmitry's advices there, I did :
Dim appointment_item As Outlook.AppointmentItem
Dim PR_MAILBOX_OWNER_ENTRYID as String
Dim mapiFolder As Outlook.MAPIFolder
Dim folderStore As Outlook.Store
Dim mailOwnerEntryId As String
Dim entryAddress As Outlook.AddressEntry
Dim smtpAdress As String
PR_MAILBOX_OWNER_ENTRYID = "http://schemas.microsoft.com/mapi/proptag/0x661B0102"
appointment_item = Application.ActiveExplorer.Selection.Item(1)
mapiFolder = appointment_item.Parent
folderStore = mapiFolder.Store
mailOwnerEntryId = folderStore.PropertyAccessor.GetProperty(PR_MAILBOX_OWNER_ENTRYID)
entryAddress = Application.Session.GetAddressEntryFromID(mailOwnerEntryId)
smtpAdress = entryAddress.GetExchangeUser.PrimarySmtpAddress
MsgBox(smtpAdress)
The issue is i can't get .Store of a shared folder as written here in the MS Documentation.
This property returns a Store object except in the case where the Folder is a shared folder (returned by NameSpace.GetSharedDefaultFolder). In this case, one user has delegated access to a default folder to another user; a call to Folder.Store will return Null.
I finally found a way to do it, this topic helped me.
The code below, parses the shared folder storeID to get the shared folder SMTP address.
Public Sub test()
Dim smtpAddress As String
Dim selectedItem As Outlook.Folder
smtpAddress = ""
TryGetSmtpAddress(Application.ActiveExplorer.Selection.Item(1).Parent, smtpAddress)
End Sub
Public Shared Function TryGetSmtpAddress(ByVal folder As MAPIFolder, ByRef smtpAddress As String) As Boolean
smtpAddress = "default"
Dim storeId = HexToBytes(folder.StoreID)
If BitConverter.ToUInt64(storeId, 4) <> &H1A10E50510BBA138UL OrElse BitConverter.ToUInt64(storeId, 12) <> &HC2562A2B0008BBA1UL Then
Return False
End If
Dim indexDn = Array.IndexOf(storeId, CByte(&H0), 60) + 1
Dim indexV3Block = Array.IndexOf(storeId, CByte(&H0), indexDn) + 1
If BitConverter.ToUInt32(storeId, indexV3Block) <> &HF43246E9UL Then
Return False
End If
Dim offsetSmtpAddress = BitConverter.ToUInt32(storeId, indexV3Block + 12)
smtpAddress = BytesToUnicode(storeId, indexV3Block + CInt(offsetSmtpAddress))
Return True
End Function
Private Shared Function HexToBytes(ByVal input As String) As Byte()
Dim bytesLength = input.Length / 2
Dim bytes = New Byte(bytesLength - 1) {}
For i = 0 To bytesLength - 1
bytes(i) = Convert.ToByte(input.Substring(i * 2, 2), 16)
Next
Return bytes
End Function
Private Shared Function BytesToUnicode(ByVal value As Byte(), ByVal startIndex As Integer) As String
Dim charsLength = (value.Length - startIndex) / 2
Dim chars = New Char(charsLength - 1) {}
For i = 0 To charsLength - 1
Dim c = CSharpImpl.__Assign(chars(i), BitConverter.ToChar(value, startIndex + i * 2))
If c = vbNullChar Then
Return New String(chars, 0, i)
End If
Next
Return New String(chars)
End Function
Private Class CSharpImpl
<Obsolete("Please refactor calling code to use normal Visual Basic assignment")>
Shared Function __Assign(Of T)(ByRef target As T, value As T) As T
target = value
Return value
End Function
End Class
It may be possible to get to the top of the folder tree of a shared calendar the long way, without built-in shortcuts.
Tested on my own calendar, not a shared calendar.
Option Explicit
Sub appointment_sourceFolder()
' VBA code
Dim obj_item As Object
Dim appointment_item As AppointmentItem
Dim parentOfAppointment As Variant
Dim parentParentFolder As Folder
Dim sourceFolder As Folder
Set obj_item = ActiveExplorer.Selection.Item(1)
If obj_item.Class <> olAppointment Then Exit Sub
Set appointment_item = obj_item
' Recurring appointment leads to
' the parent of the recurring appointment item then the calendar folder.
' Single appointment leads to
' the calendar folder then the mailbox name.
Set parentOfAppointment = appointment_item.Parent
Set parentParentFolder = parentOfAppointment.Parent
Debug.Print vbCr & " parentParentFolder: " & parentParentFolder.Name
Set sourceFolder = parentParentFolder
' Error bypass for a specific purpose
On Error Resume Next
' If parentParentFolder is the shared calendar,
' walking up one folder is the mailbox.
' If parentParentFolder is the mailbox,
' walking up one folder is an error that is bypassed,
' so no change in sourceFolder.
' Assumption:
' The shared calendar is directly under the mailbox
' otherwise add more Set sourceFolder = sourceFolder.Parent
Set sourceFolder = sourceFolder.Parent
' Return to normal error handling immediately
On Error GoTo 0
Debug.Print " sourceFolder should be smtp address: " & sourceFolder
'MsgBox " sourceFolder should be smtp address: " & sourceFolder
End Sub
I'm trying to write a macro with VBA in Solidworks that will go through all the sub assemblies and save every part as STEP-file where the name is determined by a custom property. I don't have a lot of programming experience as I'm an mechanical engineer but I try to automate some processes from time to time. Most of this code I got from others and I tried to tweak it to my situation. I do understand most of what is happening though.
The problem I'm having is that I keep getting a
91 runtime error
When I go to debugging Solidworks tells me the problem is in the line name = swPart.GetTitle. At first it said "name = nothing". I tried looking for the problem and when i added Set swApp = Application.SldWorks to the sub I still got the error but now name is always something.
Dim swApp As SldWorks.SldWorks
Dim swAssy As SldWorks.AssemblyDoc
Dim swConf As SldWorks.Configuration
Dim swRootComp As SldWorks.Component2
Dim retVal As Boolean
Dim errors As Long, warnings As Long
Dim revision As String
Dim vaultPath As String
Dim name As String
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set swAssy = swApp.ActiveDoc
Set swConf = swAssy.GetActiveConfiguration
Set swRootComp = swConf.GetRootComponent3(True)
vaultPath = "C:\Users\Engineering\Desktop\test\" 'set folder for vault (change this later)
TraverseComponent swRootComp, 1, vaultPath
End Sub
Sub TraverseComponent(swComp As SldWorks.Component2, nLevel As Long, vaultPath As String)
Dim vChilds As Variant, vChild As Variant
Dim swChildComp As SldWorks.Component2
Dim MyString As String
Dim swCustPropMgr As SldWorks.CustomPropertyManager
Set swApp = Application.SldWorks
vChilds = swComp.GetChildren
For Each vChild In vChilds
Set swChildComp = vChild
Dim FileName As String
FileName = swChildComp.GetPathName
FileName = Left(FileName, InStr(FileName, ".") - 1)
FileName = Right(FileName, Len(FileName) - InStrRev(FileName, "\"))
Debug.Print "Part Name : " & FileName
MyString = FileName
Dim ActiveConfig As String
ActiveConfig = swChildComp.ReferencedConfiguration
Debug.Print "Configuration: " & ActiveConfig
FileName = swChildComp.GetPathName
If UCase(Right(FileName, 6)) = "SLDPRT" Then
'MsgBox ("part found")
Dim swPart As SldWorks.ModelDoc2
Set swPart = swApp.OpenDoc6(swChildComp.GetPathName, 1, 0, "", longstatus, longwarnings)
'Dim name As String 'I tried adding this but it made no difference
name = swPart.GetTitle 'get the title of the active document
'chop the extension off if present
If Right(name, 7) = ".SLDPRT" Or Right(name, 7) = ".SLDasm" Then
name = Left(name, Len(name) - 7)
End If
Set swCustPropMgr = swPart.Extension.CustomPropertyManager("") 'get properties
revision = swCustPropMgr.Get("Revision") 'get revision
retVal = swApp.SetUserPreferenceIntegerValue(swUserPreferenceIntegerValue_e.swStepAP, 214) 'change the step file options
'save with revision if present
If revision = "" Or revision = Null Then
retVal = swPart.Extension.SaveAs(vaultPath & name & ".step", swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, errors, warnings)
Else
retVal = swPart.Extension.SaveAs(vaultPath & name & " - Rev " & revision & ".step", swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, errors, warnings)
End If
swApp.CloseDoc swPart.GetTitle
End If
Debug.Print
TraverseComponent swChildComp, nLevel + 1, vaultPath
Next
End Sub
A suppressed component is not the only reason why you could get a "nothing" after calling OpenDoc. This happens e.g. if the component is loaded lightweight or is otherwise not fully loaded. Then you are also not able to get the ModelDoc (PartDoc) data of a component object.
To prevent this completely you could execute the next lines only if the swPart variable is not nothing.
If (Not swPart Is Nothing) Then
name = swPart.GetTitle 'get the title of the active document
...
End If
Additionally I can say you don't necessarily need to use OpenDoc/CloseDoc because the component is already loaded into memory when the assembly is loaded. Therefore it is enough to call GetModelDoc2 of the child component. But in the end it has the same behaviour and will return nothing if the component is not fully loaded.
set swPart = swChildcomp.GetModelDoc2()
As the title suggests, I have three separate text files that I want to join together in a certain order (i.e., append file1, file2, file3 (in order) to make file4).
From what I've read, to do this with VBScript would require the FileSystemObject to read the files into an array then write the contents to the new file (I am open to whatever works with VBScript if suggested)
I'm having the following issues with my code:
1) The script runs, but produces no data
2) After I get it to run, it is imperative that the files append to the output file in the order of the array in the order (per line) I suggest above.
Here is the Array example I'm working with :
CODE
Const ForReading = 1
Dim arrServiceList(2)
arrServiceList(0) = strText1
arrServiceList(1) = strText2
arrServiceList(2) = strText3
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOutputFile = objFSO.CreateTextFile("output.txt")
Set objTextFile1 = objFSO.OpenTextFile("C:\Users\95540\Desktop\Sample1.txt", ForReading)
Set objTextFile2 = objFSO.OpenTextFile("C:\Users\95540\Desktop\Sample2.txt", ForReading)
Set objTextFile3 = objFSO.OpenTextFile("C:\Users\95540\Desktop\Sample3.txt", ForReading)
strText1 = objTextFile1.ReadAll
objTextFile1.Close
strText2 = objTextFile2.ReadAll
objTextFile2.Close
strText3 = objTextFile3.ReadAll
objTextFile3.Close
objOutputFile.WriteLine arrServiceList(0)
objOutputFile.Close
====================
UPDATE TO MY CODE 5-15-15 (Description of corrections in below post)
CODE
Const ForReading = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOutputFile = objFSO.CreateTextFile("output.txt")
Set objTextFile1 = objFSO.OpenTextFile("C:\Users\Brill\Desktop\Grab1.txt", ForReading)
Set objTextFile2 = objFSO.OpenTextFile("C:\Users\Brill\Desktop\Grab2.txt", ForReading)
Set objTextFile3 = objFSO.OpenTextFile("C:\Users\Brill\Desktop\Grab3.txt", ForReading)
Do While objTextFile1.AtEndOfStream <> True
Do While objTextFile2.AtEndOfStream <> True
Do While objTextFile3.AtEndOfStream <> True
strText1 = objTextFile1.ReadLine
objOutputFile.Write strText1 & vbTab
strText2 = objTextFile2.ReadLine
objOutputFile.Write strText2 & vbTab
strText3 = objTextFile3.ReadLine
objOutputFile.Write strText3 & vbTab & vbCrLf
Loop
Loop
Loop
objOutputFile.Close
objTextFile1.Close
objTextFile2.Close
objTextFile3.Close
The below works.
Problems with your script. 1. You were assigning the variables to the array before you had populated them. 2. You were not writing all the elements of the array.
Const ForReading = 1
Dim arrServiceList(2)
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objOutputFile = objFSO.CreateTextFile("output.txt")
Set objTextFile1 = objFSO.OpenTextFile("C:\Users\95540\Desktop\Sample1.txt", ForReading)
Set objTextFile2 = objFSO.OpenTextFile("C:\Users\95540\Desktop\Sample2.txt", ForReading)
Set objTextFile3 = objFSO.OpenTextFile("C:\Users\95540\Desktop\Sample3.txt", ForReading)
strText1 = objTextFile1.ReadAll
objTextFile1.Close
strText2 = objTextFile2.ReadAll
objTextFile2.Close
strText3 = objTextFile3.ReadAll
objTextFile3.Close
arrServiceList(0) = strText1
arrServiceList(1) = strText2
arrServiceList(2) = strText3
objOutputFile.WriteLine arrServiceList(0)
objOutputFile.WriteLine arrServiceList(1)
objOutputFile.WriteLine arrServiceList(2)
objOutputFile.Close
Merging/Zipping more then one collection (e.g. some 'column files') into one collection (e.g. a 'table file') is a standard problem with a standard solution strategy (which doesn't involve reading "the files into an array" at all).
This demo code:
Option Explicit
Dim goFS : Set goFS = CreateObject("FileSystemObject")
Dim oFZip : Set oFZip = New cFZip
oFZip.m_aIFSpecs = Split("..\data\a.txt ..\data\b.txt ..\data\c.txt")
oFZip.zip "..\data\abc.txt"
WScript.Echo goFS.OpenTextFile("..\data\abc.txt").ReadAll()
Class cFZip
Public m_aIFSpecs ' array of input files
Function zip(sOFSpec)
Dim tsOut : Set tsOut = goFS.CreateTextFile(sOFSpec)
Dim nUBFiles : nUBFiles = UBound(m_aIFSpecs)
ReDim aFiles(nUBFiles)
Dim f
For f = 0 To nUBFiles
Set aFiles(f) = goFS.OpenTextFile(m_aIFSpecs(f))
Next
Dim bDone
Do
Redim aData(UBound(m_aIFSpecs))
bDone = True
For f = 0 To nUBFiles
If Not aFiles(f).AtEndOfStream Then
bDone = False
aData(f) = aFiles(f).ReadLine()
End If
Next
If Not bDone Then tsOut.WriteLine Join(aData, ",")
Loop Until bDone
For f = 0 To nUBFiles
aFiles(f).Close
Next
tsOut.Close
End Function
End Class
output:
1,10,100
2,20,200
3,30,300
4,,400
,,500
shows the basic approach. I use a Class to make experiments/specific adaptions (e.g. delimiter, quoting, ...) easier.
I want to call an ABAP function from an Excel VBA Macro.
Is there any method I can follow to achieve this.
Please help me regarding this.
Dim sapConn As Object 'Declare connection object
Set sapConn = CreateObject("SAP.Functions") 'Create ActiveX object
sapConn.Connection.user = "user" 'Specify user
sapConn.Connection.Password = "" 'Then password
sapConn.Connection.client = "001" 'Client
sapConn.Connection.ApplicationServer = "server" 'Target server address
sapConn.Connection.Language = "PT" 'Language code
'Finally, try to logon to the specified system and check if the connection established
If sapConn.Connection.Logon(0, True) <> True Then
MsgBox "Cannot Log on to SAP" 'Issue message if cannot logon
Else
MsgBox "Logged on to SAP!"
End If
Dim rfcAcctDocCheck As Object
Dim oAcctHeader As Object
Dim otAcctAR, otAcctGL, otAcctAP, otAcctAMT, otReturn As Object
Set rfcAcctDocCheck = sapConn.Add("BAPI_ACC_DOCUMENT_CHECK")
Set oAcctHeader = rfcAcctDocCheck.Exports("DOCUMENTHEADER")
Set otAcctGL = rfcAcctDocCheck.Tables("ACCOUNTGL")
Set otAcctAR = rfcAcctDocCheck.Tables("ACCOUNTRECEIVABLE")
Set otAcctAP = rfcAcctDocCheck.Tables("ACCOUNTPAYABLE")
Set otAcctAMT = rfcAcctDocCheck.Tables("CURRENCYAMOUNT")
Set otReturn = rfcAcctDocCheck.Tables("RETURN")
Dim qtLegs As Integer
Dim dt, comp, tpDoc, docRef, tpAcct, acct, customer, vendor, _
curr, val, spLedger, ccenter, order As String
Dim curLine As Integer
For lin = 1 To UBound(reg)
id = Format(tbPost.Cells(reg(lin).lin_ini, K_COL_ID), "0000000000")
dt = getDate(tbPost.Cells(reg(lin).lin_ini, K_COL_DT))
comp = getCompanyCode(tbPost.Cells(reg(lin).lin_ini, K_COL_EMPR))
tpDoc = getDocumentType(tbPost.Cells(reg(lin).lin_ini, K_COL_TP_DOC))
docRef = tbPost.Cells(reg(lin).lin_ini, K_COL_DOC_REF)
otAcctGL.freeTable
otAcctAR.freeTable
otAcctAP.freeTable
otAcctAMT.freeTable
oAcctHeader("USERNAME") = sapConn.Connection.user
oAcctHeader("HEADER_TXT") = "Lancado via Excel"
oAcctHeader("COMP_CODE") = comp
oAcctHeader("DOC_DATE") = dt
oAcctHeader("PSTNG_DATE") = dt
oAcctHeader("DOC_TYPE") = tpDoc
oAcctHeader("REF_DOC_NO") = docRef
otAcctAMT.Rows.Add
otAcctAMT(otAcctAMT.Rows.Count, "ITEMNO_ACC") = Format(leg, "0000000000")
otAcctAMT(otAcctAMT.Rows.Count, "CURRENCY") = curr
otAcctAMT(otAcctAMT.Rows.Count, "AMT_BASE") = val
Next
If rfcAcctDocCheck.Call = False Then
MsgBox rfcAcctDocCheck.Exception
End If