I am developing an application in visual basic 2010, that finds the memory usage of a particular process. I came across this code:
Option Explicit
Private Sub Command1_Click()
Debug.Print GetProcessMemory("vb6.exe")
End Sub
Private Function GetProcessMemory(ByVal app_name As String) As String
Dim Process As Object
Dim dMemory As Double
For Each Process In GetObject("winmgmts:").ExecQuery("Select WorkingSetSize from Win32_Process Where Name = '" & app_name & "'")
dMemory = Process.WorkingSetSize
Next
If dMemory > 0 Then
GetProcessMemory = ResizeKb(dMemory)
Else
GetProcessMemory = "0 Bytes"
End If
End Function
Private Function ResizeKb(ByVal b As Double) As String
Dim bSize(8) As String, i As Integer
bSize(0) = "Bytes"
bSize(1) = "KB" 'Kilobytes
bSize(2) = "MB" 'Megabytes
bSize(3) = "GB" 'Gigabytes
bSize(4) = "TB" 'Terabytes
bSize(5) = "PB" 'Petabytes
bSize(6) = "EB" 'Exabytes
bSize(7) = "ZB" 'Zettabytes
bSize(8) = "YB" 'Yottabytes
For i = UBound(bSize) To 0 Step -1
If b >= (1024 ^ i) Then
ResizeKb = ThreeNonZeroDigits(b / (1024 ^ _
i)) & " " & bSize(i)
Exit For
End If
Next
End Function
Private Function ThreeNonZeroDigits(ByVal value As Double) As Double
If value >= 100 Then
ThreeNonZeroDigits = FormatNumber(value)
ElseIf value >= 10 Then
ThreeNonZeroDigits = FormatNumber(value, 1)
Else
ThreeNonZeroDigits = FormatNumber(value, 2)
End If
End Function
but this does not work in vb2010. It returns 0bytes. Please help. Alternative techniques are also appreciated.
Related
Question
I have a shape in visio 2021 , which is the "GRID" found in "Charting Shapes"
I would like to scale the smaller shapes in the master according to the ratios. Therefore I would like to bind a new instance of the class I created below to my master, and then be able to resize the master, which intern would scale the components relative to the ratios.
Code
Class name = LWR_Calc
Private Widths() As Double
Private Heights() As Double
Private W, H As Double
Private TotalWidthRatio, TotalHeightRatio
Private WidthRatioSubDivision, HeightRatioSubDivision
Private Sub Class_Initialize()
W = 1
H = 1
End Sub
Public Sub SetWidths(Lst As String, Optional delimiter As String = ",")
Dim WidthsRatioStrArr() As String
Dim Current As Double
WidthsRatioStrArr = Split(Lst, delimiter)
TotalWidthRatio = 0
ReDim Widths(0 To UBound(WidthsRatioStrArr))
For i = 0 To UBound(WidthsRatioStrArr)
Current = CDbl(WidthsRatioStrArr(i))
Widths(i) = Current
TotalWidthRatio = TotalWidthRatio + Current
Next
WidthRatioSubDivision = W / TotalWidthRatio
End Sub
Public Sub SetHeights(Lst As String, Optional delimiter As String = ",")
Dim HeightsRatioStrArr() As String
Dim Current As Double
HeightsRatioStrArr = Split(Lst, delimiter)
TotalHeightRatio = 0
ReDim Heights(0 To UBound(HeightsRatioStrArr))
For i = 0 To UBound(HeightsRatioStrArr)
Current = CDbl(HeightsRatioStrArr(i))
Heights(i) = Current
TotalHeightRatio = TotalHeightRatio + Current
Next
HeightRatioSubDivision = H / TotalHeightRatio
End Sub
Public Function GetHeight(ByVal index As Integer) As Double
On Error GoTo endr:
GetHeight = Heights(index - 1) * HeightRatioSubDivision
Exit Function
endr:
GetHeight = 0
End Function
Public Function GetWidth(ByVal index As Integer) As Double
On Error GoTo endr:
GetWidth = Widths(index - 1) * WidthRatioSubDivision
Exit Function
endr:
GetWidth = 0
End Function
Public Property Let Width(ByVal vNewValue As Double)
W = vNewValue
End Property
Public Property Let Height(ByVal vNewValue As Double)
H = vNewValue
End Property
my sub which tests the code is as follows
Private Sub Test__LWR_Calc()
Dim LWRC As LWR_Calc
Set LWRC = New LWR_Calc
LWRC.Height = 2
LWRC.Width = 10
LWRC.SetWidths ("1.75,1,1,1,1,1,1,1,1,1")
LWRC.SetHeights ("1.75,1,1,1.75,1,1,1,1,1,1")
For i = 1 To 10
For j = 1 To 10
Debug.Print i & "-" & j & " "; LWRC.GetWidth(j) & " , " & LWRC.GetHeight(i)
Next
Next
Set LWRC = Nothing
End Sub
This code works to get the values below
Data
Output
The Outputs I Get vs the Output I Want.
I have written a UDF in VBA that takes a parameter and a string and processes them to return a double. I would like to be able to use this formula to process a column of a table for a range in a sumproduct formula and I'm having some issues.
Public Function ColorCount(Color As String, ToCount As String)
Dim WordArray() As String
ToCount = Replace(ToCount, " ", "")
WordArray() = Split(ToCount, "}{")
ColorCount = 0
For i = LBound(WordArray) To UBound(WordArray)
WordArray(i) = Replace(WordArray(i), "{", "")
WordArray(i) = Replace(WordArray(i), "}", "")
If UCase(Color) = UCase(WordArray(i)) Then
ColorCount = ColorCount + 1
ElseIf UCase(WordArray(i)) Like UCase(Color) & "[/\]*" Or UCase(WordArray(i)) Like "*[/\]" & UCase(Color) Then
ColorCount = ColorCount + 0.5
End If
Next i
End Function
I have data in a table that I would like to be able to call for a sum product. I've tried something similar to =sumproduct(Table[Quant],ColorCount("Color", Table[Colors]) but it doesn't seem to work.
Any advice or help would be appreciated!
Write all the processing into the UDF. It seems a shame not to take advantage of the superior (compared to SUMPRODUCT) looping available in VBA.
Option Explicit
Public Function udfColorCount(theColor As String, toCount As Range, toQty As Range)
Dim c As Integer, i As Integer, colorString As String, colorArray As Variant
'toCount = Replace(toCount, " ", vbNullString)
udfColorCount = 0
For c = 1 To toQty.Cells.Count
Debug.Print toCount.Cells(c).Value2
colorString = Replace(toCount.Cells(c).Value2, Chr(32), vbNullString)
colorArray = Split(Mid(colorString, 2, Len(colorString) - 2), "}{")
For i = LBound(colorArray) To UBound(colorArray)
If UCase(theColor) = UCase(colorArray(i)) Then
udfColorCount = udfColorCount + toQty.Cells(c)
ElseIf CBool(InStr(1, colorArray(i), theColor, vbTextCompare)) Then
udfColorCount = udfColorCount + 0.5 * toQty.Cells(c)
End If
Next i
Next c
End Function
I have recently created a macro that uses a lot of large (like over 100 digits in decimal) numbers. To handle them, I scraped around the internet for ideas and optimized a lot of the stuff I found to meet my requirements.
However, I found a large number multiplication function that works... but seems to me as not to be too efficient.
I tried to think up my own algo from scratch, and I tried to optimize this one... but I can't seem to get it any faster.
I was trying to think of a method that wouldn't require factorOneNbr to reference LargeMult... but got nothing.
If anyone has any pointers I would appreciate it.
Thanks!
Here's the code:
Public Sub Initialize()
Static Initialized As Boolean
If Initialized Then Exit Sub
Initialized = True
cDecMax = _
CDec(Replace("79,228,162,514,264,337,593,543,950,335", ",", ""))
'this is 2^96-1
cDecMaxLen = Len(cDecMax) - 1
cSqrDecMaxLen = cDecMaxLen \ 2
End Sub
Function Ceil(x As Single) As Long
If x < 0 Then Ceil = Fix(x) Else Ceil = -Int(-x)
End Function
Function LargeMult(ByVal Nbr1 As String, ByVal Nbr2 As String) As String
Initialize
Dim negative As Boolean
negative = False
If Left(Nbr1, 1) = "-" And Left(Nbr2, 1) = "-" Then
Nbr1 = Right(Nbr1, Len(Nbr1) - 1)
Nbr2 = Right(Nbr2, Len(Nbr2) - 1)
ElseIf Left(Nbr1, 1) = "-" Then
Nbr1 = Right(Nbr1, Len(Nbr1) - 1)
negative = True
ElseIf Left(Nbr2, 1) = "-" Then
Nbr2 = Right(Nbr2, Len(Nbr2) - 1)
negative = True
End If
If Len(Nbr1) <= cSqrDecMaxLen And Len(Nbr2) <= cSqrDecMaxLen Then
LargeMult = CStr(CDec(Nbr1) * CDec(Nbr2))
If negative Then LargeMult = "-" & LargeMult
Exit Function
End If
If Len(Nbr1) > cSqrDecMaxLen Then
LargeMult = factorOneNbr(Nbr1, Nbr2)
Else
LargeMult = factorOneNbr(Nbr2, Nbr1)
End If
If negative Then LargeMult = "-" & LargeMult
End Function
Private Function factorOneNbr(ByVal LargeNbr As String, _
ByVal Nbr2 As String) As String
Dim NbrChunks As Integer, i As Integer, _
Nbr1Part As String, PowersOf10 As Integer, _
Rslt As String, FinalRslt As String
FinalRslt = "0"
NbrChunks = Ceil(Len(LargeNbr) / cSqrDecMaxLen) - 1
For i = NbrChunks To 0 Step -1
Nbr1Part = Mid(LargeNbr, i * cSqrDecMaxLen + 1, cSqrDecMaxLen)
Rslt = LargeMult(Nbr1Part, Nbr2)
FinalRslt = LargeAdd(FinalRslt, Rslt & String(PowersOf10, "0"))
PowersOf10 = PowersOf10 + Len(Nbr1Part)
Next i
factorOneNbr = FinalRslt
End Function
I have created the function below:
Option Explicit
Public Function fyi(x As Double, f As String) As String
Application.Volatile
Dim data As Double
Dim post(5)
post(1) = "Ribu "
post(2) = "Juta "
post(3) = "Milyar "
post(4) = "Trilyun "
post(5) = "Ribu Trilyun "
Dim part As String
Dim text As String
Dim cond As Boolean
Dim i As Integer
If (x < 0) Then
fyi = " "
Exit Function
End If
If (x = 0) Then
fyi = "Nol"
Exit Function
End If
If (x < 2000) Then
cond = True
End If
text = " "
If (x >= 1E+15) Then
fyi = "Nilai Terlalu Besar"
Exit Function
End If
For i = 4 To 1 Step -1
data = Int(x / (10 ^ (3 * i)))
If (data > 0) Then
part = fyis(data, cond)
text = text & part & post(i)
End If
x = x - data * (10 ^ (3 * i))
Next
text = text & fyis(x, False)
fyi = text & f
End Function
Function fyis(ByVal y As Double, ByVal conds As Boolean) As String
Dim datas As Double
Dim posts(2)
posts(1) = "Puluh"
posts(2) = "Ratus"
Dim parts As String
Dim texts As String
'Dim conds As Boolean
Dim j As Integer
Dim value(9)
value(1) = "Se"
value(2) = "Dua "
value(3) = "Tiga "
value(4) = "Empat "
value(5) = "Lima "
value(6) = "Enam "
value(7) = "Tujuh "
value(8) = "Delapan "
value(9) = "Sembilan "
texts = " "
For j = 2 To 1 Step -1
datas = Int(y / 10 ^ j)
If (datas > 0) Then
parts = value(datas)
If (j = 1 And datas = 1) Then
y = y - datas * 10 ^ j
If (y >= 1) Then
posts(j) = "belas"
Else
value(y) = "Se"
End If
texts = texts & value(y) & posts(j)
fyis = texts
Exit Function
Else
texts = texts & parts & posts(j)
End If
End If
y = y - datas * 10 ^ j
Next
If (conds = False) Then
value(1) = "Satu "
End If
texts = texts & value(y)
fyis = texts
End Function
When I return to Excel and type =fyi(500,"USD") in a cell, it returns #name.
Please inform me how to solve.
The best place for functions such as this is in an Addin...
To make an addin:
Make a new workbook
hit alt+F11
create a module, call it MyFunctions or something else meaningfull
drop your funciton in there
Once you have done all this, save your workbook as an ExcelAddin (.xlam) and close it.
Go to Excel Options (or Tools/addins) and select your addin (or go to the addins tab and click Go then find it for excel 07)
Now your funciton will always be available in every workbook without having to prefix it
If your UDF is in a workbook other than the workbook your calling from, prefix the udf with the workbook name. E.g.
=PERSONAL.XLS!fyi(500,"USD")
See this related question: Create a custom worksheet function in Excel VBA
In summary:
What you have should work.
Based on the comments to that question, you should place your user-defined function in any module other than ThisWorkbook.
Make sure that your function is in a Module, not in the Worksheet.
Check the typo: the function is fyi not fyis.
See the last line fyis = texts, it should be fyi = texts.
Is there any way, in either VBA or C# code, to get a list of the existing macros defined in a workbook?
Ideally, this list would have a method definition signatures, but just getting a list of the available macros would be great.
Is this possible?
I haven't done vba for Excel in a long time, but if I remember well, the object model for the code was inaccessible through scripting.
When you try to access it, you receive the following error.
Run-time error '1004':
Programmatic access to Visual Basic Project is not trusted
Try:
Tools | Macro | Security |Trusted Publisher Tab
[x] Trust access to Visual Basic Project
Now that you have access to the VB IDE, you could probably export the modules and make a text search in them, using vba / c#, using regular expressions to find sub and function declarations, then delete the exported modules.
I'm not sure if there is an other way to do this, but this should work.
You can take a look the following link, to get started with exporting the modules.
http://www.developersdex.com/vb/message.asp?p=2677&ID=%3C4FCD0AE9-5DCB-4A96-8B3C-F19C63CD3635%40microsoft.com%3E
This is where I got the information about giving thrusted access to the VB IDE.
Building on Martin's answer, after you trust access to the VBP, you can use this set of code to get an array of all the public subroutines in an Excel workbook's VB Project. You can modify it to only include subs, or just funcs, or just private or just public...
Private Sub TryGetArrayOfDecs()
Dim Decs() As String
DumpProcedureDecsToArray Decs
End Sub
Public Function DumpProcedureDecsToArray(ByRef Result() As String, Optional InDoc As Excel.Workbook) As Boolean
Dim VBProj As Object
Dim VBComp As Object
Dim VBMod As Object
If InDoc Is Nothing Then Set InDoc = ThisWorkbook
ReDim Result(1 To 1500, 1 To 4)
DumpProcedureDecsToArray = True
On Error GoTo PROC_ERR
Set VBProj = InDoc.VBProject
Dim FuncNum As Long
Dim FuncDec As String
For Each VBComp In VBProj.vbcomponents
Set VBMod = VBComp.CodeModule
For i = 1 To VBMod.countoflines
If IsSubroutineDeclaration(VBMod.Lines(i, 1)) Then
FuncDec = RemoveBlanksAndDecsFromSubDec(RemoveAsVariant(VBMod.Lines(i, 1)))
If LCase(Left(VBMod.Lines(i, 1), Len("private"))) <> "private" Then
FuncNum = FuncNum + 1
Result(FuncNum, 1) = FindToLeftOfString(InDoc.Name, ".") '
Result(FuncNum, 2) = VBMod.Name
Result(FuncNum, 3) = GetSubName(FuncDec)
Result(FuncNum, 4) = VBProj.Name
End If
End If
Next i
Next VBComp
PROC_END:
Exit Function
PROC_ERR:
GoTo PROC_END
End Function
Private Function RemoveCharFromLeftOfString(TheString As String, RemoveChar As String) As String
Dim Result As String
Result = TheString
While LCase(Left(Result, Len(RemoveChar))) = LCase(RemoveChar)
Result = Right(Result, Len(Result) - Len(RemoveChar))
Wend
RemoveCharFromLeftOfString = Result
End Function
Private Function RemoveBlanksAndDecsFromSubDec(TheLine As String) As String
Dim Result As String
Result = TheLine
Result = RemoveCharFromLeftOfString(Result, " ")
Result = RemoveCharFromLeftOfString(Result, " ")
Result = RemoveCharFromLeftOfString(Result, "Public ")
Result = RemoveCharFromLeftOfString(Result, "Private ")
Result = RemoveCharFromLeftOfString(Result, " ")
RemoveBlanksAndDecsFromSubDec = Result
End Function
Private Function RemoveAsVariant(TheLine As String) As String
Dim Result As String
Result = TheLine
Result = Replace(Result, "As Variant", "")
Result = Replace(Result, "As String", "")
Result = Replace(Result, "Function", "")
If InStr(1, Result, "( ") = 0 Then
Result = Replace(Result, "(", "( ")
End If
RemoveAsVariant = Result
End Function
Private Function IsSubroutineDeclaration(TheLine As String) As Boolean
If LCase(Left(RemoveBlanksAndDecsFromSubDec(TheLine), Len("Function "))) = "function " Or LCase(Left(RemoveBlanksAndDecsFromSubDec(TheLine), Len("sub "))) = "sub " Then
IsSubroutineDeclaration = True
End If
End Function
Private Function GetSubName(DecLine As String) As String
GetSubName = FindToRightOfString(FindToLeftOfString(DecLine, "("), " ")
End Function
Function FindToLeftOfString(FullString As String, ToFind As String) As String
If FullString = "" Then Exit Function
Dim Result As String, ToFindPos As Integer
ToFindPos = InStr(1, FullString, ToFind, vbTextCompare)
If ToFindPos > 0 Then
Result = Left(FullString, ToFindPos - 1)
Else
Result = FullString
End If
FindToLeftOfString = Result
End Function
Function FindToRightOfString(FullString As String, ToFind As String) As String
If FullString = "" Then Exit Function
Dim Result As String, ToFindPos As Integer
ToFindPos = InStr(1, FullString, ToFind, vbTextCompare)
Result = Right(FullString, Len(FullString) - ToFindPos + 1 - Len(ToFind))
If ToFindPos > 0 Then
FindToRightOfString = Result
Else
FindToRightOfString = FullString
End If
End Function