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.
Related
I want to export animation as mp4 in PowerPoint and get the timeline of all animation.
How do I get the delay between letters if the effect has EffectInformation.TextUnitEffect as msoAnimTextUnitEffectByCharacter?
Most documentation for PowerPoint I have read, but no message for "%delay between letters".
effectinformation documentation has no message as delay between letters in (https://learn.microsoft.com/en-us/office/vba/api/powerpoint.effectinformation.textuniteffect)
CONST ppLayoutBlank = 12 ''ppt new black slide
CONST ppSaveAsMP4 = 39 ''ppSaveFormat for mp4
CONST ForAppending = 8 ''log file write for appending
const ppViewSlideMaster = 2 ''viewtype
const ppViewHandoutMaster = 4
const ppViewTitleMaster = 8
const ppViewMasterThumbnails = 12
const msoAnimTextUnitEffectByCharacter = 1
Dim filePath
dim logFilePath
dim logFile
dim fullPath
logFilePath = ".\convert.log" '''''''logfile
filePath = SelectFile()
if len(filePath)<1 then
wscript.quit
end if
MsgBox filePath + ";"
Set ObjFSO = CreateObject("Scripting.FileSystemObject")
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
''create log file
if ObjFSO.fileExists(logFilePath) then
set logFile = ObjFSO.OpenTextFile(logFilePath, ForAppending)
else
set logFile = ObjFSO.CreateTextFile(logFilePath)
end if
''do job
pptAnimate(filePath)
''quit or not
''objPPT.Quit()
Function SelectFile()
dim selectPath,selectPathLen
Set wShell=CreateObject("WScript.Shell")
Set oExec=wShell.Exec("mshta.exe ""about:<input type=file id=FILE><script>FILE.click();new ActiveXObject('Scripting.FileSystemObject').GetStandardStream(1).WriteLine(FILE.value);close();resizeTo(0,0);</script>""")
selectPath = oExec.StdOut.ReadAll
selectPathLen = len(selectPath)
SelectFile = left(selectPath, selectPathLen-2)'''''remove \r\n, vbcr、vblf
End Function
Sub pptAnimate(pptPath)
if not (regMatch(pptPath, "\.(ppt|pptx)$")) then
exit sub
end if
Set pptInput = objPPT.Presentations.Open(pptPath)
logFile.WriteLine("slide count:" + cstr(pptInput.Slides.Count))
For i = 1 To pptInput.Slides.Count
if pptInput.Slides(i).TimeLine.MainSequence.Count > 0 then
Dim tmpPath
tmpPath = "F:\\word\\" + cstr(i) + ".pptx"
ObjFSO.CreateTextFile(tmpPath)
Set pptOutput = objPPT.Presentations.Open(tmpPath)
Set newSlide = pptOutput.Slides.Add(1, ppLayoutBlank)
pptOutput.PageSetup.slideWidth = pptInput.PageSetup.slideWidth
pptOutput.pageSetup.slideHeight = pptInput.pagesetup.slideheight
pptInput.Slides(i).Copy
pptOutput.Slides.Paste (pptOutput.Slides.Count)
logFile.WriteLine("page:" + cstr(i) + " sequence count:" + cstr(pptInput.Slides(i).TimeLine.MainSequence.Count))
For Each effect in pptInput.Slides(i).TimeLine.MainSequence
logFile.WriteLine("{delay time:" + cstr(effect.Timing.TriggerDelayTime) _
+ ", duration time:" + cstr(effect.Timing.Duration) _
+ ", Decelerate :" + cstr(effect.Timing.Decelerate) _
+ ", triggerType:" + getTriggerType(effect.Timing.TriggerType) _
+ ", Accelerate:" + cstr(effect.Timing.Accelerate) _
+ ", Decelerate:" + cstr(effect.Timing.Decelerate) _
+ ", Speed:" + cstr(effect.Timing.Speed) _
+ "}")
if msoAnimTextUnitEffectByCharacter = effect.EffectInformation.TextUnitEffect then
''I don't know how to get dealy between letters, have no way to set the effect to by graph
''effect.EffectInformation.TextUnitEffect = 0 '''readonly
end if
For Each behaviour in effect.Behaviors
logFile.WriteLine("behaviour {delay time :" + cstr(behaviour.Timing.TriggerDelayTime) + ", duration time :" + cstr(behaviour.Timing.Duration) + "}")
Next
Next
m = pptOutput.Slides.Count
pptOutput.Slides(m).Delete
''fullPath = "F:\\word\\"+cstr(i)+".mp4"
''pptOutput.SaveAs fullPath,ppSaveAsMP4
'''wait until the mp4 file exist,
'''msgbox fullPath
pptOutput.Save
pptOutput.Close
end if
Next
pptInput.Close
End Sub
Function regMatch(strng,Pattern)
Dim regEx
Set regEx = New RegExp
regEx.Pattern = Pattern
regEx.IgnoreCase = True
regEx.Global = True
regMatch = regEx.test(strng)
Set regEx = Nothing
End Function
'https://learn.microsoft.com/zh-cn/office/vba/api/powerpoint.msoanimtriggertype
Function getTriggerType(triggerType)
getTriggerType = ""
Select Case triggerType
Case 3
getTriggerType = "msoAnimTriggerAfterPrevious"
Case -1
getTriggerType = "msoAnimTriggerMixed"
Case 0
getTriggerType = "msoAnimTriggerNone"
Case 1
getTriggerType = "msoAnimTriggerOnPageClick"
Case 4
getTriggerType = "msoAnimTriggerOnShapeClick"
Case 2
getTriggerType = "msoAnimTriggerWithPrevious"
End Select
End Function
Function Format_Time(s_Time, n_Flag)
Dim y, m, d, h, mi, s
Format_Time = ""
If IsDate(s_Time) = False Then Exit Function
y = cstr(year(s_Time))
m = cstr(month(s_Time))
If len(m) = 1 Then m = "0" & m
d = cstr(day(s_Time))
If len(d) = 1 Then d = "0" & d
h = cstr(hour(s_Time))
If len(h) = 1 Then h = "0" & h
mi = cstr(minute(s_Time))
If len(mi) = 1 Then mi = "0" & mi
s = cstr(second(s_Time))
If len(s) = 1 Then s = "0" & s
Select Case n_Flag
Case 1
' yyyy-mm-dd hh:mm:ss
Format_Time = y & "-" & m & "-" & d & " "& h &":" & mi &":" & s
Case 2
' yyyy-mm-dd
Format_Time = y & "-" & m & "-" & d
Case 3
' hh:mm:ss
Format_Time = h & ":" & mi & ":" & s
Case 4
' yyyymmdd
Format_Time = y & m & d
End Select
End Function
The value for "seconds delay between letters" is not directly exposed in the object model.
While it's still possible to extract the value in VBA, the process is quite complicated. At a high level, you need to:
Use Presentation.SaveCopyAs to save a copy in "pptx" format, but with the "zip" extension, e.g. temp.zip
Use late binding to create a Shell.Application object
Use the shell object to copy temp.zip\ppt\slides\slideN.xml to a folder (N = the slide number)
Read the XML file and inspect the animation element. The exact value you are looking for ("seconds delay between letters") should be in an element like <p:tmAbs val="50"/>
The timing is in ms. So the 50 in the example would be 0.05s in the PowerPoint UI.
Because there could be many animations on the same slide, you may need to find the right animation sequence in the XML. It's definitely not an easy process, and particularly challenging to do in VBA. If possible, I would recommend that you use build a small utility exe file using C# or VB.NET to parse the XML and read the necessary information directly from the PPTX file and invoke the program from VBA. We did something similar for a different purpose, and it worked fairly well.
The first three steps can be used for extracting almost everything not available through the Object Model. For Word, you don't have to do that because it exposes a property WordOpenXML. Unfortunately, such property does not exist in Excel or PowerPoint.
For a homework project I am trying to enter characters in a single textbox as (eg:"AbC" no spaces) and have the output in a captioned label as the corresponding ASCII value written out with commas and spaces. (eg: 65, 98, 67)
Private Sub cmdCode_Click()
Dim codeInt As Integer
strInput = txtInput.value
codeInt = Asc(strInput)
lblAnswer.Caption = codeInt & ", "
End Sub
I would like the result to look like: 65, 98, 67
I'm getting no errors but only receiving "65," as my output.
Here is my solution. It assumes that the input is always going to be three (3) characters long:
Private Sub cmdCode_Click()
Dim x As String
Dim y As String
Dim z As String
strInput = txtInput.value
x = Asc(Left(strInput, 1))
y = Asc(Mid(strInput, 2, 1))
z = Asc(Right(strInput, 1))
lblAnswer.Caption = x & ", " & y & ", " & z
End Sub
This can be done for generic usage - and a little smarter:
Public Function StrToAscList( _
ByVal Text As String) _
As String
Dim Chars() As Byte
Dim Item As Integer
Dim List As String
Chars() = StrConv(Text, vbFromUnicode)
For Item = LBound(Chars) To UBound(Chars)
If Item > 0 Then List = List & ", "
List = List & CStr(Chars(Item))
Next
StrToAscList = List
End Function
Then:
Me!lblAnswer.Caption = StrToAscList(strInput)
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 get a compile error at the last line when testing the following: (Only public user defined types that are defined in a public object module can be coerced to or from a variant or passed to late-bound functions.)
Option Explicit
Public Type aType
P_Col As Integer
P_Rad As Single
P_X As Single
P_Y As Single
End Type
Function MakePatterns() As Variant
Dim i As Integer
Dim circles() As aType
For i = 1 To 5
ReDim Preserve circles(i)
circles(i).P_Col = Int(i / 2)
circles(i).P_Rad = i
circles(i).P_X = i * 10 + 1
circles(i).P_Y = i * 10 + 5
Next
For i = 1 To 5
Debug.Print circles(i).P_Col; circles(i).P_Rad; _
circles(i).P_X; circles(i).P_Y
Next
MakePatterns = circles
End Function
Is there a way to use TYPE and Function together to return an array? Or is there a more effective way?
In the code below Sub "TestCallFunction" calls the Function "MakePatterns", and after it prints the first array received back from the function in the Immediate window.
Option Explicit
Public Type aType
P_Col As Integer
P_Rad As Single
P_X As Single
P_Y As Single
End Type
Sub TestCallFunction()
Dim x() As aType
Dim i As Integer
x = MakePatterns
' print the first result received from Function MakePatterns
Debug.Print x(1).P_Col & ";" & x(1).P_Rad & ";" & x(1).P_X & ";" & x(1).P_Y
End Sub
Public Function MakePatterns() As aType()
Dim i As Integer
Dim circles() As aType
For i = 1 To 5
ReDim Preserve circles(i)
circles(i).P_Col = Int(i / 2)
circles(i).P_Rad = i
circles(i).P_X = i * 10 + 1
circles(i).P_Y = i * 10 + 5
Next
For i = 1 To 5
Debug.Print circles(i).P_Col; circles(i).P_Rad; _
circles(i).P_X; circles(i).P_Y
Next
MakePatterns = circles
End Function
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.