Adding line numbers to VBA code (Microsoft Access 2016) [duplicate] - vba
I want to have line numbers in my VBA code for debugging reasons. That will allow me to know where a particular error occurred.
Is there an automatic feature for this (such as an option in settings)? Or do I need to write my own macro?
If I need to write my own macro to accomplish this task, how would I go about doing such a thing?
You don't want line numbers.
Not for "debugging reasons", not for anything. Line numbers are deprecated for a reason: they're a relic of an ancient time before procedures even existed, and GOTO the only way to get anywhere.
Erl only returns the last encountered line number before an error was raised. This can mean misleading error logs, if you're logging errors:
Sub DoSomething()
10 On Error GoTo 50
Debug.Print 42 / 0
30 Exit Sub
50 Debug.Print "Error raised on line " & Erl 'returns 10
End Sub
Also, line numbers only have Integer resolution (a VBA module can have up to 65,535 lines, which is twice that resolution), and will silently fail and happily report wrong line numbers if you don't keep that in mind:
Sub DoSomething()
99997 On Error GoTo 99999
99998 Debug.Print 42 / 0
99999
Debug.Print Erl 'Prints 34462 - and which line is that?
End Sub
Any serious VBA application will use structured error handling instead.
Write small, specialized procedures (i.e. write code that follows modern-day best practices), and the line number becomes utterly meaningless.
Line numbers are a pain in the neck to maintain; they clutter up the code and make it overall harder to read (and therefore to debug).
That said, IIRC MZ-Tools 3 had such a functionality.
Keep in mind, that BASIC looked like this when line numbers were a thing:
10 GOSUB 100
20 GOSUB 1000
99 END
100 REM CLEAR SCREEN
110 PRINT CHR$(147)
120 RETURN
200 REM MODULO
210 LET MOD% = V%-INT(V%/FB%)*FB%
220 RETURN
1000 REM INIT VARIABLES
1010 LET FIZZ$ = "FIZZ"
1011 LET BUZZ$ = "BUZZ"
1020 LET FIZZ% = 3
1021 LET BUZZ% = 5
1030 LET MIN% = 1
1031 LET MAX% = 15
1100 PRINT FIZZ$ + ":" + STR$(FIZZ%)
1101 PRINT BUZZ$ + ":" + STR(BUZZ%)
1102 PRINT FIZZ$ + BUZZ$ + ":" + STR$(FIZZ%*BUZZ%)
1105 PRINT
2000 REM ACTUAL FIZZBUZZ LOOP
2010 FOR X = MIN% TO MAX%
2015 LET RESULT$ = STR$(X)
2020 LET FB% = FIZZ%*BUZZ%
2021 LET V% = X
2024 GOSUB 200
2025 IF MOD%=0 THEN LET RESULT$=FIZZ$+BUZZ$ : GOTO 2050
2030 LET FB% = FIZZ%
2031 GOSUB 200
2035 IF MOD%=0 THEN LET RESULT$=FIZZ$ : GOTO 2050
2040 LET FB% = BUZZ%
2041 GOSUB 200
2045 IF MOD%=0 THEN LET RESULT$=BUZZ$ : GOTO 2050
2050 PRINT RESULT$
2090 NEXT X
2099 RETURN
The above is a working Commodore 64 BASIC 2.0 fizzbuzz program. VBA has fabulous backward-compatibility. With only slight modifications, it runs in VBA:
Sub Main()
10 GoSub 100
20 GoSub 1000
99 End
100 Rem CLEAR SCREEN
110 'Debug.Print Chr$(147) 'Chr$(147) was a special character on C64
120 Return
200 Rem MODULO
210 Let Modulo% = V% - Int(V% / FB%) * FB%
220 Return
1000 Rem INIT VARIABLES
1010 Let FIZZ$ = "FIZZ"
1011 Let BUZZ$ = "BUZZ"
1020 Let FZZ% = 3
1021 Let BZZ% = 5
1030 Let Min% = 1
1031 Let Max% = 15
1100 Debug.Print FIZZ$ + ":" + Str$(FZZ%)
1101 Debug.Print BUZZ$ + ":" + Str(BZZ%)
1102 Debug.Print FIZZ$ + BUZZ$ + ":" + Str$(FZZ% * BZZ%)
1105 Debug.Print
2000 Rem ACTUAL FIZZBUZZ LOOP
2010 For X = Min% To Max%
2015 Let RESULT$ = Str$(X)
2020 Let FB% = FZZ% * BZZ%
2021 Let V% = X
2024 GoSub 200
2025 If Modulo% = 0 Then Let RESULT$ = FIZZ$ + BUZZ$: GoTo 2050
2030 Let FB% = FZZ%
2031 GoSub 200
2035 If Modulo% = 0 Then Let RESULT$ = FIZZ$: GoTo 2050
2040 Let FB% = BZZ%
2041 GoSub 200
2045 If Modulo% = 0 Then Let RESULT$ = BUZZ$: GoTo 2050
2050 Debug.Print RESULT$
2090 Next X
2099 Return
End Sub
Don't write 1980's code, we're 40 years later.
I use this code for adding line numbers to my Excel projects. I found it online a while back and I don't remember where I got it, so credit goes to whoever originally wrote this:
Sub AddLineNumbers(wbName As String, vbCompName As String)
'See MakeUF
Dim i As Long, j As Long, lineN As Long
Dim procName As String
Dim startOfProceedure As Long
Dim lengthOfProceedure As Long
Dim newLine As String
With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule
.CodePane.Window.Visible = False
For i = 1 To .CountOfLines
procName = .ProcOfLine(i, vbext_pk_Proc)
If procName <> vbNullString Then
startOfProceedure = .ProcStartLine(procName, vbext_pk_Proc)
lengthOfProceedure = .ProcCountLines(procName, vbext_pk_Proc)
If startOfProceedure + 1 < i And i < startOfProceedure + lengthOfProceedure - 1 Then
newLine = RemoveOneLineNumber(.Lines(i, 1))
If Not HasLabel(newLine) And Not (.Lines(i - 1, 1) Like "* _") Then
.ReplaceLine i, CStr(i) & ":" & newLine
End If
End If
End If
Next i
.CodePane.Window.Visible = True
End With
End Sub
Sub RemoveLineNumbers(wbName As String, vbCompName As String)
'See MakeUF
Dim i As Long
With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule
For i = 1 To .CountOfLines
.ReplaceLine i, RemoveOneLineNumber(.Lines(i, 1))
Next i
End With
End Sub
Function RemoveOneLineNumber(aString)
RemoveOneLineNumber = aString
If aString Like "#:*" Or aString Like "##:*" Or aString Like "###:*" Then
RemoveOneLineNumber = Mid(aString, 1 + InStr(1, aString, ":", vbTextCompare))
End If
End Function
Function HasLabel(ByVal aString As String) As Boolean
HasLabel = InStr(1, aString & ":", ":") < InStr(1, aString & " ", " ")
End Function
You'll have to modify it to suit your needs since you're working in Access, but I'm sure the main meat of it still applies. In Excel, there's a userform that is used to kick off the code for the module you specify, but you should be able to just pass in the module name (vbCompName) to specify the module. I'm not well-versed in Access VBA, so I'm not sure what you'd replace Workbooks(wbName) with in the code.
The VBA editor has a built in way to see a line number, under the 'Standard' toolbar:
When you select a line of code, the line number will be represented here next to 'Ln'.
MZ-Tools for VBA has functions to add and remove line numbers to single functions, modules, or the whole project.
See http://www.mztools.com/v8/onlinehelp/index.html?add_remove_line_numbers.htm
Note 1: I find it better to configure the line number increment to 1 instead of 10. You will never manually add line numbers inbetween - whenever you edit the code, you first remove the line numbers, then add them back when you are finished.
Note 2: Until a few years ago, there was a free version 3.0 of MZ-Tools, but it is surprisingly difficult to find a copy. But it is a good investment - there are lots of other useful features (e.g. the automatic adding of error handlers).
The answer of Arich works like a charm on an individual module. If you want to provide your entire workbook with (updated) line numbers you apply the following steps*^:
Do Once:
Paste the large code from Module2 in your workbook.
Paste the code for Module3 in your workbook.
Paste the code for Module4 in your workbook.
Then paste the line Global allow_for_line_addition As Stringthis is just so that you can automatically add linenumbers` above/in the first line of every
module.
Delete all empty lines at the end of each module (so no lose enters after the last end sub,end function or End Property of a module).
In the VBA editor, while not running a code, and not being in "break"-mode:click tools>references>mark: `Microsoft Visual Basic for Applications Extensibility 5.3"
Do every time you have modified your code:
°Run the code for Module3 to remove line numbers to all the modules in your workbook.
°Run the code for Module4 to add line numbers to all the modules in your workbook.
Module2:
Public Enum vbLineNumbers_LabelTypes
vbLabelColon ' 0
vbLabelTab ' 1
End Enum
Public Enum vbLineNumbers_ScopeToAddLineNumbersTo
vbScopeAllProc ' 1
vbScopeThisProc ' 2
End Enum
Sub AddLineNumbers(ByVal wbName As String, _
ByVal vbCompName As String, _
ByVal LabelType As vbLineNumbers_LabelTypes, _
ByVal AddLineNumbersToEmptyLines As Boolean, _
ByVal AddLineNumbersToEndOfProc As Boolean, _
ByVal Scope As vbLineNumbers_ScopeToAddLineNumbersTo, _
Optional ByVal thisProcName As String)
' USAGE RULES
' DO NOT MIX LABEL TYPES FOR LINE NUMBERS! IF ADDING LINE NUMBERS AS COLON TYPE, ANY LINE NUMBERS AS VBTAB TYPE MUST BE REMOVE BEFORE, AND RECIPROCALLY ADDING LINE NUMBERS AS VBTAB TYPE
Dim i As Long
Dim j As Long
Dim procName As String
Dim startOfProcedure As Long
Dim lengthOfProcedure As Long
Dim endOfProcedure As Long
Dim strLine As String
With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule
.CodePane.Window.Visible = False
If Scope = vbScopeAllProc Then
For i = 1 To .CountOfLines - 1
strLine = .Lines(i, 1)
procName = .ProcOfLine(i, vbext_pk_Proc) ' Type d'argument ByRef incompatible ~~> Requires VBIDE library as a Reference for the VBA Project
If procName <> vbNullString Then
startOfProcedure = .ProcStartLine(procName, vbext_pk_Proc)
bodyOfProcedure = .ProcBodyLine(procName, vbext_pk_Proc)
countOfProcedure = .ProcCountLines(procName, vbext_pk_Proc)
prelinesOfProcedure = bodyOfProcedure - startOfProcedure
'postlineOfProcedure = ??? not directly available since endOfProcedure is itself not directly available.
lengthOfProcedure = countOfProcedure - prelinesOfProcedure ' includes postlinesOfProcedure !
'endOfProcedure = ??? not directly available, each line of the proc must be tested until the End statement is reached. See below.
If endOfProcedure <> 0 And startOfProcedure < endOfProcedure And i > endOfProcedure Then
GoTo NextLine
End If
If i = bodyOfProcedure Then inprocbodylines = True
If bodyOfProcedure < i And i < startOfProcedure + countOfProcedure Then
If Not (.Lines(i - 1, 1) Like "* _") Then
inprocbodylines = False
PreviousIndentAdded = 0
If Trim(strLine) = "" And Not AddLineNumbersToEmptyLines Then GoTo NextLine
If IsProcEndLine(wbName, vbCompName, i) Then
endOfProcedure = i
If AddLineNumbersToEndOfProc Then
Call IndentProcBodyLinesAsProcEndLine(wbName, vbCompName, LabelType, endOfProcedure)
Else
GoTo NextLine
End If
End If
If LabelType = vbLabelColon Then
If HasLabel(strLine, vbLabelColon) Then strLine = RemoveOneLineNumber(.Lines(i, 1), vbLabelColon)
If Not HasLabel(strLine, vbLabelColon) Then
temp_strLine = strLine
.ReplaceLine i, CStr(i) & ":" & strLine
new_strLine = .Lines(i, 1)
If Len(new_strLine) = Len(CStr(i) & ":" & temp_strLine) Then
PreviousIndentAdded = Len(CStr(i) & ":")
Else
PreviousIndentAdded = Len(CStr(i) & ": ")
End If
End If
ElseIf LabelType = vbLabelTab Then
If Not HasLabel(strLine, vbLabelTab) Then strLine = RemoveOneLineNumber(.Lines(i, 1), vbLabelTab)
If Not HasLabel(strLine, vbLabelColon) Then
temp_strLine = strLine
.ReplaceLine i, CStr(i) & vbTab & strLine
PreviousIndentAdded = Len(strLine) - Len(temp_strLine)
End If
End If
Else
If Not inprocbodylines Then
If LabelType = vbLabelColon Then
.ReplaceLine i, Space(PreviousIndentAdded) & strLine
ElseIf LabelType = vbLabelTab Then
.ReplaceLine i, Space(4) & strLine
End If
Else
End If
End If
End If
End If
NextLine:
Next i
ElseIf AddLineNumbersToEmptyLines And Scope = vbScopeThisProc Then
End If
.CodePane.Window.Visible = True
End With
End Sub
Function IsProcEndLine(ByVal wbName As String, _
ByVal vbCompName As String, _
ByVal Line As Long) As Boolean
With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule
If Trim(.Lines(Line, 1)) Like "End Sub*" _
Or Trim(.Lines(Line, 1)) Like "End Function*" _
Or Trim(.Lines(Line, 1)) Like "End Property*" _
Then IsProcEndLine = True
End With
End Function
Sub IndentProcBodyLinesAsProcEndLine(ByVal wbName As String, ByVal vbCompName As String, ByVal LabelType As vbLineNumbers_LabelTypes, ByVal ProcEndLine As Long)
Dim procName As String
Dim startOfProcedure As Long
Dim endOfProcedure As Long
With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule
procName = .ProcOfLine(ProcEndLine, vbext_pk_Proc)
bodyOfProcedure = .ProcBodyLine(procName, vbext_pk_Proc)
endOfProcedure = ProcEndLine
strEnd = .Lines(endOfProcedure, 1)
j = bodyOfProcedure
Do Until Not .Lines(j - 1, 1) Like "* _" And j <> bodyOfProcedure
strLine = .Lines(j, 1)
If LabelType = vbLabelColon Then
If Mid(strEnd, Len(CStr(endOfProcedure)) + 1 + 1 + 1, 1) = " " Then
.ReplaceLine j, Space(Len(CStr(endOfProcedure)) + 1) & strLine
Else
.ReplaceLine j, Space(Len(CStr(endOfProcedure)) + 2) & strLine
End If
ElseIf LabelType = vbLabelTab Then
If endOfProcedure < 1000 Then
.ReplaceLine j, Space(4) & strLine
Else
Debug.Print "This tool is limited to 999 lines of code to work properly."
End If
End If
j = j + 1
Loop
End With
End Sub
Sub RemoveLineNumbers(ByVal wbName As String, ByVal vbCompName As String, ByVal LabelType As vbLineNumbers_LabelTypes)
Dim i As Long
With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule
'MsgBox ("nr of lines = " & .CountOfLines & vbNewLine & "Procname = " & procName)
'MsgBox ("nr of lines REMEMBER MUST BE LARGER THAN 7! = " & .CountOfLines)
For i = 1 To .CountOfLines
procName = .ProcOfLine(i, vbext_pk_Proc)
If procName <> vbNullString Then
If i > 1 Then
'MsgBox ("Line " & i & " is a body line " & .ProcBodyLine(procName, vbext_pk_Proc))
If i = .ProcBodyLine(procName, vbext_pk_Proc) Then inprocbodylines = True
If .Lines(i - 1, 1) <> "" Then
'MsgBox (.Lines(i - 1, 1))
End If
If Not .Lines(i - 1, 1) Like "* _" Then
'MsgBox (inprocbodylines)
inprocbodylines = False
'MsgBox ("recoginized a line that should be substituted: " & i)
'MsgBox ("about to replace " & .Lines(i, 1) & vbNewLine & " with: " & RemoveOneLineNumber(.Lines(i, 1), LabelType) & vbNewLine & " with label type: " & LabelType)
.ReplaceLine i, RemoveOneLineNumber(.Lines(i, 1), LabelType)
Else
If IsInProcBodyLines Then
' do nothing
'MsgBox (i)
Else
.ReplaceLine i, Mid(.Lines(i, 1), RemovedChars_previous_i + 1)
End If
End If
End If
Else
' GoTo NextLine
End If
NextLine:
Next i
End With
End Sub
Function RemoveOneLineNumber(ByVal aString As String, ByVal LabelType As vbLineNumbers_LabelTypes)
RemoveOneLineNumber = aString
If LabelType = vbLabelColon Then
If aString Like "#:*" Or aString Like "##:*" Or aString Like "###:*" Or aString Like "####:*" Then
RemoveOneLineNumber = Mid(aString, 1 + InStr(1, aString, ":", vbTextCompare))
If Left(RemoveOneLineNumber, 2) Like " [! ]*" Then RemoveOneLineNumber = Mid(RemoveOneLineNumber, 2)
End If
ElseIf LabelType = vbLabelTab Then
If aString Like "# *" Or aString Like "## *" Or aString Like "### *" Or aString Like "#### *" Then RemoveOneLineNumber = Mid(aString, 5)
If aString Like "#" Or aString Like "##" Or aString Like "###" Or aString Like "####" Then RemoveOneLineNumber = ""
End If
End Function
Function HasLabel(ByVal aString As String, ByVal LabelType As vbLineNumbers_LabelTypes) As Boolean
If LabelType = vbLabelColon Then HasLabel = InStr(1, aString & ":", ":") < InStr(1, aString & " ", " ")
If LabelType = vbLabelTab Then
HasLabel = Mid(aString, 1, 4) Like "# " Or Mid(aString, 1, 4) Like "## " Or Mid(aString, 1, 4) Like "### " Or Mid(aString, 1, 5) Like "#### "
End If
End Function
Function RemoveLeadingSpaces(ByVal aString As String) As String
Do Until Left(aString, 1) <> " "
aString = Mid(aString, 2)
Loop
RemoveLeadingSpaces = aString
End Function
Function WhatIsLineIndent(ByVal aString As String) As String
i = 1
Do Until Mid(aString, i, 1) <> " "
i = i + 1
Loop
WhatIsLineIndent = i
End Function
Function HowManyLeadingSpaces(ByVal aString As String) As String
HowManyLeadingSpaces = WhatIsLineIndent(aString) - 1
End Function
Module3:
Global allow_for_line_addition As String 'this is just so that you can automatically add linenumbers
Sub remove_line_numbering_all_modules()
'source: https://stackoverflow.com/questions/36791473/vba-getting-the-modules-in-workbook
'This code numbers all the modules in your .xlsm
Dim vbcomp As VBComponent
Dim modules As Collection
Set modules = New Collection
For Each vbcomp In ThisWorkbook.VBProject.VBComponents
'if normal or class module
If ((vbcomp.Type = vbext_ct_StdModule) Or (vbcomp.Type = vbext_ct_ClassModule)) Then
'V0:
RemoveLineNumbers wbName:=ThisWorkbook.name, vbCompName:=vbcomp.name, LabelType:=vbLabelColon
'V1:
'Call RemoveLineNumbers(ThisWorkbook.name, vbcomp.name)
End If
Next vbcomp
End Sub
Module4:
Global allow_for_line_addition As String 'this is just so that you can automatically add linenumbers
'This sub adds line numbers to all the modules after you have added the following line to every module
'add tools references microsoft visual basic for applications (5.3) as checked
'Source httpsstackoverflow.comquestions40731182excel-vba-how-to-turn-on-line-numbers-in-code-editor50368332#50368332
Sub add_line_numbering_all_modules()
'source: https://www.stackoverflow.com/questions/36791473/vba-getting-the-modules-in-workbook
'This code numbers all the modules in your .xlsm
Dim vbcomp As VBComponent
Dim modules As Collection
Set modules = New Collection
For Each vbcomp In ThisWorkbook.VBProject.VBComponents
'if normal or class module
If ((vbcomp.Type = vbext_ct_StdModule) Or (vbcomp.Type = vbext_ct_ClassModule)) Then
'V0:
Call AddLineNumbers(ThisWorkbook.name, vbcomp.name, vbLabelColon, True, True, vbScopeAllProc)
'v1
'Call AddLineNumbers(ThisWorkbook.name, vbcomp.name)
End If
Next vbcomp
End Sub
where you can either substitute "Book1.xlsm" with the name of your own workbook, or with thisworkbook (notice no ""), or vice versa.
*Note this worked in excel 2016, I have not tried it in 2013 yet.
^It is a modified version of Hemced's answer here., which in turn, looks a lot like Arich's answer.
°because sometimes you get an error if you cut lines out or move them around (e.g. put line 2440: above line 2303:). By removing and re-adding them, the line numbering is automatically correct again.
This Works for me...Add this to its own module. Calling the code will toggle line numbers on or off. Adding Module titles and/or procedure titles in quotes will update only the module or procedure named.
Option Compare Database
Option Explicit
Sub AddLineNumbers(Optional vbCompName As String, Optional vbCompSubName As String)
On Error Resume Next
DoCmd.Hourglass True
Application.VBE.ActiveVBProject.References.AddFromGuid "{0002E157-0000-0000-C000-000000000046}", 5, 0
Call ExecuteAddLineNumbers(vbCompName, vbCompSubName)
DoCmd.Hourglass False
End Sub
Sub ExecuteAddLineNumbers(Optional vbCompName As String, Optional vbCompSubName As String)
On Error GoTo Err_Handler
'create a reference to the Microsoft Visual Basic for Applications Extensibility library
Dim i As Long, j As Long, lineN As Long
Dim procName As String
Dim startOfProceedure As Long
Dim lengthOfProceedure As Long
Dim newLine As String
Dim objComponent As Object
Dim lineNumber As Long
Dim HasLineNumbers As Boolean
For Each objComponent In Application.VBE.ActiveVBProject.VBComponents
If (vbCompName = vbNullString Or objComponent.Name = vbCompName) And objComponent.Name <> _
Application.VBE.ActiveCodePane.CodeModule.Name) Then
Debug.Print objComponent.Name
With objComponent.CodeModule
.CodePane.Window.Visible = False
For i = 1 To .CountOfLines
'Debug.Print .ProcOfLine(i, vbext_pk_Proc)
If procName = "" And .ProcOfLine(i, vbext_pk_Proc) <> "" Then
procName = .ProcOfLine(i, vbext_pk_Proc)
'vbext_pk_Get Specifies a procedure that returns the value of a property.
'vbext_pk_Let Specifies a procedure that assigns a value to a property.
'vbext_pk_Set Specifies a procedure that sets a reference to an object.
'vbext_pk_Proc Specifies all procedures other than property procedures.
'type=vbext_ct_ClassModule
'type=vbext_ct_StdModule
'type=vbext_ct_Document
If objComponent.Type = vbext_ct_ClassModule Then
If InStr(.Lines(i + 1, 1), " Let ") > 0 Then
startOfProceedure = .ProcStartLine(procName, vbext_pk_Let)
lengthOfProceedure = .ProcCountLines(procName, vbext_pk_Let)
ElseIf InStr(.Lines(i + 1, 1), " Get ") > 0 Then
startOfProceedure = .ProcStartLine(procName, vbext_pk_Get)
lengthOfProceedure = .ProcCountLines(procName, vbext_pk_Get)
ElseIf InStr(.Lines(i + 1, 1), " Set ") > 0 Then
startOfProceedure = .ProcStartLine(procName, vbext_pk_Set)
lengthOfProceedure = .ProcCountLines(procName, vbext_pk_Set)
Else
startOfProceedure = .ProcStartLine(procName, vbext_pk_Proc)
lengthOfProceedure = .ProcCountLines(procName, vbext_pk_Proc)
End If
Else
startOfProceedure = .ProcStartLine(procName, vbext_pk_Proc)
lengthOfProceedure = .ProcCountLines(procName, vbext_pk_Proc)
End If
lineNumber = 10
HasLineNumbers = .Find("## ", startOfProceedure + 1, 1, startOfProceedure + lengthOfProceedure - 1, 1, _
False, False, True)
End If
If (vbCompSubName = vbNullString And procName <> vbNullString) Or _
(vbCompSubName <> vbNullString And procName = vbCompSubName) Then
If startOfProceedure + 1 < i And i < startOfProceedure + lengthOfProceedure - 1 Then
newLine = RemoveOneLineNumber(.Lines(i, 1), HasLineNumbers)
If Trim(newLine) <> vbNullString Then
If Not HasLabel(newLine) And Not (.Lines(i - 1, 1) Like "* _") Then
If HasLineNumbers = False Then newLine = CStr(lineNumber) & vbTab & newLine
.ReplaceLine i, newLine
lineNumber = lineNumber + 10
ElseIf Not HasLineNumbers Then
.ReplaceLine i, vbTab & newLine
Else
.ReplaceLine i, newLine
End If
End If
ElseIf i = startOfProceedure + lengthOfProceedure - 1 Then
procName = ""
End If
Else
procName = ""
End If
Next i
.CodePane.Window.Visible = True
End With
End If
Next objComponent
Exit Sub
Err_Handler:
MsgBox (Err.Number & ": " & Err.Description)
End Sub
Function RemoveOneLineNumber(aString As String, HasLineNumbers As Boolean)
Dim i As Double
RemoveOneLineNumber = aString
i = ((Len(Trim(Str(Val(aString)))) / 4) - Int(Len(Trim(Str(Val(aString)))) / 4)) * 4
If aString Like "#*" Then
RemoveOneLineNumber = Space(i) & Mid(aString, InStr(1, aString, " ", vbTextCompare))
RemoveOneLineNumber = Right(aString, Len(aString) - 4)
ElseIf HasLineNumbers And aString Like " *" Then
RemoveOneLineNumber = Right(aString, Len(aString) - 4)
End If
End Function
Function HasLabel(ByVal aString As String) As Boolean
HasLabel = False
If Right(Trim(aString), 1) = ":" Or _
Left(Trim(aString), 3) = "Dim" Or _
Left(Trim(aString), 3) = "ReDim" Or _
Left(Trim(aString), 1) = "'" Or _
Left(Trim(aString), 6) = "Option" Or _
Left(Trim(aString), 5) = "Debug" Or _
Left(Trim(aString), 3) = "Sub" Or _
Left(Trim(aString), 11) = "Private Sub" Or _
Left(Trim(aString), 10) = "Public Sub" Or _
Left(Trim(aString), 8) = "Function" Or _
Left(Trim(aString), 12) = "End Function" Or _
Left(Trim(aString), 8) = "Property" Or _
Left(Trim(aString), 12) = "End Property" Or _
Left(Trim(aString), 7) = "End Sub" Then HasLabel = True
End Function
Any decent error handler will report more than just a line number. It will report the error ode, description and the module where it happened. Regardless whether ERL is repeating line numbers throughout your app, if you can't find the problem with the other clues reported, maybe you need a sabbatical. Or, hell, add a variable that increments a module level alpha code as an adjunct to the line number like "newERL = strProcLevel & ERL" to give you "A12345" as a line number.
This is not 100% tested, but using VBA extensibility you could do the following
Sub line_number(strModuleName As String)
Dim vbProj As VBProject
Dim vbComp As VBComponent
Dim cmCode As CodeModule
Dim intLine As Integer
Set vbProj = Application.VBE.ActiveVBProject
Set vbComp = vbProj.VBComponents(strModuleName)
Set cmCode = vbComp.CodeModule
For intLine = 2 To cmCode.CountOfLines - 1
cmCode.InsertLines intLine, intLine - 1 & cmCode.Lines(intLine, 1)
cmCode.DeleteLines intLine + 1, 1
Next intLine
End Sub
This gives the results before and after as below, altering in this way is not recommended though.
Related
VBA walk through multidimensional array (dimensions limited by system only!)
Via Google I found no function that can emit a multidimensional array as structured text. VBA arrays behave somewhat bulky in this respect, if you want to iterate through a multidimensional array. Corrective suggestions, answers and / or comments are welcome. So here's my Code suggestion - For free private Use (not excessively tested!): '********************************************************************************************************** ' Helper-Function: emits a multidimensional array as structured text (c) 2018 F. Heinemann, Freiburg, Germany Function Arr2Str(ByVal aArr As Variant, Optional ByVal nLevel As Long = 0, Optional ByVal nMaxDim As Long = 0) As String Dim cRet As String Dim nI, nK As Long Dim nCount1 As Long On Error Resume Next Arr2Str = "" cRet = "" nMaxDim = MaxUboundFH(aArr) nCount1 = UboundFH(aArr, nMaxDim) If nCount1 = -1 Then Debug.Print "Error: wrong MaxDim! [" & CStr(nMaxDim) & "]" Exit Function End If For nI = LBound(aArr) To UBound(aArr) cRet = cRet & Space(nLevel) & "- " & "[" & nI & "]: " & aArr(nI) & vbCrLf If Err.Number = 0 Then GoTo NextIteration_nI End If nCount1 = UboundFH(aArr, nMaxDim) For nK = 0 To nCount1 + 1 If IsArrayFH(aArr, nI, nK) = True Then cRet = cRet & Arr2Str(aArr(nI, nK), nLevel + 1, nMaxDim - 1) Else cRet = cRet & Space(nLevel) & "- " & "[" & nI & "]: " & aArr(nI, nK) & vbCrLf End If Next nK NextIteration_nI: Next nI Arr2Str = cRet End Function Function MaxUboundFH(ByRef aArr As Variant) As Long Dim nI, nDimGet As Long MaxUboundFH = 1 On Error GoTo MaxUboundFH_Error For nI = 2 To 64 nDimGet = UBound(aArr, nI) MaxUboundFH = nI Exit Function Next nI Exit Function MaxUboundFH_Error: End Function Function UboundFH(ByRef aArr As Variant, ByVal nDim As Long) As Long Dim nDimGet As Long UboundFH = -1 On Error GoTo UboundFH_Error nDimGet = UBound(aArr, nDim) UboundFH = nDimGet Exit Function UboundFH_Error: UboundFH = -1 End Function Function IsArrayFH(ByRef aArr As Variant, ByVal nIndex1 As Long, ByVal nIndex2 As Long) As Boolean IsArrayFH = False On Error GoTo IsArrayFH_Error If IsArray(aArr(nIndex1, nIndex2)) = True Then IsArrayFH = True Exit Function End If IsArrayFH_Error: IsArrayFH = False End Function
Label VBA code with line numbers
Is there a way to quickly label VBA code with line numbers such as shown below? Sub sample() Dim i As Long 10 Debug.Print "A" 20 Debug.Print "B" 30 Debug.Print "C" 40 Debug.Print "D" 50 MsgBox "Done." End Sub
As you can see in this answer Log what line error occurs: vba, there are two ways to do that: Either manually (not fast, so doesn't answer your question) Or with some add-in, like the one mentioned in the linked answer Or write your own add-in using VBA Extensibility to do that. Edit: I never worked with VBE extensivbility library so I would suggest consulting other sources, for example here: http://www.cpearson.com/excel/vbe.aspx Repurposing code written by Chip Pearson I would try the following, although this I haven't tested it: With VBComp.CodeModule 'VBComp is VBIDE.VBComponent For N = 1 To .CountOfLines If Trim(.Lines(N, 1)) = vbNullString Then ' blank line, skip it ElseIf Left(Trim(.Lines(N, 1)), 1) = "'" Then ' comment line, skip it Else .Lines(N, 1) = N & " " & .Lines(N,1) End If Next N End With Keep in mind, that you need to make sure that you check for various cases, for example for the lines that are already numbered.
If you want to provide all the modules in your workbook with (updated) line numbers (adding and removing) you can apply the steps below*^°°. Please take this warning into account. Do Once: Paste the large code from Module2 in your workbook. Paste the code for Module3 in your workbook. Paste the code for Module4 in your workbook. Then paste the line Global allow_for_line_addition As Stringthis is just so that you can automatically add linenumbers` above/in the first line of every module. Delete all empty lines at the end of each module (so no lose enters after the last end sub,end function or End Property of a module). In the VBA editor, while not running a code, and not being in "break"-mode:click tools>references>mark: `Microsoft Visual Basic for Applications Extensibility 5.3" Do every time you have modified your code: °Run the code for Module3 to remove line numbers to all the modules in your workbook. °Run the code for Module4 to add line numbers to all the modules in your workbook. Module2: Public Enum vbLineNumbers_LabelTypes vbLabelColon ' 0 vbLabelTab ' 1 End Enum Public Enum vbLineNumbers_ScopeToAddLineNumbersTo vbScopeAllProc ' 1 vbScopeThisProc ' 2 End Enum Sub AddLineNumbers(ByVal wbName As String, _ ByVal vbCompName As String, _ ByVal LabelType As vbLineNumbers_LabelTypes, _ ByVal AddLineNumbersToEmptyLines As Boolean, _ ByVal AddLineNumbersToEndOfProc As Boolean, _ ByVal Scope As vbLineNumbers_ScopeToAddLineNumbersTo, _ Optional ByVal thisProcName As String) ' USAGE RULES ' DO NOT MIX LABEL TYPES FOR LINE NUMBERS! IF ADDING LINE NUMBERS AS COLON TYPE, ANY LINE NUMBERS AS VBTAB TYPE MUST BE REMOVE BEFORE, AND RECIPROCALLY ADDING LINE NUMBERS AS VBTAB TYPE Dim i As Long Dim j As Long Dim procName As String Dim startOfProcedure As Long Dim lengthOfProcedure As Long Dim endOfProcedure As Long Dim strLine As String With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule .CodePane.Window.Visible = False If Scope = vbScopeAllProc Then For i = 1 To .CountOfLines - 1 strLine = .Lines(i, 1) procName = .ProcOfLine(i, vbext_pk_Proc) ' Type d'argument ByRef incompatible ~~> Requires VBIDE library as a Reference for the VBA Project If procName <> vbNullString Then startOfProcedure = .ProcStartLine(procName, vbext_pk_Proc) bodyOfProcedure = .ProcBodyLine(procName, vbext_pk_Proc) countOfProcedure = .ProcCountLines(procName, vbext_pk_Proc) prelinesOfProcedure = bodyOfProcedure - startOfProcedure 'postlineOfProcedure = ??? not directly available since endOfProcedure is itself not directly available. lengthOfProcedure = countOfProcedure - prelinesOfProcedure ' includes postlinesOfProcedure ! 'endOfProcedure = ??? not directly available, each line of the proc must be tested until the End statement is reached. See below. If endOfProcedure <> 0 And startOfProcedure < endOfProcedure And i > endOfProcedure Then GoTo NextLine End If If i = bodyOfProcedure Then inprocbodylines = True If bodyOfProcedure < i And i < startOfProcedure + countOfProcedure Then If Not (.Lines(i - 1, 1) Like "* _") Then inprocbodylines = False PreviousIndentAdded = 0 If Trim(strLine) = "" And Not AddLineNumbersToEmptyLines Then GoTo NextLine If IsProcEndLine(wbName, vbCompName, i) Then endOfProcedure = i If AddLineNumbersToEndOfProc Then Call IndentProcBodyLinesAsProcEndLine(wbName, vbCompName, LabelType, endOfProcedure) Else GoTo NextLine End If End If If LabelType = vbLabelColon Then If HasLabel(strLine, vbLabelColon) Then strLine = RemoveOneLineNumber(.Lines(i, 1), vbLabelColon) If Not HasLabel(strLine, vbLabelColon) Then temp_strLine = strLine .ReplaceLine i, CStr(i) & ":" & strLine new_strLine = .Lines(i, 1) If Len(new_strLine) = Len(CStr(i) & ":" & temp_strLine) Then PreviousIndentAdded = Len(CStr(i) & ":") Else PreviousIndentAdded = Len(CStr(i) & ": ") End If End If ElseIf LabelType = vbLabelTab Then If Not HasLabel(strLine, vbLabelTab) Then strLine = RemoveOneLineNumber(.Lines(i, 1), vbLabelTab) If Not HasLabel(strLine, vbLabelColon) Then temp_strLine = strLine .ReplaceLine i, CStr(i) & vbTab & strLine PreviousIndentAdded = Len(strLine) - Len(temp_strLine) End If End If Else If Not inprocbodylines Then If LabelType = vbLabelColon Then .ReplaceLine i, Space(PreviousIndentAdded) & strLine ElseIf LabelType = vbLabelTab Then .ReplaceLine i, Space(4) & strLine End If Else End If End If End If End If NextLine: Next i ElseIf AddLineNumbersToEmptyLines And Scope = vbScopeThisProc Then End If .CodePane.Window.Visible = True End With End Sub Function IsProcEndLine(ByVal wbName As String, _ ByVal vbCompName As String, _ ByVal Line As Long) As Boolean With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule If Trim(.Lines(Line, 1)) Like "End Sub*" _ Or Trim(.Lines(Line, 1)) Like "End Function*" _ Or Trim(.Lines(Line, 1)) Like "End Property*" _ Then IsProcEndLine = True End With End Function Sub IndentProcBodyLinesAsProcEndLine(ByVal wbName As String, ByVal vbCompName As String, ByVal LabelType As vbLineNumbers_LabelTypes, ByVal ProcEndLine As Long) Dim procName As String Dim startOfProcedure As Long Dim endOfProcedure As Long With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule procName = .ProcOfLine(ProcEndLine, vbext_pk_Proc) bodyOfProcedure = .ProcBodyLine(procName, vbext_pk_Proc) endOfProcedure = ProcEndLine strEnd = .Lines(endOfProcedure, 1) j = bodyOfProcedure Do Until Not .Lines(j - 1, 1) Like "* _" And j <> bodyOfProcedure strLine = .Lines(j, 1) If LabelType = vbLabelColon Then If Mid(strEnd, Len(CStr(endOfProcedure)) + 1 + 1 + 1, 1) = " " Then .ReplaceLine j, Space(Len(CStr(endOfProcedure)) + 1) & strLine Else .ReplaceLine j, Space(Len(CStr(endOfProcedure)) + 2) & strLine End If ElseIf LabelType = vbLabelTab Then If endOfProcedure < 1000 Then .ReplaceLine j, Space(4) & strLine Else Debug.Print "This tool is limited to 999 lines of code to work properly." End If End If j = j + 1 Loop End With End Sub Sub RemoveLineNumbers(ByVal wbName As String, ByVal vbCompName As String, ByVal LabelType As vbLineNumbers_LabelTypes) Dim i As Long With Workbooks(wbName).VBProject.VBComponents(vbCompName).CodeModule 'MsgBox ("nr of lines = " & .CountOfLines & vbNewLine & "Procname = " & procName) 'MsgBox ("nr of lines REMEMBER MUST BE LARGER THAN 7! = " & .CountOfLines) For i = 1 To .CountOfLines procName = .ProcOfLine(i, vbext_pk_Proc) If procName <> vbNullString Then If i > 1 Then 'MsgBox ("Line " & i & " is a body line " & .ProcBodyLine(procName, vbext_pk_Proc)) If i = .ProcBodyLine(procName, vbext_pk_Proc) Then inprocbodylines = True If .Lines(i - 1, 1) <> "" Then 'MsgBox (.Lines(i - 1, 1)) End If If Not .Lines(i - 1, 1) Like "* _" Then 'MsgBox (inprocbodylines) inprocbodylines = False 'MsgBox ("recoginized a line that should be substituted: " & i) 'MsgBox ("about to replace " & .Lines(i, 1) & vbNewLine & " with: " & RemoveOneLineNumber(.Lines(i, 1), LabelType) & vbNewLine & " with label type: " & LabelType) .ReplaceLine i, RemoveOneLineNumber(.Lines(i, 1), LabelType) Else If IsInProcBodyLines Then ' do nothing 'MsgBox (i) Else .ReplaceLine i, Mid(.Lines(i, 1), RemovedChars_previous_i + 1) End If End If End If Else ' GoTo NextLine End If NextLine: Next i End With End Sub Function RemoveOneLineNumber(ByVal aString As String, ByVal LabelType As vbLineNumbers_LabelTypes) RemoveOneLineNumber = aString If LabelType = vbLabelColon Then If aString Like "#:*" Or aString Like "##:*" Or aString Like "###:*" Or aString Like "####:*" Then RemoveOneLineNumber = Mid(aString, 1 + InStr(1, aString, ":", vbTextCompare)) If Left(RemoveOneLineNumber, 2) Like " [! ]*" Then RemoveOneLineNumber = Mid(RemoveOneLineNumber, 2) End If ElseIf LabelType = vbLabelTab Then If aString Like "# *" Or aString Like "## *" Or aString Like "### *" Or aString Like "#### *" Then RemoveOneLineNumber = Mid(aString, 5) If aString Like "#" Or aString Like "##" Or aString Like "###" Or aString Like "####" Then RemoveOneLineNumber = "" End If End Function Function HasLabel(ByVal aString As String, ByVal LabelType As vbLineNumbers_LabelTypes) As Boolean If LabelType = vbLabelColon Then HasLabel = InStr(1, aString & ":", ":") < InStr(1, aString & " ", " ") If LabelType = vbLabelTab Then HasLabel = Mid(aString, 1, 4) Like "# " Or Mid(aString, 1, 4) Like "## " Or Mid(aString, 1, 4) Like "### " Or Mid(aString, 1, 5) Like "#### " End If End Function Function RemoveLeadingSpaces(ByVal aString As String) As String Do Until Left(aString, 1) <> " " aString = Mid(aString, 2) Loop RemoveLeadingSpaces = aString End Function Function WhatIsLineIndent(ByVal aString As String) As String i = 1 Do Until Mid(aString, i, 1) <> " " i = i + 1 Loop WhatIsLineIndent = i End Function Function HowManyLeadingSpaces(ByVal aString As String) As String HowManyLeadingSpaces = WhatIsLineIndent(aString) - 1 End Function Module3: Global allow_for_line_addition As String 'this is just so that you can automatically add linenumbers Sub remove_line_numbering_all_modules() 'source: https://stackoverflow.com/questions/36791473/vba-getting-the-modules-in-workbook 'This code numbers all the modules in your .xlsm Dim vbcomp As VBComponent Dim modules As Collection Set modules = New Collection For Each vbcomp In ThisWorkbook.VBProject.VBComponents 'if normal or class module If ((vbcomp.Type = vbext_ct_StdModule) Or (vbcomp.Type = vbext_ct_ClassModule)) Then 'V0: RemoveLineNumbers wbName:=ThisWorkbook.name, vbCompName:=vbcomp.name, LabelType:=vbLabelColon 'V1: 'Call RemoveLineNumbers(ThisWorkbook.name, vbcomp.name) End If Next vbcomp End Sub Module4: Global allow_for_line_addition As String 'this is just so that you can automatically add linenumbers 'This sub adds line numbers to all the modules after you have added the following line to every module 'add tools references microsoft visual basic for applications (5.3) as checked 'Source httpsstackoverflow.comquestions40731182excel-vba-how-to-turn-on-line-numbers-in-code-editor50368332#50368332 Sub add_line_numbering_all_modules() 'source: https://www.stackoverflow.com/questions/36791473/vba-getting-the-modules-in-workbook 'This code numbers all the modules in your .xlsm Dim vbcomp As VBComponent Dim modules As Collection Set modules = New Collection For Each vbcomp In ThisWorkbook.VBProject.VBComponents 'if normal or class module If ((vbcomp.Type = vbext_ct_StdModule) Or (vbcomp.Type = vbext_ct_ClassModule)) Then 'V0: Call AddLineNumbers(ThisWorkbook.name, vbcomp.name, vbLabelColon, True, True, vbScopeAllProc) 'v1 'Call AddLineNumbers(ThisWorkbook.name, vbcomp.name) End If Next vbcomp End Sub where you can either substitute "Book1.xlsm" with the name of your own workbook, or with thisworkbook (notice no ""), or vice versa. *Note this worked in excel 2016, I have not tried it in 2013 yet. ^It is a modified version of Hemced's answer here., which in turn, looks a lot like Arich's answer here. °because sometimes you get an error if you cut lines out or move them around (e.g. put line 2440: above line 2303:). By removing and re-adding them, the line numbering is automatically correct again. °°Tested in Excel 2016.
Crop last N lines of a string to display in userform textbox
I want to display a textlog string in a userform's textbox. Code might look like this: Dim public textlog as string sub button1_click() ' do some action textlog = textlog & event_string & vbCrLf 'event_string might exceed more than 2 line textlog = textlog & "button1 action" & vbCrLf userform1.textbox1.text = textlog end sub sub button2_click() ' do some action textlog = textlog & event_string & vbCrLf 'event_string might exceed more than 2 line textlog = textlog & "button2 action" & vbCrLf userform1.textbox1.text = textlog end sub However, the textbox should only contain 20 lines of information, while my the contents of my textlog will exceed 20 lines. How can I display only the latest (last) 20 lines of the textlog in textbox1?
You can use this function to return only the last N lines of a string, and then display that in your textbox. Note that you have to specify what the line break character is. Depending on your specific application, it could be vbCrLf, vbCr, vbLf, or even some other delimiter. Function GetLastLines(ByVal s As String, ByVal nLinesToDisplay As Long, _ Optional ByVal lineBreakChar As String = vbCrLf) 'Split the string into an array Dim splitString() As String splitString = Split(s, lineBreakChar) 'How many lines are there? Dim nLines As Long nLines = UBound(splitString) + 1 If nLines <= nLinesToDisplay Then 'No need to remove anything. Get out. GetLastLines = s Exit Function End If 'Collect last N lines in a new array Dim lastLines() As String ReDim lastLines(0 To nLinesToDisplay - 1) Dim i As Long For i = 0 To UBound(lastLines) lastLines(i) = splitString(i + nLines - nLinesToDisplay) Next i 'Join the lines array into a single string GetLastLines = Join(lastLines, lineBreakChar) End Function Example usage: MsgBox GetLastLines( _ "line 1" & vbCrLf & "line 2" & vbCrLf & "line 3" & vbCrLf _ & "line 4" & vbCrLf & "line 5" & vbCrLf & "line 6", _ 4, vbCrLf) Only the last 4 lines are displayed: Note that this assumes that your last line is not terminated by a line break. If it is, then you can tweak the code to deal with that. Alternatively, you can use Excel's built-in SUBSTITUTE function, which is useful in this particular case, because it can locate a specific instance of a given character. So instead of building arrays you can use a one-liner: Function GetLastLines2(ByVal s As String, ByVal nLinesToDisplay As Long, _ Optional ByVal lineBreakChar As String = vbCrLf) 'An arbitrary character that will never be in your input string: Dim delim As String: delim = Chr(1) 'How many lines are there? Dim nLines As Long nLines = UBound(Split(s, lineBreakChar)) + 1 If nLines <= nLinesToDisplay Then 'No need to remove anything. Get out. GetLastLines2 = s Exit Function End If 'Replace one line break with delim, split the string on it, 'return only second part: GetLastLines2 = Split( _ WorksheetFunction.Substitute( _ s, lineBreakChar, delim, nLines - nLinesToDisplay), _ delim)(1) End Function
A = "Cat" & vbcrlf & "Tiger" & vbcrlf & "Lion" & vbcrlf & "Shark hunting florida lynxs" & vbcrlf & "Leopard" & vbcrlf & "Cheetah" A= StrReverse(A) NumLines = 3 i=1 For X = 1 to NumLines i = Instr(i, A, vbcr) + 1 Next Msgbox StrReverse(Left(A, i - 1)) This is a program that cuts or leaves lines from top or bottom of files. To use Cut filter cut {t|b} {i|x} NumOfLines Cuts the number of lines from the top or bottom of file. t - top of the file b - bottom of the file i - include n lines x - exclude n lines Example cscript //nologo filter.vbs cut t i 5 < "%systemroot%\win.ini" The script Set rs = CreateObject("ADODB.Recordset") With rs .Fields.Append "LineNumber", 4 .Fields.Append "Txt", 201, 5000 .Open LineCount = 0 Do Until Inp.AtEndOfStream LineCount = LineCount + 1 .AddNew .Fields("LineNumber").value = LineCount .Fields("Txt").value = Inp.readline .UpDate Loop .Sort = "LineNumber ASC" If LCase(Arg(1)) = "t" then If LCase(Arg(2)) = "i" then .filter = "LineNumber < " & LCase(Arg(3)) + 1 ElseIf LCase(Arg(2)) = "x" then .filter = "LineNumber > " & LCase(Arg(3)) End If ElseIf LCase(Arg(1)) = "b" then If LCase(Arg(2)) = "i" then .filter = "LineNumber > " & LineCount - LCase(Arg(3)) ElseIf LCase(Arg(2)) = "x" then .filter = "LineNumber < " & LineCount - LCase(Arg(3)) + 1 End If End If Do While not .EOF Outp.writeline .Fields("Txt").Value .MoveNext Loop End With
Displaying MacroOptions
In Excel/VBA it's possible to define some informations relative to a macro or function using the function MacroOptions. Is it possible to access such information once entered via VBA ? Thank you
I've been searching for a while but I found nothing great. The only workaround I found is to use the code build by Chip Pearson and described on his website. With this code, you can get some general information about a procedure. Public Enum ProcScope ScopePrivate = 1 ScopePublic = 2 ScopeFriend = 3 ScopeDefault = 4 End Enum Public Enum LineSplits LineSplitRemove = 0 LineSplitKeep = 1 LineSplitConvert = 2 End Enum Public Type ProcInfo ProcName As String ProcKind As VBIDE.vbext_ProcKind ProcStartLine As Long ProcBodyLine As Long ProcCountLines As Long ProcScope As ProcScope ProcDeclaration As String End Type Function ProcedureInfo(ProcName As String, ProcKind As VBIDE.vbext_ProcKind, _ CodeMod As VBIDE.CodeModule) As ProcInfo Dim PInfo As ProcInfo Dim BodyLine As Long Dim Declaration As String Dim FirstLine As String BodyLine = CodeMod.ProcStartLine(ProcName, ProcKind) If BodyLine > 0 Then With CodeMod PInfo.ProcName = ProcName PInfo.ProcKind = ProcKind PInfo.ProcBodyLine = .ProcBodyLine(ProcName, ProcKind) PInfo.ProcCountLines = .ProcCountLines(ProcName, ProcKind) PInfo.ProcStartLine = .ProcStartLine(ProcName, ProcKind) FirstLine = .Lines(PInfo.ProcBodyLine, 1) If StrComp(Left(FirstLine, Len("Public")), "Public", vbBinaryCompare) = 0 Then PInfo.ProcScope = ScopePublic ElseIf StrComp(Left(FirstLine, Len("Private")), "Private", vbBinaryCompare) = 0 Then PInfo.ProcScope = ScopePrivate ElseIf StrComp(Left(FirstLine, Len("Friend")), "Friend", vbBinaryCompare) = 0 Then PInfo.ProcScope = ScopeFriend Else PInfo.ProcScope = ScopeDefault End If PInfo.ProcDeclaration = GetProcedureDeclaration(CodeMod, ProcName, ProcKind, LineSplitKeep) End With End If ProcedureInfo = PInfo End Function Public Function GetProcedureDeclaration(CodeMod As VBIDE.CodeModule, _ ProcName As String, ProcKind As VBIDE.vbext_ProcKind, _ Optional LineSplitBehavior As LineSplits = LineSplitRemove) ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' GetProcedureDeclaration ' This return the procedure declaration of ProcName in CodeMod. The LineSplitBehavior ' determines what to do with procedure declaration that span more than one line using ' the "_" line continuation character. If LineSplitBehavior is LineSplitRemove, the ' entire procedure declaration is converted to a single line of text. If ' LineSplitBehavior is LineSplitKeep the "_" characters are retained and the ' declaration is split with vbNewLine into multiple lines. If LineSplitBehavior is ' LineSplitConvert, the "_" characters are removed and replaced with vbNewLine. ' The function returns vbNullString if the procedure could not be found. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Dim LineNum As Long Dim S As String Dim Declaration As String On Error Resume Next LineNum = CodeMod.ProcBodyLine(ProcName, ProcKind) If Err.Number <> 0 Then Exit Function End If S = CodeMod.Lines(LineNum, 1) Do While Right(S, 1) = "_" Select Case True Case LineSplitBehavior = LineSplitConvert S = Left(S, Len(S) - 1) & vbNewLine Case LineSplitBehavior = LineSplitKeep S = S & vbNewLine Case LineSplitBehavior = LineSplitRemove S = Left(S, Len(S) - 1) & " " End Select Declaration = Declaration & S LineNum = LineNum + 1 S = CodeMod.Lines(LineNum, 1) Loop Declaration = SingleSpace(Declaration & S) GetProcedureDeclaration = Declaration End Function Private Function SingleSpace(ByVal Text As String) As String Dim Pos As String Pos = InStr(1, Text, Space(2), vbBinaryCompare) Do Until Pos = 0 Text = Replace(Text, Space(2), Space(1)) Pos = InStr(1, Text, Space(2), vbBinaryCompare) Loop SingleSpace = Text End Function You can call the ProcedureInfo function using code like the following: Sub ShowProcedureInfo() Dim VBProj As VBIDE.VBProject Dim VBComp As VBIDE.VBComponent Dim CodeMod As VBIDE.CodeModule Dim CompName As String Dim ProcName As String Dim ProcKind As VBIDE.vbext_ProcKind Dim PInfo As ProcInfo CompName = "modVBECode" ProcName = "ProcedureInfo" ProcKind = vbext_pk_Proc Set VBProj = ActiveWorkbook.VBProject Set VBComp = VBProj.VBComponents(CompName) Set CodeMod = VBComp.CodeModule PInfo = ProcedureInfo(ProcName, ProcKind, CodeMod) Debug.Print "ProcName: " & PInfo.ProcName Debug.Print "ProcKind: " & CStr(PInfo.ProcKind) Debug.Print "ProcStartLine: " & CStr(PInfo.ProcStartLine) Debug.Print "ProcBodyLine: " & CStr(PInfo.ProcBodyLine) Debug.Print "ProcCountLines: " & CStr(PInfo.ProcCountLines) Debug.Print "ProcScope: " & CStr(PInfo.ProcScope) Debug.Print "ProcDeclaration: " & PInfo.ProcDeclaration End Sub
Find the directory part (minus the filename) of a full path in access 97
For various reasons, I'm stuck in Access 97 and need to get only the path part of a full pathname. For example, the name c:\whatever dir\another dir\stuff.mdb should become c:\whatever dir\another dir\ This site has some suggestions on how to do it: http://www.ammara.com/access_image_faq/parse_path_filename.html But they seem rather hideous. There must be a better way, right?
You can do something simple like: Left(path, InStrRev(path, "\")) Example: Function GetDirectory(path) GetDirectory = Left(path, InStrRev(path, Application.PathSeparator)) End Function
I always used the FileSystemObject for this sort of thing. Here's a little wrapper function I used. Be sure to reference the Microsoft Scripting Runtime. Function StripFilename(sPathFile As String) As String 'given a full path and file, strip the filename off the end and return the path Dim filesystem As New FileSystemObject StripFilename = filesystem.GetParentFolderName(sPathFile) & "\" Exit Function End Function
This seems to work. The above doesn't in Excel 2010. Function StripFilename(sPathFile As String) As String 'given a full path and file, strip the filename off the end and return the path Dim filesystem As Object Set filesystem = CreateObject("Scripting.FilesystemObject") StripFilename = filesystem.GetParentFolderName(sPathFile) & "\" Exit Function End Function
If you're just needing the path of the MDB currently open in the Access UI, I'd suggest writing a function that parses CurrentDB.Name and then stores the result in a Static variable inside the function. Something like this: Public Function CurrentPath() As String Dim strCurrentDBName As String Static strPath As String Dim i As Integer If Len(strPath) = 0 Then strCurrentDBName = CurrentDb.Name For i = Len(strCurrentDBName) To 1 Step -1 If Mid(strCurrentDBName, i, 1) = "\" Then strPath = Left(strCurrentDBName, i) Exit For End If Next End If CurrentPath = strPath End Function This has the advantage that it only loops through the name one time. Of course, it only works with the file that's open in the user interface. Another way to write this would be to use the functions provided at the link inside the function above, thus: Public Function CurrentPath() As String Static strPath As String If Len(strPath) = 0 Then strPath = FolderFromPath(CurrentDB.Name) End If CurrentPath = strPath End Function This makes retrieving the current path very efficient while utilizing code that can be used for finding the path for any filename/path.
vFilename="C:\Informes\Indicadores\Program\Ind_Cont_PRv.txt" vDirFile = Replace(vFilename, Dir(vFileName, vbDirectory), "") ' Result=C:\Informes\Indicadores_Contraloria\Programa\Versiones anteriores\
left(currentdb.Name,instr(1,currentdb.Name,dir(currentdb.Name))-1) The Dir function will return only the file portion of the full path. Currentdb.Name is used here, but it could be any full path string.
If you are confident in your input parameters, you can use this single line of code which uses the native Split and Join functions and Excel native Application.pathSeparator. Split(Join(Split(strPath, "."), Application.pathSeparator), Application.pathSeparator) If you want a more extensive function, the code below is tested in Windows and should also work on Mac (though not tested). Be sure to also copy the supporting function GetPathSeparator, or modify the code to use Application.pathSeparator. Note, this is a first draft; I should really refactor it to be more concise. Private Sub ParsePath2Test() 'ParsePath2(DrivePathFileExt, -2) returns a multi-line string for debugging. Dim p As String, n As Integer Debug.Print String(2, vbCrLf) If True Then Debug.Print String(2, vbCrLf) Debug.Print ParsePath2("", -2) Debug.Print ParsePath2("C:", -2) Debug.Print ParsePath2("C:\", -2) Debug.Print ParsePath2("C:\Windows", -2) Debug.Print ParsePath2("C:\Windows\notepad.exe", -2) Debug.Print ParsePath2("C:\Windows\SysWOW64", -2) Debug.Print ParsePath2("C:\Windows\SysWOW64\", -2) Debug.Print ParsePath2("C:\Windows\SysWOW64\AcLayers.dll", -2) Debug.Print ParsePath2("C:\Windows\SysWOW64\.fakedir", -2) Debug.Print ParsePath2("C:\Windows\SysWOW64\fakefile.ext", -2) End If If True Then Debug.Print String(1, vbCrLf) Debug.Print ParsePath2("\Windows", -2) Debug.Print ParsePath2("\Windows\notepad.exe", -2) Debug.Print ParsePath2("\Windows\SysWOW64", -2) Debug.Print ParsePath2("\Windows\SysWOW64\", -2) Debug.Print ParsePath2("\Windows\SysWOW64\AcLayers.dll", -2) Debug.Print ParsePath2("\Windows\SysWOW64\.fakedir", -2) Debug.Print ParsePath2("\Windows\SysWOW64\fakefile.ext", -2) End If If True Then Debug.Print String(1, vbCrLf) Debug.Print ParsePath2("Windows\notepad.exe", -2) Debug.Print ParsePath2("Windows\SysWOW64", -2) Debug.Print ParsePath2("Windows\SysWOW64\", -2) Debug.Print ParsePath2("Windows\SysWOW64\AcLayers.dll", -2) Debug.Print ParsePath2("Windows\SysWOW64\.fakedir", -2) Debug.Print ParsePath2("Windows\SysWOW64\fakefile.ext", -2) Debug.Print ParsePath2(".fakedir", -2) Debug.Print ParsePath2("fakefile.txt", -2) Debug.Print ParsePath2("fakefile.onenote", -2) Debug.Print ParsePath2("C:\Personal\Workspace\Code\PythonVenvs\xlwings_test\.idea", -2) Debug.Print ParsePath2("Windows", -2) ' Expected to raise error 52 End If If True Then Debug.Print String(2, vbCrLf) Debug.Print "ParsePath2 ""\Windows\SysWOW64\fakefile.ext"" with different ReturnType values" Debug.Print , "{empty}", "D", ParsePath2("Windows\SysWOW64\fakefile.ext")(1) Debug.Print , "0", "D", ParsePath2("Windows\SysWOW64\fakefile.ext", 0)(1) Debug.Print , "1", "ext", ParsePath2("Windows\SysWOW64\fakefile.ext", 1) Debug.Print , "10", "file", ParsePath2("Windows\SysWOW64\fakefile.ext", 10) Debug.Print , "11", "file.ext", ParsePath2("Windows\SysWOW64\fakefile.ext", 11) Debug.Print , "100", "path", ParsePath2("Windows\SysWOW64\fakefile.ext", 100) Debug.Print , "110", "path\file", ParsePath2("Windows\SysWOW64\fakefile.ext", 110) Debug.Print , "111", "path\file.ext", ParsePath2("Windows\SysWOW64\fakefile.ext", 111) Debug.Print , "1000", "D", ParsePath2("Windows\SysWOW64\fakefile.ext", 1000) Debug.Print , "1100", "D:\path", ParsePath2("Windows\SysWOW64\fakefile.ext", 1100) Debug.Print , "1110", "D:\p\file", ParsePath2("Windows\SysWOW64\fakefile.ext", 1110) Debug.Print , "1111", "D:\p\f.ext", ParsePath2("Windows\SysWOW64\fakefile.ext", 1111) On Error GoTo EH: ' This is expected to presetn an error: p = "Windows\SysWOW64\fakefile.ext" n = 1010 Debug.Print "1010", "D:\p\file.ext", ParsePath2("Windows\SysWOW64\fakefile.ext", 1010) On Error GoTo 0 End If Exit Sub EH: Debug.Print , CStr(n), "Error: "; Err.Number, Err.Description Resume Next End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function ParsePath2(ByVal DrivePathFileExt As String _ , Optional ReturnType As Integer = 0) ' Writen by Chris Advena. You may modify and use this code provided you leave ' this credit in the code. ' Parses the input DrivePathFileExt string into individual components (drive ' letter, folders, filename and extension) and returns the portions you wish ' based on ReturnType. ' Returns either an array of strings (ReturnType = 0) or an individual string ' (all other defined ReturnType values). ' ' Parameters: ' DrivePathFileExt: The full drive letter, path, filename and extension ' ReturnType: -2 or a string up of to 4 ones with leading or lagging zeros ' (e.g., 0001) ' -2: special code for debugging use in ParsePath2Test(). ' Results in printing verbose information to the Immediate window. ' 0: default: Array(driveStr, pathStr, fileStr, extStr) ' 1: extension ' 10: filename stripped of extension ' 11: filename.extension, excluding drive and folders ' 100: folders, excluding drive letter filename and extension ' 111: folders\filename.extension, excluding drive letter ' 1000: drive leter only ' 1100: drive:\folders, excluding filename and extension ' 1110: drive:\folders\filename, excluding extension ' 1010, 0101, 1001: invalid ReturnTypes. Will result raise error 380, Value ' is not valid. Dim driveStr As String, pathStr As String Dim fileStr As String, extStr As String Dim drivePathStr As String Dim pathFileExtStr As String, fileExtStr As String Dim s As String, cnt As Integer Dim i As Integer, slashStr As String Dim dotLoc As Integer, slashLoc As Integer, colonLoc As Integer Dim extLen As Integer, fileLen As Integer, pathLen As Integer Dim errStr As String DrivePathFileExt = Trim(DrivePathFileExt) If DrivePathFileExt = "" Then fileStr = "" extStr = "" fileExtStr = "" pathStr = "" pathFileExtStr = "" drivePathStr = "" GoTo ReturnResults End If ' Determine if Dos(/) or UNIX(\) slash is used slashStr = GetPathSeparator(DrivePathFileExt) ' Find location of colon, rightmost slash and dot. ' COLON: colonLoc and driveStr colonLoc = 0 driveStr = "" If Mid(DrivePathFileExt, 2, 1) = ":" Then colonLoc = 2 driveStr = Left(DrivePathFileExt, 1) End If #If Mac Then pathFileExtStr = DrivePathFileExt #Else ' Windows pathFileExtStr = "" If Len(DrivePathFileExt) > colonLoc _ Then pathFileExtStr = Mid(DrivePathFileExt, colonLoc + 1) #End If ' SLASH: slashLoc, fileExtStr and fileStr ' Find the rightmost path separator (Win backslash or Mac Fwdslash). slashLoc = InStrRev(DrivePathFileExt, slashStr, -1, vbBinaryCompare) ' DOT: dotLoc and extStr ' Find rightmost dot. If that dot is not part of a relative reference, ' then set dotLoc. dotLoc is meant to apply to the dot before an extension, ' NOT relative path reference dots. REl ref dots appear as "." or ".." at ' the very leftmost of the path string. dotLoc = InStrRev(DrivePathFileExt, ".", -1, vbTextCompare) If Left(DrivePathFileExt, 1) = "." And dotLoc <= 2 Then dotLoc = 0 If slashLoc + 1 = dotLoc Then dotLoc = 0 If Len(extStr) = 0 And Right(pathFileExtStr, 1) <> slashStr _ Then pathFileExtStr = pathFileExtStr & slashStr End If #If Not Mac Then ' In windows, filenames cannot end with a dot ("."). If dotLoc = Len(DrivePathFileExt) Then s = "Error in FileManagementMod.ParsePath2 function. " _ & "DrivePathFileExt " & DrivePathFileExt _ & " cannot end iwth a dot ('.')." Err.Raise 52, "FileManagementMod.ParsePath2", s End If #End If ' extStr extStr = "" If dotLoc > 0 And (dotLoc < Len(DrivePathFileExt)) _ Then extStr = Mid(DrivePathFileExt, dotLoc + 1) ' fileExtStr fileExtStr = "" If slashLoc > 0 _ And slashLoc < Len(DrivePathFileExt) _ And dotLoc > slashLoc Then fileExtStr = Mid(DrivePathFileExt, slashLoc + 1) End If ' Validate the input: DrivePathFileExt s = "" #If Mac Then If InStr(1, DrivePathFileExt, ":") > 0 Then s = "DrivePathFileExt ('" & DrivePathFileExt _ & "')has invalid format. " _ & "UNIX/Mac filenames cannot contain a colon ('.')." End If #End If If Not colonLoc = 0 And slashLoc = 0 And dotLoc = 0 _ And Left(DrivePathFileExt, 1) <> slashStr _ And Left(DrivePathFileExt, 1) <> "." Then s = "DrivePathFileExt ('" & DrivePathFileExt _ & "') has invalid format. " _ & "Good example: 'C:\folder\file.txt'" ElseIf colonLoc <> 0 And colonLoc <> 2 Then ' We are on Windows and there is a colon; it can only be ' in position 2. s = "DrivePathFileExt ('" & DrivePathFileExt _ & "') has invalid format. " _ & "In the Windows operating system, " _ & "a colon (':') can only be the second character '" _ & "of a valid file path. " ElseIf Left(DrivePathFileExt, 1) = ":" _ Or InStr(3, DrivePathFileExt, ":", vbTextCompare) > 0 Then 'If path contains a drive letter, it must contain at least one slash. s = "DrivePathFileExt ('" & DrivePathFileExt _ & "') has invalid format. " _ & "Colon can only appear in the second character position." _ & slashStr & "')." ElseIf colonLoc > 0 And slashLoc = 0 _ And Len(DrivePathFileExt) > 2 Then 'If path contains a drive letter, it must contain at least one slash. s = "DrivePathFileExt ('" & DrivePathFileExt _ & "') has invalid format. " _ & "The last dot ('.') cannot be before the last file separator '" _ & slashStr & "')." ElseIf colonLoc = 2 _ And InStr(1, DrivePathFileExt, slashStr, vbTextCompare) = 0 _ And Len(DrivePathFileExt) > 2 Then ' There is a colon, but no file separator (slash). This is invalid. s = "DrivePathFileExt ('" & DrivePathFileExt _ & "') has invalid format. " _ & "If a drive letter is included, then there must be at " _ & "least one file separator character ('" & slashStr & "')." ElseIf Len(driveStr) > 0 And Len(DrivePathFileExt) > 2 And slashLoc = 0 Then ' If path contains a drive letter and is more than 2 character long ' (e.g., 'C:'), it must contain at least one slash. s = "DrivePathFileExt cannot contain a drive letter but no path separator." End If If Len(s) > 0 Then End If ' Determine if DrivePathFileExt = DrivePath ' or = Path (with no fileStr or extStr components). If Right(DrivePathFileExt, 1) = slashStr _ Or slashLoc = 0 _ Or dotLoc = 0 _ Or (dotLoc > 0 And dotLoc <= slashLoc + 1) Then ' If rightmost character is the slashStr, then no fileExt exists, just drivePath ' If no dot found, then no extension. Assume a folder is after the last slashstr, ' not a filename. ' If a dot is found (extension exists), ' If a rightmost dot appears one-char to the right of the rightmost slash ' or anywhere before (left) of that, it is not a file/ext separator. Exmaple: ' 'C:\folder1\.folder2' Then ' If no slashes, then no fileExt exists. It must just be a driveletter. ' DrivePathFileExt contains no file or ext name. fileStr = "" extStr = "" fileExtStr = "" pathStr = pathFileExtStr drivePathStr = DrivePathFileExt GoTo ReturnResults Else ' fileStr fileStr = "" If slashLoc > 0 Then If Len(extStr) = 0 Then fileStr = fileExtStr Else ' length of filename excluding dot and extension. i = Len(fileExtStr) - Len(extStr) - 1 fileStr = Left(fileExtStr, i) End If Else s = "Error in FileManagementMod.ParsePath2 function. " _ & "*** Unhandled scenario: find fileStr when slashLoc = 0. *** " Err.Raise 52, "FileManagementMod.ParsePath2", s End If ' pathStr pathStr = "" ' length of pathFileExtStr excluding fileExt. i = Len(pathFileExtStr) - Len(fileExtStr) pathStr = Left(pathFileExtStr, i) ' drivePathStr drivePathStr = "" ' length of DrivePathFileExt excluding dot and extension. i = Len(DrivePathFileExt) - Len(fileExtStr) drivePathStr = Left(DrivePathFileExt, i) End If ReturnResults: ' ReturnType uses a 4-digit binary code: dpfe = drive path file extension, ' where 1 = return in array and 0 = do not return in array ' -2, and 0 are special cases that do not follow the code. ' Note: pathstr is determined with the tailing slashstr If Len(drivePathStr) > 0 And Right(drivePathStr, 1) <> slashStr _ Then drivePathStr = drivePathStr & slashStr If Len(pathStr) > 0 And Right(pathStr, 1) <> slashStr _ Then pathStr = pathStr & slashStr #If Not Mac Then ' Including this code add a slash to the beginnning where missing. ' the downside is that it would create an absolute path where a ' sub-path of the current folder is intended. 'If colonLoc = 0 Then ' If Len(drivePathStr) > 0 And Not IsIn(Left(drivePathStr, 1), slashStr, ".") _ Then drivePathStr = slashStr & drivePathStr ' If Len(pathStr) > 0 And Not IsIn(Left(pathStr, 1), slashStr, ".") _ Then pathStr = slashStr & pathStr ' If Len(pathFileExtStr) > 0 And Not IsIn(Left(pathFileExtStr, 1), slashStr, ".") _ Then pathFileExtStr = slashStr & pathFileExtStr 'End If #End If Select Case ReturnType Case -2 ' used for ParsePath2Test() only. ParsePath2 = "DrivePathFileExt " _ & CStr(Nz(DrivePathFileExt, "{empty string}")) _ & vbCrLf & " " _ & "-------------- -----------------------------------------" _ & vbCrLf & " " & "D:\Path\ " & drivePathStr _ & vbCrLf & " " & "\path[\file.ext] " & pathFileExtStr _ & vbCrLf & " " & "\path\ " & pathStr _ & vbCrLf & " " & "file.ext " & fileExtStr _ & vbCrLf & " " & "file " & fileStr _ & vbCrLf & " " & "ext " & extStr _ & vbCrLf & " " & "D " & driveStr _ & vbCrLf & vbCrLf ' My custom debug printer prints to Immediate winodw and log file. ' Dbg.Prnt 2, ParsePath2 Debug.Print ParsePath2 Case 1 '0001: ext ParsePath2 = extStr Case 10 '0010: file ParsePath2 = fileStr Case 11 '0011: file.ext ParsePath2 = fileExtStr Case 100 '0100: path ParsePath2 = pathStr Case 110 '0110: (path, file) ParsePath2 = pathStr & fileStr Case 111 '0111: ParsePath2 = pathFileExtStr Case 1000 ParsePath2 = driveStr Case 1100 ParsePath2 = drivePathStr Case 1110 ParsePath2 = drivePathStr & fileStr Case 1111 ParsePath2 = DrivePathFileExt Case 1010, 101, 1001 s = "Error in FileManagementMod.ParsePath2 function. " _ & "Value of Paramter (ReturnType = " _ & CStr(ReturnType) & ") is not valid." Err.Raise 380, "FileManagementMod.ParsePath2", s Case Else ' default: 0 ParsePath2 = Array(driveStr, pathStr, fileStr, extStr) End Select End Function Supporting function GetPathSeparatorTest extends the native Application.pathSeparator (or bypasses when needed) to work on Mac and Win. It can also takes an optional path string and will try to determine the path separator used in the string (favoring the OS native path separator). Private Sub GetPathSeparatorTest() Dim s As String Debug.Print "GetPathSeparator(s):" Debug.Print "s not provided: ", GetPathSeparator s = "C:\folder1\folder2\file.ext" Debug.Print "s = "; s, GetPathSeparator(DrivePathFileExt:=s) s = "C:/folder1/folder2/file.ext" Debug.Print "s = "; s, GetPathSeparator(DrivePathFileExt:=s) End Sub Function GetPathSeparator(Optional DrivePathFileExt As String = "") As String ' by Chris Advena ' Finds the path separator from a string, DrivePathFileExt. ' If DrivePathFileExt is not provided, return the operating system path separator ' (Windows = backslash, Mac = forwardslash). ' Mac/Win compatible. ' Initialize Dim retStr As String: retStr = "" Dim OSSlash As String: OSSlash = "" Dim OSOppositeSlash As String: OSOppositeSlash = "" Dim PathFileExtSlash As String GetPathSeparator = "" retStr = "" ' Determine if OS expects fwd or back slash ("/" or "\"). On Error GoTo EH OSSlash = Application.pathSeparator If DrivePathFileExt = "" Then ' Input parameter DrivePathFileExt is empty, so use OS file separator. retStr = OSSlash Else ' Input parameter DrivePathFileExt provided. See if it contains / or \. ' Set OSOppositeSlash to the opposite slash the OS expects. OSOppositeSlash = "\" If OSSlash = "\" Then OSOppositeSlash = "/" ' If DrivePathFileExt does NOT contain OSSlash ' and DOES contain OSOppositeSlash, return OSOppositeSlash. ' Otherwise, assume OSSlash is correct. retStr = OSSlash If InStr(1, DrivePathFileExt, OSSlash, vbTextCompare) = 0 _ And InStr(1, DrivePathFileExt, OSOppositeSlash, vbTextCompare) > 0 Then retStr = OSOppositeSlash End If End If GetPathSeparator = retStr Exit Function EH: ' Application.PathSeparator property does not exist in Access, ' so get it the slightly less easy way. #If Mac Then ' Application.PathSeparator doesn't seem to exist in Access... OSSlash = "/" #Else OSSlash = "\" #End If Resume Next End Function Supporting function (actually commented out, so you can skip this if you don't plan to use it). Sub IsInTest() ' IsIn2 is case insensitive Dim StrToFind As String, arr As Variant arr = Array("Me", "You", "Dog", "Boo") StrToFind = "doG" Debug.Print "Is '" & CStr(StrToFind) & "' in list (expect True): " _ , IsIn(StrToFind, "Me", "You", "Dog", "Boo") StrToFind = "Porcupine" Debug.Print "Is '" & CStr(StrToFind) & "' in list (expect False): " _ , IsIn(StrToFind, "Me", "You", "Dog", "Boo") End Sub Function IsIn(ByVal StrToFind, ParamArray StringArgs() As Variant) As Boolean ' StrToFind: the string to find in the list of StringArgs() ' StringArgs: 1-dimensional array containing string values. ' Built for Strings, but actually works with other data types. Dim arr As Variant arr = StringArgs IsIn = Not IsError(Application.Match(StrToFind, arr, False)) End Function
Try this function: Function FolderPath(FilePath As String) As String '-------------------------------------------------- 'Returns the folder path form the file path. 'Written by: Christos Samaras 'Date: 06/11/2013 '-------------------------------------------------- Dim FileName As String With WorksheetFunction FileName = Mid(FilePath, .Find("*", .Substitute(FilePath, "\", "*", Len(FilePath) - _ Len(.Substitute(FilePath, "\", "")))) + 1, Len(FilePath)) End With FolderPath = Left(FilePath, Len(FilePath) - Len(FileName) - 1) End Function If you don't want to remove the last backslash "\" at the end of the folder's path, change the last line with this: FolderPath = Left(FilePath, Len(FilePath) - Len(FileName)) Example: FolderPath("C:\Users\Christos\Desktop\LAT Analysers Signal Correction\1\TP 14_03_2013_5.csv") gives: C:\Users\Christos\Desktop\LAT Analysers Signal Correction\1 or C:\Users\Christos\Desktop\LAT Analysers Signal Correction\1\ in the second case (note that there is a backslash at the end). I hope it helps...
Use these codes and enjoy it. Public Function GetDirectoryName(ByVal source As String) As String() Dim fso, oFolder, oSubfolder, oFile, queue As Collection Set fso = CreateObject("Scripting.FileSystemObject") Set queue = New Collection Dim source_file() As String Dim i As Integer queue.Add fso.GetFolder(source) 'obviously replace Do While queue.Count > 0 Set oFolder = queue(1) queue.Remove 1 'dequeue '...insert any folder processing code here... For Each oSubfolder In oFolder.SubFolders queue.Add oSubfolder 'enqueue Next oSubfolder For Each oFile In oFolder.Files '...insert any file processing code here... 'Debug.Print oFile i = i + 1 ReDim Preserve source_file(i) source_file(i) = oFile Next oFile Loop GetDirectoryName = source_file End Function And here you can call function: Sub test() Dim s For Each s In GetDirectoryName("C:\New folder") Debug.Print s Next End Sub