I have written a function to dynamically create code in VBA. When I run the function, the VBA module shows on the screen to the users and does not close after execution. Is there something I can do to not show the VBA code to the user when I run my function or a method to hide the VBA window after execution?
The code I run is:
'create textbox
Set txt = CreateControl(frm, acLabel, acDetail, "", "", x, y, w * cmToTwip, h * cmToTwip)
txt.BorderStyle = 1
txt.borderColor = borderColor
txt.BorderWidth = 3
txt.BackStyle = 0
txt.ForeColor = 0
txt.SpecialEffect = 0
txt.Vertical = True
txt.Name = "DELRectangle" & idVogn
txt.TextAlign = 1
txt.Caption = " " & text
'add onClick event
Dim mdl As Module
Set mdl = Forms(frm).Module
Dim lngReturn As Long
lngReturn = mdl.CreateEventProc("click", txt.Name)
mdl.InsertLines lngReturn + 1, "call handleClickOnWagenverfolgung(" & idVogn & ")"```
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.
I'm using OpenOffice Calc.
And I am writing macro's in OpenOffice BASIC.
I need the right code to insert a checkbox in the sheet.
I now have
Dim Doc as Object
Doc = ThisComponent
Dim cbName As Object
cbName = "checkbox_name"
Dim oCheckBoxModel as Object
// dlg is a dialog, (don't know how to create a checkbox else)
oCheckBoxModel = dlg.getmodel().createInstance( "com.sun.star.awt.UnoControlCheckBoxModel" )
oCheckBoxModel.PositionX = 100
oCheckBoxModel.PositionY = 100
oCheckBoxModel.Width = 50
oCheckBoxModel.Height = 30
oCheckBoxModel.Label = id
oCheckBoxModel.Name = cbName
oCheckBoxModel.Enabled = True
oCheckBoxModel.TabIndex = 1
Doc.Sheets().insertByName( cbName, oCheckBoxModel ) // This line is totally wrong, but I hope it's clear what I want to do
So I want to create a checkbox, and then insert it into the sheet. (In a specific cell, or just by setting a X and Y position).
I searched on the internet, but I only find information about inserting controls into a dialog, not into a sheet
To create check boxes manually, see here. To create check boxes dynamically:
Sub CreateCheckbox
oDoc = ThisComponent
oSheet = oDoc.Sheets.getByIndex(0)
oDrawPage = oSheet.DrawPage 'Was oDrawPage = oDoc.getDrawPage()
oCheckboxModel = AddNewCheckbox("Checkbox_1", "Check this box", oDoc, oDrawPage)
End Sub
Function AddNewCheckbox(sName As String, sLabel As String, _
oDoc As Object, oDrawPage As Object) As Object
oControlShape = oDoc.createInstance("com.sun.star.drawing.ControlShape")
aPoint = CreateUnoStruct("com.sun.star.awt.Point")
aSize = CreateUnoStruct("com.sun.star.awt.Size")
aPoint.X = 1000
aPoint.Y = 1000
aSize.Width = 3000
aSize.Height = 1000
oControlShape.setPosition(aPoint)
oControlShape.setSize(aSize)
oButtonModel = CreateUnoService("com.sun.star.form.component.CheckBox")
oButtonModel.Name = sName
oButtonModel.Label = sLabel
oControlShape.setControl(oButtonModel)
oDrawPage.add(oControlShape)
AddNewCheckbox = oButtonModel
End Function
This code was adapted from https://forum.openoffice.org/en/forum/viewtopic.php?f=45&t=46391.
I want to shuffle the questions in the textboxes with the answers in the checklistboxes. The problem is textboxes do shuffle but the checklistboxes doesnt.
Dim txtQ() As TextBox = {txtQ1, txtQ2, txtQ3, txtQ4, txtQ5, txtQ6, txtQ7, txtQ8, txtQ9, txtQ10}
Dim cbA() As CheckedListBox = {cbA1, cbA2, cbA3, cbA4, cbA5, cbA6, cbA7, cbA8, cbA9, cbA10}
While r.Read
If i <= 9 Then
txtQ(i).Text = r.GetString("exam_question")
cbA(i).Items.Clear()
cbA(i).Items.Add("a) " & r.GetString("exam_ans_a"))
cbA(i).Items.Add("b) " & r.GetString("exam_ans_b"))
cbA(i).Items.Add("c) " & r.GetString("exam_ans_c"))
cbA(i).Items.Add("d) " & r.GetString("exam_ans_d"))
i = i + 1
End If
End While
Dim n As Integer = i - 1
Randomize()
While i > 0
Dim j As Integer = CInt(Int(n * Rnd()))
i = i - 1
Dim tmpQ As String = txtQ(i).Text
txtQ(i).Text = txtQ(j).Text
txtQ(j).Text = tmpQ
Dim tmpA As CheckedListBox = cbA(i)
cbA(i) = cbA(j)
cbA(j) = tmpA
End While
You are using a value-type property in case of TextBoxes and a reference-type in case of CheckBoxes. You should rather swap the Text of those CheckedListBox Items to let it behave properly. Simply assigning one CheckBox Item's reference to another CheckBox Item doesn't do any good.
I'm trying to set the focus in a form after update. When I do this within the forms class module I have no problem. However, I need to do this in a few forms so I'm trying to write it in the module. My problem is I can't get the .SetFocus to work unless I hardcode the form name within the class module. WHno is the name of the control I'm trying to set focus.
I have attempted a number of options and none seem to work.
Here is the sub. Everything works wonderfully except the .SetFocus procedure.
Sub ValidateWHNO()
Dim EnteredWHNO As Integer
Dim actForm As String
Dim deWHNO As Variant
msg As Integer
Dim ctrlWHNO As Control
EnteredWHNO = Screen.ActiveControl.Value
actForm = Screen.ActiveForm.Name
Set ctrlWHNO = [Forms]![frmEnterBookData]![WHno]
deWHNO = DLookup("[WHno]", "tblDataEntry", "[WHno] = " & EnteredWHNO)
If EnteredWHNO = deWHNO Then
msg = MsgBox("You have already entered " & EnteredWHNO & " as a WHNO. The next number is " & DMax("[WHno]", "tblDataEntry") + 1 & ", use this?", 4 + 64, "Already Used WHno!")
If msg = 6 Then
Screen.ActiveControl.Value = DMax("[WHno]", "tblDataEntry") + 1
Else
Screen.ActiveControl.Value = Null
ctrlWHNO.SetFocus 'CODE THAT WONT RUN
End If
End If
End Sub
I've tried a number of other methods to set focus, such as:
Forms(actForm).WHno.SetFocus,
Forms(actForm).Controls(WHno).SetFocus, Screen.ActiveControl.SetFocus
The current result is that if No is selected in the MsgBox, the value is cleared, but the focus moves to the next control.
Thanks in advanced for any help that may be offered.
Does the following make a difference?
Sub ValidateWHNO(frm as Access.Form)
Dim EnteredWHNO As Integer
Dim actForm As String
Dim deWHNO As Variant
msg As Integer
EnteredWHNO = frm.ActiveControl.Value
actForm = frm.Name
deWHNO = DLookup("[WHno]", "tblDataEntry", "[WHno] = " & EnteredWHNO)
If EnteredWHNO = deWHNO Then
msg = MsgBox("You have already entered " & EnteredWHNO & " as a WHNO. The next number is " & DMax("[WHno]", "tblDataEntry") + 1 & ", use this?", 4 + 64, "Already Used WHno!")
If msg = 6 Then
frm.ActiveControl.Value = DMax("[WHno]", "tblDataEntry") + 1
Else
frm.ActiveControl.Value = Null
frm![WHno].SetFocus
End If
End If
End Sub
And your call from each form would be:
VaidateWHNO Me
Instead of using a relative reference to the form (Screen.ActiveForm), the code passes the form reference through directly and uses that reference as the parent of the .setFocus method.
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.