I am getting error as Compile Error: Argument Not Optional when running vba code pointing towards the line. MsgBox (RemoveFirstChar)
Code:
Sub test()
Dim Currworkbook As Workbook
Dim CurrWKSHT As Worksheet
Dim Filename As String
Dim BCName As String
Dim Str As String
FFolder = "C:\user"
CurrLoc = "File3"
If CurrrLoc = "File3" Then
CurrLoc = FFolder & "\" & CurrLoc
Set FSobj = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set FFolderObj = FSobj.GetFolder(CurrLoc)
If Err.Number > 0 Then
'
End If
For Each BCObj In FFolderObj.Files
'BCName = Right(BCObj.Name, (Len(BCObj.Name) - InStrRev(BCObj.Name, "\", 1)))
If IsNumeric(Left(BCObj.Name, 4)) <> True Then
Call RemoveFirstChar(BCObj.Name)
'Str = RemoveFirstChar
MsgBox (RemoveFirstChar) '--->Error: Compile Error: Argument Not Optional
Else
MsgBox (BCObj.Name)
End If
Next
End If
End Sub
Public Function RemoveFirstChar(RemFstChar As String) As String
Dim TempString As String
TempString = RemFstChar
If Left(RemFstChar, 1) = "1" Then
If Len(RemFstChar) > 1 Then
TempString = Right(RemFstChar, Len(RemFstChar) - 1)
End If
End If
RemoveFirstChar = TempString
End Function
RemoveFirstChar is a user defined function that requires a non-optional string as a parameter.
Public Function RemoveFirstChar(RemFstChar As String) As String
....
End Function
I think you want to get rid of the Call RemoveFirstChar(BCObj.Name) then use,
MsgBox RemoveFirstChar(BCObj.Name)
Related
I have watched many videos on calling another sub. But with my code every time it gets to the line where it should call the function. It just finished the IF statement without following this command. Please note that this code is from a commandbutton inside of a userforum
Sub Begin_Click()
Unload BeginTheCode
Dim ws As Worksheet
Dim strDataRange As Range
Dim keyRange As Range
Dim wbk As Workbook
Dim wbkName As String
Dim wsName As String
Dim mName As String
Dim yName As String
Dim cName As String
On Error GoTo Err
'This command puts the other code in this workbook on hold'
Application.DisplayAlerts = False
'This provides shortcuts for future use in the code'
Set wa = ThisWorkbook.Worksheets("RE-I-A Raw")
Set wb = ThisWorkbook.Worksheets("I-A Data Copy (1)")
Set wc = ThisWorkbook.Worksheets("Untied Raw")
Set wd = ThisWorkbook.Worksheets("Blanks")
Dim IMRCCSpec() As String
Dim IMRSup() As String
Dim x As Integer
Dim y As Integer
Dim i As Integer
If Comittee = "IMRCC" Then
Call IM
Else
If Comittee = "COO" Then
Call COO
Else
If Comittee = "CFO" Then
Call CFO
Else
If Comittee = "AURA" Then
Call AURA
Else
If Comittee = "Distribution" Then
Call Dist
Else
If Comittee = "Legal" Then
Call Legal
End If
End If
End If
End If
End If
End If
Exit Sub
Err:
MsgBox "Error on Line : Sub Begin_Click() " & Erl
End Sub
Sub IM()
On Error GoTo Err
Dim IMRCCSpec() As String
Dim IMRSup() As String
Dim x As Integer
Dim y As Integer
x = Application.WorksheetFunction.CountA(wt.Range("C:C")) - 2
y = Application.WorksheetFunction.CountA(wt.Range("E:E")) - 2
ReDim IMRCCSpec(x) As String
ReDim IMRCCSup(y) As String
Dim i As Integer
For i = 0 To x
IMRCCSpec(i) = wt.Range("A" & i + 2)
Next i
For i = 0 To y
IMRCCSup(i) = wt.Range("B" & i + 2)
Next i
'Call Something
Exit Sub
Err:
MsgBox "Error on Line : Sub IM()" & Erl
End Sub
No error messages occur. when I use the F8 command it goes through this line without any error and does not do anything
I wrote a script where I add a signature from an htm file in the appData ... signature folder to a newly opened email.
My question is - how do i modify this VBA script to add that signature in a way so Outlook knows its a signature and the signature might be changed by a user via gui.
I assume it may have something to do with setting a "_MailAutoSig" bookmark, is that right?
Script looks like this and works so far:
Dim WithEvents m_objMail As Outlook.MailItem
Dim LODGIT_SUBJECT_IDENTIFIERS() As String
Private Sub Application_ItemLoad(ByVal Item As Object)
'MsgBox "Application_ItemLoad"
Select Case Item.Class
Case olMail
Set m_objMail = Item
End Select
End Sub
Private Sub m_objMail_Open(Cancel As Boolean)
'string array containing lodgit email subject identifiers (beginning string!!! of email subject)
LODGIT_SUBJECT_IDENTIFIERS = Split("Angebot von Bödele Alpenhotel,Angebot von,bestätigt Ihre Reservierung,Rechnung Nr.,Stornogutschrift für die Rechnung,Ausstehende Zahlung", ",")
Dim Application As Object
Dim oOutApp As Object, oOutMail As Object
Dim strbody As String, FixedHtmlBody As String
Dim Ret
Set Application = CreateObject("Outlook.Application")
'Change only Mysig.htm to the name of your signature
' C:\Users\nicole\AppData\Roaming\Microsoft\Signatures
Ret = Environ("appdata") & _
"\Microsoft\Signatures\AH Andrea kurz.htm"
If Ret = False Then Exit Sub
'~~> Use the function to fix image paths in the htm file
FixedHtmlBody = FixHtmlBody(Ret)
'CHECK FOR LODGIT IDENTIFIER
If myInStr(m_objMail.Subject, LODGIT_SUBJECT_IDENTIFIERS()) Then
Debug.Print "E-Mail as from Lodgit identified"
Dim str As String
Dim a As Object
str = Replace(m_objMail.Body, vbCrLf, "<br>")
str = Replace(str, vbNewLine, "<br>")
m_objMail.HTMLBody = "<html><body><span style='font-size:11.0pt;font-family:""Times New Roman"" '>" & str & "</span>" & FixedHtmlBody & "</body></html>"
End If
End Sub
'~~> Function to fix image paths in Signature .htm Files
Function FixHtmlBody(r As Variant) As String
Dim FullPath As String, filename As String
Dim FilenameWithoutExtn As String
Dim foldername As String
Dim MyData As String
'~~> Read the html file as text file in a string variable
Open r For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
'~~> Get File Name from path
filename = GetFilenameFromPath(r)
'~~> Get File Name without extension
FilenameWithoutExtn = Left(filename, (InStrRev(filename, ".", -1, vbTextCompare) - 1))
'~~> Get the foldername where the images are stored
foldername = FilenameWithoutExtn & "-Dateien"
'~~> Full Path of Folder
FullPath = Left(r, InStrRev(r, "\")) & foldername
'~~> To cater for spaces in signature file name
'FullPath = Replace(FullPath, " ", "%20")
'~~> Replace incomplete path with full Path
FixHtmlBody = Replace(MyData, "AH%20Andrea%20kurz-Dateien", FullPath)
'FixHtmlBody = Replace(MyData, foldername, FullPath)
End Function
'~~> Gets File Name from path
Public Function GetFilenameFromPath(ByVal strPath As String) As String
If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then _
GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
End Function
'check if str contains on of the elements of a str array
Public Function myInStr(myString As String, a() As String) As Boolean
For Each elem In a
If InStr(1, myString, elem, vbTextCompare) <> 0 Then
myInStr = True
Exit Function
End If
Next
myInStr = False
End Function
Outlook looks for the "_MailAutoSig" bookmark. This needs to be done with Word Object Model, not by setting the HTMLBody property. Something along the lines:
wdStory = 6
wdMove = 0
Set objBkm = Nothing
Set objDoc = Inspector.WordEditor
Set objSel = objDoc.Application.Selection
'remember the cursor position
set cursorRange = objDoc.Range
cursorRange.Start = objSel.Start
cursorRange.End = objSel.End
If objDoc.Bookmarks.Exists("_MailAutoSig") Then
'replace old signature
Debug.Print "old signature found"
set objBkm = objDoc.Bookmarks("_MailAutoSig")
objBkm.Select
objDoc.Windows(1).Selection.Delete
ElseIf objDoc.Bookmarks.Exists("_MailOriginal") Then
' is there the original email? (_MailOriginal)
set objBkm = objDoc.Bookmarks("_MailOriginal")
objSel.Start = objBkm.Start-2 'give room for the line break before. It includes the line
objSel.End = objBkm.Start-2
Else
'insert at the end of the email
objSel.EndOf wdStory, wdMove
End If
'start bookmark
set bkmStart = objDoc.Bookmarks.Add("_tempStart", objSel.Range)
'end bookmark
set bkmEnd = objDoc.Bookmarks.Add("_tempEnd", objSel.Range)
bkmEnd.End = bkmEnd.End + 1
bkmEnd.Start = bkmEnd.Start + 1
objSel.Text = " "
set objBkm = objDoc.Bookmarks.Add("_MailAutoSig", bkmStart.Range)
objBkm.Range.insertFile "c:\Users\<user>\AppData\Roaming\Microsoft\Signatures\test.htm", , false, false, false
objBkm.Range.InsertParagraphBefore
objBkm.End = bkmEnd.Start - 1 'since we added 1 above for bkmEnd
objSel.Start = cursorRange.Start
objSel.End = cursorRange.End
bkmStart.Delete
bkmEnd.Delete
I have a VBA code that pulls images and inserts in Excel file based on cell value in column A. But in my P drive, from where it pulls images, I have images that end with ' -TH ' and I want to exclude them. i.e. I have image in P drive, that named as "CITY-B" and the other one as "CITY-B-TH". And when I type 'CITY'(this is how I need the name to be typed in excel), I want it to insert the one without "TH". How can i do that?
Private Sub Worksheet_Change(ByVal Target As Range)
If (Split(Target.Address, "$")(1) <> "A") Then Exit Sub
Call Inser_Image(Target)
End Sub
Private Sub Inser_Image(Ac_Cells As Range)
Dim myRng As Range
Dim Mycell As Range
Dim St As String
Dim myPath As String
Dim My_Pic As Shape
Dim My_File As String
Dim Ac_cell As Range
myPath = Sheet1.Cells(1, 5).Value
If Len(myPath) > 3 Then
If Right(myPath, 1) <> "\" Then
myPath = myPath + "\"
End If
End If
For Each Ac_cell In Ac_Cells
For Each My_Pic In Sheet1.Shapes
If My_Pic.Left = Ac_cell.Offset(0, 1).Left And My_Pic.Top = Ac_cell.Offset(0, 1).Top Then
My_Pic.Delete
Exit For
End If
Next
St = Trim(Ac_cell.Value)
If Len(St) > 4 Then
If LCase(Left(St, 4)) = "http" Then
Call Insert_Picture(St, Ac_cell.Offset(0, 1))
GoTo Nextse1
End If
End If
myPath = "P:\"
If Right(myPath, 1) <> "\" Then myPath = myPath + "\"
If Not (Dir(myPath + St)) = "" Then
My_File = St
Else
My_File = Find_File(myPath, St)
End If
If My_File > " " Then
Call Insert_Picture(myPath + My_File, Ac_cell.Offset(0, 1))
End If
Application.ScreenUpdating = True
Nextse1:
Next
End Sub
Sub Insert_Picture(thePath As String, theRange As Range)
On Error GoTo Err3
Dim myPict As Shape
Sheet1.Shapes.AddPicture thePath, True, True, theRange.Left, theRange.Top, theRange.Width, theRange.Height
Set myPict = Sheet1.Shapes(Sheet1.Shapes.Count)
With myPict
.LockAspectRatio = msoFalse
.Placement = xlMoveAndSize
End With
Set myPict = Nothing
Exit Sub
Err3:
MsgBox Err.Description
End Sub
Function Find_File(thePath As String, F_N As String) As String
file = Dir(thePath)
Do Until file = ""
If Len(file) < Len(F_N) Then GoTo EXT_N1
If LCase(Left(file, Len(F_N))) = LCase(F_N) Then
Find_File = file
Exit Function
End If
EXT_N1:
file = Dir()
Loop
Find_File = ""
End Function
Put the EndsWith function in your code. (I included a starts with if it helps down the road) and use it like this:
If My_File > " " Then
If EndsWith(My_File,"-TH") Then
else
Call Insert_Picture(myPath + My_File, Ac_cell.Offset(0, 1))
End If
End If
Public Function EndsWith(str As String, ending As String) As Boolean
Dim endingLen As Integer
endingLen = Len(ending)
EndsWith = (Right(Trim(UCase(str)), endingLen) = UCase(ending))
End Function
Public Function StartsWith(str As String, start As String) As Boolean
Dim startLen As Integer
startLen = Len(start)
StartsWith = (Left(Trim(UCase(str)), startLen) = UCase(start))
End Function
Use InStr to search in the filename your pattern "-TH"
Dim pos As Integer
pos = InStr("find the comma, in the string", ",")
Does anyone have an idea how to return parameter name in VBA?
This is what I have:
Sub Main()
Dim MyString As String
MyString = "Hello World"
MsgBox MyString
End Sub
It shows only "Hello World". I would like to have it "MyString says Hello World", but dynamically, not by entering
MsgBox "MyString says " & MyString
I would prefer something like
MsgBox ParamName(MyString) & " says " & MyString
but it actually won't work... Could anyone help?
I believe I have accomplished what you are looking to do here. However, please note that this will currently only work for your first parameter in a macro assigned to a Form control:
Step 1
Add the following code, adapted from here, to a new Module:
Public Function ExportModules(ModuleName As String) As String
Dim bExport As Boolean
Dim wkbSource As Excel.Workbook
Dim szSourceWorkbook As String
Dim szExportPath As String
Dim szFileName As String
Dim cmpComponent As VBIDE.VBComponent
''' The code modules will be exported in a folder named.
''' VBAProjectFiles in the Documents folder.
''' The code below create this folder if it not exist
''' or delete all files in the folder if it exist.
If FolderWithVBAProjectFiles = "Error" Then
MsgBox "Export Folder not exist"
Exit Function
End If
On Error Resume Next
Kill FolderWithVBAProjectFiles & "\*.*"
On Error GoTo 0
''' NOTE: This workbook must be open in Excel.
szSourceWorkbook = ActiveWorkbook.Name
Set wkbSource = Application.Workbooks(szSourceWorkbook)
If wkbSource.VBProject.Protection = 1 Then
MsgBox "The VBA in this workbook is protected," & _
"not possible to export the code"
Exit Function
End If
szExportPath = FolderWithVBAProjectFiles & "\"
Set cmpComponent = wkbSource.VBProject.VBComponents(ModuleName)
bExport = True
szFileName = cmpComponent.Name
''' Concatenate the correct filename for export.
Select Case cmpComponent.Type
Case vbext_ct_ClassModule
szFileName = szFileName & ".cls"
Case vbext_ct_MSForm
szFileName = szFileName & ".frm"
Case vbext_ct_StdModule
szFileName = szFileName & ".bas"
Case vbext_ct_Document
''' This is a worksheet or workbook object.
''' Don't try to export.
bExport = False
End Select
If bExport Then
''' Export the component to a text file.
cmpComponent.Export szExportPath & szFileName
''' remove it from the project if you want
'''wkbSource.VBProject.VBComponents.Remove cmpComponent
End If
ExportModules = szExportPath & szFileName
End Function
Function FolderWithVBAProjectFiles() As String
Dim WshShell As Object
Dim FSO As Object
Dim SpecialPath As String
Set WshShell = CreateObject("WScript.Shell")
Set FSO = CreateObject("scripting.filesystemobject")
SpecialPath = WshShell.SpecialFolders("MyDocuments")
If Right(SpecialPath, 1) <> "\" Then
SpecialPath = SpecialPath & "\"
End If
If FSO.FolderExists(SpecialPath & "VBAProjectFiles") = False Then
On Error Resume Next
MkDir SpecialPath & "VBAProjectFiles"
On Error GoTo 0
End If
If FSO.FolderExists(SpecialPath & "VBAProjectFiles") = True Then
FolderWithVBAProjectFiles = SpecialPath & "VBAProjectFiles"
Else
FolderWithVBAProjectFiles = "Error"
End If
End Function
Step 2
Add the following code, adapted from answer #7 here, and from here, along with my own function, to a new module (it could be the same module as the first if preferred):
Public Function MyMacroInfo() As String
Dim MacroName$, SubName$, ModArr As Variant
Dim ModName As Object, strModName$, i&, j&
MacroName = ActiveSheet.Buttons(Application.Caller).OnAction
SubName = Application.Replace(MacroName, 1, Application.Search("!", MacroName), "")
ModArr = Array(0, 1, 2, 3)
For Each ModName In ActiveWorkbook.VBProject.VBComponents
For j = LBound(ModArr) To UBound(ModArr)
i = 0
On Error Resume Next
i = ModName.CodeModule.ProcStartLine(SubName, CLng(ModArr(j)))
Err.Clear
If i > 0 Then
strModName = ModName.Name
Exit For
End If
Next j
Next ModName
MyMacroInfo = strModName
End Function
Public Function GetParamName(ModulePath As String) As String
Dim text As String
Dim textline As String
Dim ParamStartLocation As Long
Dim ParamEndLocation As Long
Dim ParamLength As Long
Dim i As Long
Open ModulePath For Input As #1
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
Close #1
ParamStartLocation = 0
For i = 1 To 3
ParamStartLocation = InStr(ParamStartLocation + 1, text, "Dim ")
Next i
ParamEndLocation = InStr(ParamStartLocation, text, " As ")
ParamLength = ParamEndLocation - ParamStartLocation
GetParamName = Left(Right(text, Len(text) - ParamStartLocation - 3), ParamLength - 4)
End Function
Step 3
Change your sub to the following:
Sub Main()
'--------Leave this section at the top of your sub---------
Dim strExportedModule As String
Dim strParamName As String
strExportedModule = ExportModules(MyMacroInfo)
strParamName = GetParamName(strExportedModule)
'-----------------Start your code here---------------------
Dim MyString As String
MyString = "Hello World"
MsgBox strParamName & " says " & MyString
End Sub
Step 4
Assign Main to a Form Button.
Notes
As noted above, this will only get the first parameter that you dimension in the macro assigned to the Form Button. If this is not acceptable, I'll have to take a look at it to see if it can be modified to meet your needs.
As Ron de Bruin notes on his site, you'll need to do the following:
In the VBE Editor set a reference to "Microsoft Visual Basic For
Applications Extensibility 5.3" and to "Microsoft Scripting Runtime"
and then save the file.
This code will export the module to a folder named "VBAProjectFiles" in your My Documents folder. If you happen to have a folder saved there with the same name (as unlikely as that is), it will delete all the files in that folder.
Vba newbie. Need a function to output the last modification date of an open workbook. Here is what I have so far but I am getting a message that my formula contains an error when I invoke the function:
Function LastWBModDate(wbname)
ActivateWB (wbname)
LastWBModDate = Format(FileDateTime(ActiveWorkbook.FullName), "m/d/yy h:n ampm")
End Function
Public Function ActivateWB(wbname As String)
If IsWBOpen(wbname) Then
Workbooks(wbname).Activate
Else
MsgBox "Workbook : " & wbname & " is not open " & vbNewLine
End If
End Function
Public Function IsWBOpen(wbname As String) As Boolean
On Error Resume Next
If Workbooks(wbname) Is Nothing Then
IsWBOpen = False
Else
IsWBOpen = True
End If
End Function
Thanks!
Function LastWBModDate(wbname As String)
Dim rv, wb As Workbook
rv = "workbook?" 'default return value
On Error Resume Next
Set wb = Workbooks(wbname)
On Error GoTo 0
If Not wb Is Nothing Then
rv = Format(FileDateTime(wb.FullName), "m/d/yy h:n ampm")
End If
LastWBModDate = rv
End Function
Try below code :
You may also refer this link
Put below code on ThisWorkbook code section
Private Sub Workbook_Open()
LastWBModDate
End Sub
Put this code in any Standard Module
Function LastWBModDate() As String
Dim FSO As Object
Dim File As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set File = FSO.GetFile(ThisWorkbook.FullName)
LastWBModDate = Format(File.DateLastModified, "m/d/yy h:n ampm")
Msgbox LastWBModDate
Set FSO = Nothing
End Function