How can I pass the data generated by the EliminaAcentos function to the
URLEncode function in this script?
The first function removes diacritics and the second function URL-encodes the data.
Function EliminaAcentos(texto)
Dim i, s1, s2
s1 = "ÀÁÂÃÄÅÇÈÉÊËÌÍÎÏÒÓÔÕÖÙÚÛÜàáâãäåçèéêëìíîïòóôõöùúûü"
s2 = "AAAAAACEEEEIIIIOOOOOUUUUaaaaaaceeeeiiiiooooouuuu"
If Len(texto) <> 0 Then
For i = 1 To Len(s1)
texto = Replace(texto, Mid(s1,i,1), Mid(s2,i,1))
Next
End If
EliminaAcentos = texto
End Function
Function URLEncode(ByVal str)
Dim strTemp, strChar
Dim intPos, intASCII
strTemp = ""
strChar = ""
For intPos = 1 To Len(str)
intASCII = Asc(Mid(str, intPos, 1))
If intASCII = 32 Then
strTemp = strTemp & "+"
ElseIf ((intASCII < 123) And (intASCII > 96)) Then
strTemp = strTemp & Chr(intASCII)
ElseIf ((intASCII < 91) And (intASCII > 64)) Then
strTemp = strTemp & Chr(intASCII)
ElseIf ((intASCII < 58) And (intASCII > 47)) Then
strTemp = strTemp & Chr(intASCII)
Else
strChar = Trim(Hex(intASCII))
If intASCII < 16 Then
strTemp = strTemp & "%0" & strChar
Else
strTemp = strTemp & "%" & strChar
End If
End If
Next
URLEncode = strTemp
End Function
WScript.Echo URLEncode(WScript.Arguments(0))
Basically there are two ways to go about it:
You can nest the call of EliminaAcentos in the call of URLEncode as #JosefZ suggested:
URLEncode(EliminaAcentos(WScript.Arguments(0)))
You can embed the call of EleminaAcentos in the body of the URLEncode function:
Function URLEncode(ByVal str)
Dim strTemp, strChar
Dim intPos, intASCII
strTemp = ""
strChar = ""
str = EliminaAcentos(str)
For intPos = 1 To Len(str)
...
Next
URLEncode = strTemp
End Function
Usually you'd pick the first option if there are situations where you call URLEncode and don't want diacritics removed, or if you don't control the implementation of URLEncode. If you always want URLEncode to remove diacritics and you control the function implementation you'd pick the second option.
Side note (also mentioned by #JosefZ): pass the parameter to EliminaAcentos by value, so the function call doesn't inadvertently modify the original value.
Function EliminaAcentos(ByVal texto)
...
End Function
Related
There's a few posts on this, but none seem to provide a whole code solution, so I'm posting this up, which is culled (and credited where appropriate) from various bits and pieces of ideas on the Internet. VB6 doesn't have any function to convert from a fraction to a decimal number, which I needed for a project that I was working on which was concerned with meal recipes. I considered writing a DLL in .NET and plugging it into my application, but decided on this approach in the end. I hope this is useful for others. The solution below will do the following:
You supply a decimal number and you will be returned the fraction as a string.
You supply a fraction as a string and you will be returned with the decimal number.
In both cases, whole numbers are accounted for eg. "2 3/4" (two and three quarters) or "2.75".
I'm sure the code is not efficient, so any improvements are welcome.
Copy/Paste this as a new Class module:
Option Explicit
Private ErrorNote As String
'Properties
Public Property Get GetAsFraction(numToConvert As Double) As String
On Error GoTo GetAsFraction_Error
GetAsFraction = FncGetAsFraction(numToConvert)
On Error GoTo 0
Exit Property
GetAsFraction_Error:
ErrorNote = "Number:" & Err.number & " (" & Err.Description & ") in procedure 'GetAsFraction' in 'ClsFractionDecimal'"
MsgBox (ErrorNote)
End Property
Public Property Get GetAsDecimal(fractionString As String) As Double
On Error GoTo GetAsDecimal_Error
GetAsDecimal = FncGetAsDecimal(fractionString)
On Error GoTo 0
Exit Property
GetAsDecimal_Error:
ErrorNote = "Number:" & Err.number & " (" & Err.Description & ") in procedure 'GetAsDecimal' in 'ClsFractionDecimal'"
MsgBox (ErrorNote)
End Property
'Functions - private
Private Function FncGetAsDecimal(fractionToConvert As String) As Double
Dim result As Double
Dim wholeNumber As Integer
Dim splitStr As Variant
Dim numerator As Integer
Dim denominator As Integer
Dim fractionString As String
Dim dividedByPos As Integer
On Error GoTo FncGetAsDecimal_Error
splitStr = Split(fractionToConvert, " ")
If UBound(splitStr) = 1 Then
wholeNumber = splitStr(0)
fractionString = splitStr(1)
Else
fractionString = splitStr(0)
End If
dividedByPos = InStr(1, fractionString, "/")
numerator = Left(fractionString, dividedByPos - 1)
denominator = Mid(fractionString, dividedByPos + 1)
result = Val(numerator) / Val(denominator) + wholeNumber
FncGetAsDecimal = result
On Error GoTo 0
Exit Function
FncGetAsDecimal_Error:
ErrorNote = "Number:" & Err.number & " (" & Err.Description & ") in procedure 'FncGetAsDecimal' in 'ClsFractionDecimal'"
MsgBox (ErrorNote)
End Function
Private Function FncGetAsFraction(numToConvert As Double) As String
Dim result As String
Dim numeratorCount As Integer
Dim denominator As Single
Dim multiplierStr As String
Dim i As Integer
Dim fractionNum As Single
Dim lowestCommonDenominator As Long
Dim wholeNumber As Integer
Dim decimalPos As Integer
On Error GoTo FncGetAsFraction_Error
If numToConvert > 0 Then
decimalPos = InStr(1, CStr(numToConvert), ".")
If decimalPos > 1 Then
wholeNumber = CStr(Mid(numToConvert, 1, decimalPos - 1))
numToConvert = CStr(Mid(numToConvert, decimalPos))
End If
numeratorCount = FncCountDecimalPlaces(numToConvert)
multiplierStr = "1"
For i = 1 To numeratorCount
multiplierStr = multiplierStr & "0"
Next i
fractionNum = numToConvert * Val(multiplierStr)
denominator = 1 * Val(multiplierStr)
result = FncCrunchFraction(fractionNum, denominator)
If result = "" Then result = fractionNum & "/" & denominator
If wholeNumber <> 0 Then result = wholeNumber & " " & result
Else
result = "ERROR"
End If
FncGetAsFraction = result
On Error GoTo 0
Exit Function
FncGetAsFraction_Error:
ErrorNote = "Number:" & Err.number & " (" & Err.Description & ") in procedure 'FncGetAsFraction' in 'ClsFractionDecimal'"
MsgBox (ErrorNote)
End Function
Private Function FncCountDecimalPlaces(num As Double) As Integer
Dim result As Integer
Dim numberStr As String
Dim i As Integer
Dim decimalPointPos As Integer
On Error GoTo FncCountDecimalPlaces_Error
numberStr = CStr(num)
If Len(numberStr) > 0 Then
i = 1
Do While i <= Len(numberStr) And decimalPointPos = 0
If Mid(numberStr, i, 1) = "." Then decimalPointPos = i
i = i + 1
Loop
End If
If i > 1 Then
result = (Len(numberStr) - i + 1)
End If
FncCountDecimalPlaces = result
On Error GoTo 0
Exit Function
FncCountDecimalPlaces_Error:
ErrorNote = "Number:" & Err.number & " (" & Err.Description & ") in procedure 'FncCountDecimalPlaces' in 'ClsFractionDecimal'"
MsgBox (ErrorNote)
End Function
'Credit to:
'http://www.tek-tips.com/viewthread.cfm?qid=206890
'dsi (Programmer) - 7 Feb 02 10:38
Private Function FncCrunchFraction(num1 As Single, num2 As Single) As String
Dim num As Single
Dim dem As Single
Dim cnt1 As Integer
Dim cnt2 As Integer
Dim numFactors() As Single
Dim demFactors() As Single
Dim common As Single
Dim i As Integer
Dim j As Integer
On Error GoTo FncCrunchFraction_Error
num = num1
dem = num2
For i = 2 To Int(num / 2) Step 1
If (num Mod i = 0) Then
cnt1 = cnt1 + 1
ReDim Preserve numFactors(1 To cnt1)
numFactors(cnt1) = i
End If
Next i
cnt1 = cnt1 + 1
ReDim Preserve numFactors(1 To cnt1)
numFactors(cnt1) = num
For i = 2 To Int(dem / 2) Step 1
If (dem Mod i = 0) Then
cnt2 = cnt2 + 1
ReDim Preserve demFactors(1 To cnt2)
demFactors(cnt2) = i
End If
Next i
cnt2 = cnt2 + 1
ReDim Preserve demFactors(1 To cnt2)
demFactors(cnt2) = dem
For i = cnt1 To 1 Step -1
For j = cnt2 To 1 Step -1
If (numFactors(i) = demFactors(j)) Then
common = numFactors(i)
FncCrunchFraction = num / common & "/" & dem / common
Exit Function
End If
Next j
Next i
FncCrunchFraction = ""
On Error GoTo 0
Exit Function
FncCrunchFraction_Error:
ErrorNote = "Line:" & Erl & " Number:" & Err.number & " (" & Err.Description & ") in procedure 'FncCrunchFraction' in 'ClsFractionDecimal'"
MsgBox (ErrorNote)
End Function
Then call it with these code examples:
Public Function DecimalToFraction(number As Double) As String
Dim myFractionDecimal As New ClsFractionDecimal
DecimalToFraction = myFractionDecimal.GetAsFraction(number)
Set myFractionDecimal = Nothing
End Function
Public Function FractionToDecimal(fractionString As String) As Double
Dim myFractionDecimal As New ClsFractionDecimal
FractionToDecimal = myFractionDecimal.GetAsDecimal(fractionString)
Set myFractionDecimal = Nothing
End Function
I am not sure why but this cet = Split(strCSV, " - ") causes Run time error 5: Invalid procedure call or argument.
strCSV = Trim(cWk.Range("P" & i)): dt = CDate(CLng(cWk.Range("H" & i)))
where str = "Cap Style:Snapback - CD / Number:07 / Color:First Avenger(+S$1.50) / Box:none - Only Purchase 3 caps and above - Free Box "
Following code works perfectly on windows but it throws error on the above mentioned line
Option Explicit
Option Compare Text
Sub Get_Data()
Application.ScreenUpdating = False
Dim fName, wkB2 As Workbook, cWk As Worksheet, xWk As Worksheet, frowC As Long, i As Long, j As Long, ch As String, num As String
Dim strCSV As String, dt As Date, shtName As String, cet, temp As String, rng As Range, cel As Range, cl As String, rw As Long, toF As String
On Error GoTo Err
fName = Application.GetOpenFilename
If fName <> False Then
Set wkB2 = Workbooks.Open(fName): Set cWk = wkB2.Worksheets(1): frowC = cWk.Range("P" & Rows.Count).End(xlUp).Row
'Cap Style:Baseball - CC / Number:04 / Color:Grey(+S$2) / Box:none - Only Purchase 3 caps and above - Free Box
'Cap Style:SnapBack - CC / Number:04 / Color:Grey(+S$1.50) / Box:none - Only Purchase 3 caps and above - Free Box
For i = 2 To frowC
strCSV = Trim(cWk.Range("P" & i)): dt = CDate(CLng(cWk.Range("H" & i)))
If strCSV <> "" And IsDate(dt) Then
'ERROR cet = Split(strCSV, " - "): temp = cet(LBound(cet)): cet = Split(temp, ":"): shtName = Trim(cet(UBound(cet)))
For Each xWk In ThisWorkbook.Worksheets
If shtName = Trim(xWk.Name) Then
Set rng = xWk.Range("E3:BD3")
For Each cel In rng
If cel.Value = dt Then
cet = Split(cel.Address, "$"): cl = cet(UBound(cet) - 1): Exit For
End If
Next cel
cet = Split(strCSV, "Number:"): temp = cet(UBound(cet)): cet = Split(temp, "/"): num = Trim(cet(LBound(cet)))
cet = Split(strCSV, " / "): temp = cet(LBound(cet)): cet = Split(temp, " - "): ch = Trim(cet(UBound(cet))): ch = ch & "-" & num
Debug.Print "Ch is " & ch
Set rng = xWk.Range("A1:A" & xWk.Range("A" & Rows.Count).End(xlUp).Row)
For Each cel In rng
If cel.Value = ch Then
rw = cel.Row: Exit For
End If
Next cel
cet = Split(strCSV, "Color:"): temp = cet(UBound(cet)): cet = Split(temp, "("): toF = Trim(cet(LBound(cet)))
For j = rw To rw - 10 Step -1
If Trim(xWk.Range("B" & j)) = toF Then
rw = j: Exit For
End If
Next j
Debug.Print "Address is: " & cl & rw & " for row " & i
xWk.Range(cl & rw) = cWk.Range("O" & i)
Exit For
End If
Next xWk
End If
Next i
wkB2.Close False
Else
Exit Sub
End If
Application.ScreenUpdating = True
MsgBox "Done"
Exit Sub
Err:
MsgBox Err.Description
End Sub
Update: SplitString now handle multi-character delimiters.
We conclude that older versions of Mac Office use the equivalent of VB5. Since the Split function was introduced in VB6. An Invalid procedure call or argument is being thrown because the Split function is not available in VB5.
The workaround would be to create a custom function that works like Spli.
Split Replacement Function
Function SplitString(Text As String, Delimiter As String)
Dim arr() As String, s As String
Dim i As Long, iEnd As Long, iStart As Long, length As Long
length = Len(Delimiter)
ReDim Preserve arr(0)
iStart = 1
Do
iEnd = InStr(Mid(Text, iStart), Delimiter) - 1
If iEnd = -1 Then
ReDim Preserve arr(i)
arr(i) = Mid(Text, iStart)
Exit Do
Else
ReDim Preserve arr(i)
arr(i) = Mid(Text, iStart, iEnd)
iStart = iStart + iEnd + length
i = i + 1
End If
Loop Until iStart = 0
SplitString = arr
End Function
Here are the tests that I ran
Sub BatchTest()
Dim strCSV As String, Temp As String, Delimiter As String
Dim a
strCSV = "Cap Style Snapback - CD / Number 07 / Color First Avenger(+S$1.50) / Box none - Only Purchase 3 caps and above - Free Box"
a = SplitString(strCSV, "/")
TestSplit strCSV, " / "
TestSplit strCSV, " /"
TestSplit strCSV, "/"
TestSplit strCSV, " Color First"
End Sub
Sub TestSplit(Text As String, Delimiter As String)
Dim arr As Variant, sReplcement As String
arr = SplitString(Text, Delimiter)
sReplcement = Replace(Text, Delimiter, "|")
Debug.Print sReplcement
Debug.Print Join(arr, "|")
Debug.Print sReplcement = Join(arr, "|")
End Sub
The Results of the tests
Sub TestRegEx()
MsgBox RegexExtract("sdi 99090 dfddf sdi 5666", "(sdi \d+)", ", ") = "sdi 99090, sdi 5666"
End Sub
Function RegexExtract(ByVal text As String, _
ByVal extract_what As String, _
Optional seperator As String = "") As String
Dim i As Long, j As Long
Dim result As String
Dim allMatches As Object
Dim RE As Object
Set RE = CreateObject("vbscript.regexp")
RE.Pattern = extract_what
RE.Global = True
Set allMatches = RE.Execute(text)
For i = 0 To allMatches.count - 1
For j = 0 To allMatches.Item(i).submatches.count - 1
result = result & seperator & allMatches.Item(i).submatches.Item(j)
Next
Next
If Len(result) <> 0 Then
result = Right(result, Len(result) - Len(seperator))
End If
RegexExtract = result
End Function
why now return ....Syntax error
Can i put the Sub rutine in the function? Or better way for this?!
Function SumerizePlanArrays(f_String, f_Type)
Set dic = CreateObject("Scripting.Dictionary")
Sub Add(s)
weight = Split(s,"$")(0)
values = Split(s,"$")(1)
pipes = Split(values, "|")
For Each line In pipes
val = Split(line, ",")
if f_Type = 1 then
dic(val(1)) = (dic(val(1))*weight/100) + CInt(val(2))
elseif f_Type = 2 then
dic(val(1)) = dic(val(1)) + CInt(val(2))
end if
Next
End Sub
arrString = Split(f_String,"#")
For i = 0 to UBound(arrString)
'wei = Split(arrString(i),"$")(0)
Add arrString(i)
Next
Set a = CreateObject("System.Collections.ArrayList")
For Each key In dic.Keys
a.Add "0," & key & "," & dic(key)
Next
a.Sort
result = Join(a.ToArray, "|")
SumerizePlanArrays = result
End Function
Microsoft VBScript compilation error '800a03ea'
Syntax error
/inc_func_projects.asp, line 2592
Sub Add(s)
^
No - you can't put a sub within a function, except in JavaScript or in the server side version called JScript. VBScript and JScript are two completely different languages, however.
You should be doing this...
Function SumerizePlanArrays(f_String, f_Type)
Set dic = CreateObject("Scripting.Dictionary")
arrString = Split(f_String,"#")
For i = 0 to UBound(arrString)
'NOTE: Updated the call to reflect comment by sadrasjd...
Add arrString(i, f_Type, dic)
Next
Set a = CreateObject("System.Collections.ArrayList")
For Each key In dic.Keys
a.Add "0," & key & "," & dic(key)
Next
a.Sort
result = Join(a.ToArray, "|")
SumerizePlanArrays = result
End Function
Sub Add(s, type, dic)
'NOTE: ^Updated the parameters to reflect comment by sadrasjd^
weight = Split(s,"$")(0)
values = Split(s,"$")(1)
pipes = Split(values, "|")
For Each line In pipes
val = Split(line, ",")
if type = 1 then
dic(val(1)) = (dic(val(1))*weight/100) + CInt(val(2))
elseif type = 2 then
dic(val(1)) = dic(val(1)) + CInt(val(2))
end if
Next
End Sub
NOTE: Updated the call to reflect the suggestion made by sadrasjd.
I want to to create a full path directory, like "C:\temp1\temp2\temp2" without having to make multiple "MakeDir", for each directory.
Is this possible?
Is there any reference that I can add to my project that has this kind of function?
Thanks
You can use these functions to make the task a little easier:
Const PATH_SEPARATOR As String = "\"
'"' Creates a directory and its parent directories '''
Public Sub MakeDirectoryStructure(strDir As String)
Dim sTemp As String
If Right$(strDir, 1) = PATH_SEPARATOR Then
sTemp = Left$(strDir, Len(strDir) - 1)
Else
sTemp = strDir
End If
If Dir(strDir, vbDirectory) <> "" Then
' Already exists.'
Else
'We have to create it'
On Error Resume Next
MkDir strDir
If Err > 0 Then
' Create parent subdirectory first.'
Err.Clear
'New path'
sTemp = ExtractPath(strDir)
'Recurse'
MakeDirectoryStructure sTemp
End If
MkDir strDir
End If
End Sub
Public Function ExtractPath(strPath As String) As String
ExtractPath = MiscExtractPathName(strPath, True)
End Function
Private Function MiscExtractPathName(strPath As String, ByVal bFlag) As String
'The string is treated as if it contains '
'a path and file name. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' If bFlag = TRUE: '
' Function extracts the path from '
' the input string and returns it. '
' If bFlag = FALSE: '
' Function extracts the File name from '
' the input string and returns it. '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim lPos As Long
Dim lOldPos As Long
'Shorten the path one level'
lPos = 1
lOldPos = 1
Do
lPos = InStr(lPos, strPath, PATH_SEPARATOR)
If lPos > 0 Then
lOldPos = lPos
lPos = lPos + 1
Else
If lOldPos = 1 And Not bFlag Then
lOldPos = 0
End If
Exit Do
End If
Loop
If bFlag Then
MiscExtractPathName = Left$(strPath, lOldPos - 1)
Else
MiscExtractPathName = Mid$(strPath, lOldPos + 1)
End If
End Function ' MiscExtractPathName'
I'm not sure where I got this code.
Asked and answered before:
equivalent-of-directory-createdirectory-in-vb6
Private Declare Function MakeSureDirectoryPathExists Lib
"imagehlp.dll" (ByVal lpPath As String) As Long
Dim mF As String
mF = FolderPath
If Right(mF, 1) <> "\" Then
mF = mF & "\"
MakeSureDirectoryPathExists mF
End If
'//Create nested folders in one call
Public Function MkDirs(ByVal PathIn As String) _
As Boolean
Dim nPos As Long
MkDirs = True 'assume success
If Right$(PathIn, 1) <> "\" Then PathIn = PathIn + "\" nPos = InStr(1, PathIn, "\")
Do While nPos > 0
If Dir$(Left$(PathIn, nPos), vbDirectory) = "" Then
On Error GoTo Failed
MkDir Left$(PathIn, nPos)
On Error GoTo 0
End If
nPos = InStr(nPos + 1, PathIn, "\")
Loop
Exit Function
Failed:
MkDirs = False
End Function
Can someone post a Visual Studio macro which goes through all C# source files in a project and adds a file banner? Extra credit if it works for any type of source file (.cs, .xaml, etc).
Here you go, I provide an example for .cs and .vb but shouldn't be hard for you to adjust it to your other file type needs: Edited to recursively add header to sub-folders
Sub IterateFiles()
Dim solution As Solution = DTE.Solution
For Each prj As Project In solution.Projects
IterateProjectFiles(prj.ProjectItems)
Next
End Sub
Private Sub IterateProjectFiles(ByVal prjItms As ProjectItems)
For Each file As ProjectItem In prjItms
If file.SubProject IsNot Nothing Then
AddHeaderToItem(file)
IterateProjectFiles(file.ProjectItems)
ElseIf file.ProjectItems IsNot Nothing AndAlso file.ProjectItems.Count > 0 Then
AddHeaderToItem(file)
IterateProjectFiles(file.ProjectItems)
Else
AddHeaderToItem(file)
End If
Next
End Sub
Private Sub AddHeaderToItem(ByVal file As ProjectItem)
DTE.ExecuteCommand("View.SolutionExplorer")
If file.Name.EndsWith(".cs") OrElse file.Name.EndsWith(".vb") Then
file.Open()
file.Document.Activate()
AddHeader()
file.Document.Save()
file.Document.Close()
End If
End Sub
Private Sub AddHeader()
Dim cmtHeader As String = "{0} First Line"
Dim cmtCopyright As String = "{0} Copyright 2008"
Dim cmtFooter As String = "{0} Footer Line"
Dim cmt As String
Select Case DTE.ActiveDocument.Language
Case "CSharp"
cmt = "//"
Case "Basic"
cmt = "'"
End Select
DTE.UndoContext.Open("Header Comment")
Dim ts As TextSelection = CType(DTE.ActiveDocument.Selection, TextSelection)
ts.StartOfDocument()
ts.Text = String.Format(cmtHeader, cmt)
ts.NewLine()
ts.Text = String.Format(cmtCopyright, cmt)
ts.NewLine()
ts.Text = String.Format(cmtFooter, cmt)
ts.NewLine()
DTE.UndoContext.Close()
End Sub
Visual Studio macro to add file headers
Here is the jist of it. No, I have not debugged this, that is an excercise for the reader. And, this is done off the top of my head. (Except the File commenter...That's a real Macro that I use).
function CommentAllFiles
option explicit
Dim ActiveProjectFullName
Dim dte80 As EnvDTE80.Solution2
ActiveProjectFullName = dte80.Projects.Item(0).FullName
If ActiveProjectFullName = "" Then
MsgBox("No project loaded!")
Exit Sub
End If
Err.Number = 0
doc.Open(ActiveProjectFullName, "Text", True)
If Err.Number <> 0 Then
MsgBox("Open " + ActiveProjectFullName + " failed: " & Hex(Err.Number))
Exit Sub
End If
ActiveDocument.Goto(1, 1, vsMovementOptions.vsMovementOptionsMove)
' Build search string
Dim SearchString
Dim vsFindOptionsValue As Integer
SearchString = "^SOURCE=.*" + dn + "$"
while ActiveDocument.Selection.FindText(SearchString, vsFindOptions.vsFindOptionsFromStart + vsFindOptions.vsFindOptionsRegularExpression)
Dim TheFile
TheFile = ActiveDocument.Selection.Text
TheFile = Mid(TheFile, 8)
doc.Open(TheFile)
wend
ActiveDocument.Close()
end function
Tried and true "Flower Box" adder:
Function IsClassDef()
Dim ColNum
Dim LineNum
Dim sText
sText = ActiveDocument.Selection.ToString()
If sText = "" Then
'ActiveDocument.Selection.WordRight(dsExtend)
'sText = ActiveDocument.Selection
'sText = ucase(trim(sText))
End If
If (sText = "CLASS") Then
IsClassDef = True
Else
IsClassDef = False
End If
End Function
Sub AddCommentBlock()
'DESCRIPTION: Add Commecnt block to header, CPP files and Class Defs
AddCPPFileDesc()
End Sub
Sub AddCPPFileDesc()
'DESCRIPTION: Add File desc block to the top of a CPP file
Dim selection As EnvDTE.TextSelection
ActiveDocument.Selection.StartOfLine()
Dim editPoint As EnvDTE.EditPoint
selection = DTE.ActiveDocument.Selection()
editPoint = selection.TopPoint.CreateEditPoint()
Dim bOk, sExt, IsCpp, IsHdr, sHeader, IsCSharp
bOk = True
IsCpp = False
IsCSharp = False
If ActiveDocument.Selection.CurrentLine > 10 Then
If MsgBox("You are not at the top of the file. Are you sure you want to continue?", vbYesNo + vbDefaultButton2) = vbNo Then
bOk = False
End If
End If
If (bOk) Then
sExt = ucase(right(ActiveDocument.Name, 4))
IsCpp = sExt = ".CPP"
IsHdr = Right(sExt, 2) = ".H"
IsCSharp = sExt = ".CS"
If (IsCpp) Then
sHeader = left(ActiveDocument.Name, len(ActiveDocument.Name) - 3) + "h"
FileDescTopBlock(1)
editPoint.Insert("#include " + Chr(34) + "StdAfx.h" + Chr(34) + vbLf)
editPoint.Insert("#include " + Chr(34) + sHeader + Chr(34) + vbLf)
ElseIf (IsCSharp) Then
FileDescTopBlock(1)
Else
If IsHdr Then
'If IsCLassDef() Then
'AddClassDef()
'Else
AddHeaderFileDesc()
'End If
Else
FileDescTopBlock(1)
End If
End If
End If
End Sub
Sub AddHeaderFileDesc()
FileDescTopBlock(0)
Dim selection As EnvDTE.TextSelection
ActiveDocument.Selection.StartOfLine()
Dim editPoint As EnvDTE.EditPoint
selection = DTE.ActiveDocument.Selection()
editPoint = selection.TopPoint.CreateEditPoint()
editPoint.Insert("#pragma once" + vbLf)
End Sub
Sub FileDescTopBlock(ByVal HasRevHistory)
'DESCRIPTION: Add File desc block to the top of a CPP file
Dim selection As EnvDTE.TextSelection
ActiveDocument.Selection.StartOfLine()
ActiveDocument.Selection.EndOfLine()
Dim sComment
sComment = ActiveDocument.Selection.ToString()
If Left(sComment, 2) = "//" Then
ActiveDocument.Selection.Delete()
sComment = LTrim(Mid(sComment, 3))
Else
sComment = ""
End If
Dim sLineBreak
Dim sFileName
Dim sBlock
sLineBreak = "////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////"
sFileName = ActiveDocument.Name
ActiveDocument.Selection.StartOfDocument()
sBlock = sLineBreak & vbLf & _
"// File : " & sFileName & vbLf & _
"// Author : Larry Frieson" & vbLf & _
"// Desc : " & sComment & vbLf & _
"// Date : " & CStr(Now.Date()) & vbLf & _
"//" & vbLf & _
"// Copyright © 20" + Right(CStr(Now.Year.ToString()), 2) + " MLinks Technologies. All rights reserved" + vbLf
If (HasRevHistory > 0) Then
sBlock = sBlock & _
"//" & vbLf & _
"// Revision History: " & vbLf & _
"// " & CStr(Now) & " created." & vbLf & _
"// " & vbLf
End If
sBlock = sBlock + sLineBreak + vbLf
Dim editPoint As EnvDTE.EditPoint
selection = DTE.ActiveDocument.Selection()
editPoint = selection.TopPoint.CreateEditPoint()
editPoint.Insert(sBlock)
End Sub
Hope this helps, or at least gives you some ideas. Again, I didn't test/debug the "source file looper", I figure you can handle that.
Larry