If I try to change it, its size is too limited
ActiveDocument.Tables(2).Cell(3, 2).Range = text + " " + String(200,".")
For example:
Sub Demo()
Const Txt As String = "abcdefghijklmnopqrstuvwxyz"
With ActiveDocument.Tables(2).Cell(3, 2)
.Range.Text = Txt + " " + String(200, ".")
.Range.FitTextWidth = .Width
End With
End Sub
Related
In my document I must add footnotes to every formula i used. For example, I have some text with added Bibliography source
(something like "some very smart text [WrittenBySb]")
and I have formula
(for examle : E = mc2)
And after that formula I must add footnote contains source. I decided to write a macro that add footnote to formula with selected bibliography source:
Sub addFootnoteFromSelection()
Selection.MoveRight Unit:=wdCell 'my formula is in table - first row
'is null. second is actual formula and
'third contains actual formula's number
Selection.MoveRight Unit:=wdCell
Selection.MoveRight Unit:=wdCell
With Selection 'i want footnote mark to be in current
'formula's number
With .FootnoteOptions
.Location = wdBottomOfPage
.NumberingRule = wdRestartContinuous
.StartingNumber = 1
.NumberStyle = wdNoteNumberStyleArabic
End With
.Footnotes.Add Range:=Selection.Range, Reference:=""
End With
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Selection.Style = ActiveDocument.Styles("Numer wzoru")
Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
End Sub
And that works, but I want to have full source name (like in bibliography field), not a citation mark.
I write a function in vba that returns proper looking and formatted string from Source field:
Function stringFromSource(curField As Source) As String
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
xmlDoc.LoadXML curField.XML
authors = "": title = "": publish = "": city = "": year = "": periodic =
""
'authors
Set surname = xmlDoc.getElementsByTagName("b:Last")
Set name = xmlDoc.getElementsByTagName("b:First")
Dim l As Integer
l = 0
For Each el In surname
If el.Text = "" Then Exit For
authors = authors + (el.Text & " " & name(l).Text & " ")
l = l + 1
Next el
'title
Set titlex = xmlDoc.getElementsByTagName("b:Title")
For Each el In titlex
If el.Text = "" Then Exit For
title = title + (el.Text & " ")
Next el
'publisher
Set pubx = xmlDoc.getElementsByTagName("b:Publisher")
For Each el In pubx
publish = publish + (el.Text & " ")
Next el
'city
Set cityx = xmlDoc.getElementsByTagName("b:City")
If cityx.Length = 0 Then city = city + ("(brak miasta)" & " ")
For Each el In cityx
city = city + (el.Text & " ")
Next el
'year
Set yearx = xmlDoc.getElementsByTagName("b:Year")
If yearx.Length = 0 Then year = year + ("(brak roku wydania)" & " ")
For Each el In yearx
year = year + (el.Text & " ")
Next el
'periodical title
Set periodx = xmlDoc.getElementsByTagName("b:PeriodicalTitle")
For Each el In period
periodic = periodic + (el.Text & " ")
Next el
Dim outputString As String
outputString = author & "- " & title & ", " & publish & periodic & ", " &
year
stringFromSource = outputString
End Function
This function works as expected. But I want to loop through all footnotes and convert it to string using my function:
Sub convertAllFootnotes()
Dim ftn As Footnote
Dim oRng As Range
For Each ftn In ActiveDocument.Footnotes
Set oRng = Selection.Range
oRng.Start = oRng.Start - 1
oRng.End = oRng.End + 1
oRng.Select
oRng.Text = stringFromSource(ftn) 'i don't know how to get source object
'from footnote
Next ftn
End Sub
And that is my problem. I don't know how to get Source object from footnote (that has Source object in it, this is not a static string but copied proper Source field)
I just joined and hope to learn all I can here and contribute where I can.
I am having major issues with the last three sections of my VBA script.
The correct, incorrect, and percentage score values are not being displayed on slides 40 & 41.
On slide 42 I cannot get the textbox or the label to display the username, date and their overall percentage score.
Any help on slide 40 would be great and I can workout the rest.
**Sub shapeTextHappySmile()**strong text**
Sub ShapeTextSadSmile()
Sub CertificateBuld()**
Option Explicit
Dim UserName As String
Dim numberCorrect As Integer
Dim numberIncorrect As Integer
Dim numberPercentage As Integer
Dim numberTotal As Integer
Private Sub CertDate()
Dim Rdate As Variant
Rdate = Date
Rdate = Format((Date), "mmmm dd, yyyy")
End Sub
Sub Initialise()
numberCorrect = 12
numberIncorrect = 8
numberPercentage = 58
numberTotal = 20
numberTotal = (numberCorrect + numberIncorrect)
numberCorrect = (numberTotal - numberIncorrect)
numberIncorrect = (numberTotal - numberCorrect)
numberPercentage = Round(numberCorrect / numberTotal) * 100
End Sub
Sub TakeQuiz()
UserName = InputBox(Prompt:="Type Your Name! ")
MsgBox "Welcome To The Academic Online Tutorial Quiz " + UserName, vbApplicationModal, " Academic Online Tutorial Quiz"
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub Correct()
numberCorrect = numberCorrect + 1
MsgBox ("Great well Done! That's the correct answer")
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub Incorrect()
numberIncorrect = numberIncorrect + 1
MsgBox ("Sorry! That was the incorrect answer")
ActivePresentation.SlideShowWindow.View.Next
End Sub
Sub shapeTextHappySmile()
ActivePresentation.Slides(40).Shapes(Label1).TextFrame.TextRange.Text = 12
'numberCorrect
ActivePresentation.Slides(40).Shapes(Label2).TextFrame.TextRange.Text = numberPercentage & "%"
MsgBox "Great Job, Well done " + "," & "Please print a copy of your completion certificate"
MsgBox "After printing or saving a copy of your certificate, you can exit the presentation"
With SlideShowWindows(1).View
.GotoSlide 42
End With
End Sub
Sub ShapeTextSadSmile()
ActivePresentation.Slides(41).Shapes("AnsweredIncorrectly").TextFrame.TextRange.Text = numberIncorrect
ActivePresentation.Slides(41).Shapes("InCorrectPercentage").TextFrame.TextRange.Text = numberPercentage & " %"
MsgBox "Your score was below 70%, in order to pass the quiz and receive a certificate of completion you need to score 70% or more."
MsgBox "Please retake the quiz, and good luck"
With SlideShowWindows(1).View
.GotoSlide 1
End With
' I will add the option of redoing the entire presentation or just the quiz.
'see slide 19 action buttons
End Sub
Sub CertificateBuld()
MsgBox "Great Job, Well done " + "," & "Plese print a copy of your completion certificate"
MsgBox "After printing or saving a copy of your certificate, please exit the presentation"
If numberCorrect >= "14" Then
ActivePresentation.Slides(42).Shapes(" ABCDEFGHIJKLMN ").TextFrame.TextRange.Text = " ABCDEFGHIJKLMN "
ActivePresentation.Slides(42).Shapes("Rdate & Percentage").TextFrame.TextRange.Text = " ON " & Rdate & " WITH A SCORE OF " & numberPercentage & " %"
ActivePresentation.Slides(42).Shapes(UserName).TextFrame.TextRange.Text = UserName
'OR
If numberCorrect <= "14" Then
ActivePresentation.Slides(42).Shapes(8).TextFrame.TextRange.Text = ABCDEFGHIJKLMN "
ActivePresentation.Slides(42).Shapes(9).TextFrame.TextRange.Text = Rdate & " ON " & Rdate & " WITH A SCORE OF " & numberPercentage & " %"
ActivePresentation.Slides(42).Shapes(10).TextFrame.TextRange.Text = UserName
Else
ActivePresentation.SlideShowWindow.View.Save
ActivePresentation.SlideShowWindow.View.Exit
End If
End Sub
See comments inline:
Sub shapeTextHappySmile()
' This won't work:
'ActivePresentation.Slides(40).Shapes(Label1).TextFrame.TextRange.Text = 12
' Shapes have names that are strings, so you need to use .Shapes("Label1")
' Assuming this is an ActiveX label, you get at its properties a bit
' differently from regular PPT shapes, starting with:
' .Shapes("Label1").OLEFormat.Object
' And for a Label ActiveX control, the property you want is .Caption
' And finally, Text/Caption properties take a String value so you want to
' put the 12 in quotes or convert a numeric value to string using Cstr(x)
' Final version:
ActivePresentation.Slides(40).Shapes("Label1").OLEFormat.Object.Caption = "12"
'numberCorrect
' And make the same changes to this one:
ActivePresentation.Slides(40).Shapes(Label2).TextFrame.TextRange.Text = numberPercentage & "%"
' MsgBox "Great Job, Well done " + "," & "Please print a copy of your completion certificate"
' and I think you probably want to do this instead of the above:
MsgBox "Great Job, Well done" & ", " & "Please print a copy of your completion certificate"
MsgBox "After printing or saving a copy of your certificate, you can exit the presentation"
With SlideShowWindows(1).View
.GotoSlide 42
End With
End Sub
I repurposed the code on MicrosoftPowerpointConverter - MoinMoin to work without the Microsoft Scripting Runtime.
I was able to generate a new file and export text to it, (I know that's the easy part), where I am getting stuck is in two places:
Formatting bullets:
Original code
' Check for bullets
If aShape.TextFrame.TextRange.ParagraphFormat.Bullet = msoTrue Then
outText = Replace(outText, Chr(10), " * ")
End If
My code
' Check for bullets
If oShape.TextFrame.TextRange.ParagraphFormat.Bullet.Type <> ppBulletNone Then
outText = Replace(outText, Chr(10), " * ")
End If
This doesn't work at all, and it totally ignores bullet formatting, but still outputs the content without the *
Exporting images:
Original Code
' Is it a picture or embedded object
If aShape.Type = msoPicture Or aShape.Type = msoEmbeddedOLEObject Or aShape.Type = msoLinkedPicture Or aShape.Type = msoGroup Then
aShape.Export outPath + "\image" + Trim(Str(i)) + Trim(Str(j)) + ".png", ppShapeFormatPNG
oFileStream.WriteLine (Chr(13) + "attachment:image" + Trim(Str(i)) + Trim(Str(j)) + ".png" + Chr(13))
End If
My code
' Is it a picture or embedded object
If oShape.Type = msoPicture Or oShape.Type = msoEmbeddedOLEObject Or oShape.Type = msoLinkedPicture Or oShape.Type = msoGroup Then
Dim imagepath
imagepath = oPres.Path & "/images/slide" + Trim(Str(i)) + Trim(Str(j)) + ".png"
oShape.Export imagepath, ppShapeFormatPNG
Print #iFile, (Chr(13) + "<img src=" + Chr(34) + "/images/slide" + Trim(Str(i)) + Trim(Str(j)) + ".png" + Chr(34) + ">" + Chr(13))
End If
This code throws up the following error in windows, and is totally ignored in Mac
Adding my complete code below:
Sub ExportToWiki()
' Iterators
Dim i As Integer
Dim j As Integer
' Pres, Slide, Shape
Dim oPres As Presentation
Dim oSlides As Slides
Dim oSlide As Slide 'Slide Object
Dim oShp As Shape 'Shape Object
Dim iFile As Integer 'File handle for output
iFile = FreeFile 'Get a free file number
Dim PathSep As String
Dim FileNum As Integer
Set oPres = ActivePresentation
Set oSlides = oPres.Slides
FileNum = FreeFile
'Open output file
' NOTE: errors here if file hasn't been saved
Open oPres.Path & "/text.xml" For Output As FileNum
' File Handling
Dim outText As String
' Table exports
Dim row As Integer
Dim col As Integer
Dim cellText As String
' Select my ppt
' Write TOC
Print #iFile, ("[[TableOfContents]]")
' Loop through slides
For i = 1 To oPres.Slides.Count
Set oSlide = oPres.Slides(i)
' Loop through shapes
For j = 1 To oSlide.Shapes.Count
Set oShape = oSlide.Shapes(j)
' Is it a text frame?
If oShape.HasTextFrame Then
If oShape.TextFrame.HasText Then
outText = oShape.TextFrame.TextRange.Text
' Check for bullets
If oShape.TextFrame.TextRange.ParagraphFormat.Bullet.Type <> ppBulletNone Then
outText = Replace(outText, Chr(10), " * ")
End If
If j = 1 Then ' Assume first text is always the header
outText = "= " + outText + " ="
End If
Print #iFile, (outText + Chr(13) + "[[BR]]" + Chr(13))
End If
End If
' Is it a table?
If oShape.Type = msoTable Then
cellText = ""
For row = 1 To oShape.Table.Rows.Count
For col = 1 To oShape.Table.Columns.Count
If row = 1 Then
cellText = cellText + "||<class=" + Chr(34) + "tableheader" + Chr(34) + ">" + oShape.Table.Columns.Item(col).Cells(row).Shape.TextFrame.TextRange.Text
Else
cellText = cellText + "||" + oShape.Table.Columns.Item(col).Cells(row).Shape.TextFrame.TextRange.Text
End If
If col = oShape.Table.Columns.Count Then
cellText = cellText + "||" + Chr(13)
End If
Next col
Next row
Print #iFile, (Chr(13) + cellText + Chr(13))
End If
' Is it a picture or embedded object
If oShape.Type = msoPicture Or oShape.Type = msoEmbeddedOLEObject Or oShape.Type = msoLinkedPicture Or oShape.Type = msoGroup Then
Dim imagepath
imagepath = oPres.Path & "/images/slide" + Trim(Str(i)) + Trim(Str(j)) + ".png"
oShape.Export imagepath, ppShapeFormatPNG
Print #iFile, (Chr(13) + "<img src=" + Chr(34) + "/images/slide" + Trim(Str(i)) + Trim(Str(j)) + ".png" + Chr(34) + ">" + Chr(13))
End If
Next j
Next i
Close #iFile
End Sub
For the first part, I think you probably need to recursively check each paragraph within the TextRange as bullets can be set for the whole text range or specific paragraphs within it and if there is a mix, you'll get unexpected results. I also don't see why the replacement is being made for Char 10. I think you should be returning the text for the paragraphs where a bullet is found and prefixing it with your Wiki string. For example:
' Check for bullets
Dim p As Long
Dim para As String
With oShape.TextFrame.TextRange
For p = 1 To .Paragraphs.Count
If .Paragraphs(p).ParagraphFormat.Bullet.Type <> ppBulletNone Then
para = " * " & .Paragraphs(p).Text
Else
para = .Paragraphs(p).Text
End If
outText = outText & para
Next
End With
For the second point, I got the same error because the images sub folder didn't exist. Once I created it manually, the code ran on PC. For Mac, you'll need to use POSIX or AppleScript path syntax if I recall correctly, for example:
#If Mac Then
Public Const PathSeparator = ":"
#Else
Public Const PathSeparator = "\"
#End If
However, if you're using PowerPoint:mac 2016 then things are more complicated due to its sandboxed environment. Check this article for more info:
http://www.rondebruin.nl/mac/mac034.htm
I wanted to insert some texts(new line) in between existing texts in a textbox (multiline = true).
Example: (Textbox1.text's value is written below)
Name: Name of Client
DOB: 11/11/11
>>>THIS IS WHERE I WHAT TO INSERT THE VALUE OF TEXTBOX2.TEXT
Hospitalization: No
Serial Number: 12345678
Private Sub cmdTransfer_Click()
Dim SearchNote As Integer, SearchThis As String, tx2 As String
If cb9.Value = True Then
tx2 = "ADDRESS: " & vbTab & text2.Text & vbCrLf
End If
SearchThis = "Hospitalization"
SearchNote = InStr(Textbox1.Text, SearchThis)
If SearchNote Then
With textbox1
.SetFocus
.SelStart = SearchNote
.Text = .Text & .SelStart & tx2
End with
End If
End Sub
What I'm doing in my code is I'm getting the number of characters before the "Hospitalization" so that I can insert the value of Textbox2 before it. I dont know how to do that tho. Please help.
Thanks!
I believe the code you are looking for is this:
Left(SearchNote, InStr(1, SearchNote, "Hospitalization") - 1) & "new text to insert" & Mid(SearchNote, InStr(1, SearchNote, "Hospitalization"))
Left will take the first few letters up to the starting point of "Hospitalization". Then you insert the new string (possible with a new line before and after with & chr(10) &). Then you add with Mid everything after "Hospitalization".
Since I don't have a sample copy of your spreadsheet, there is a chance that one/some of my variables might be different. If you find problems with any of these, check all of the vars.
Solution #1: Create module and add this function:
Function addText(txtBox As String, addString As String)
Dim endIndex As Long
Dim SearchThis As String
Dim input1, input2, input3 As String
SearchThis = "Hospitalization"
' Get index of Hospitalization
endIndex = InStr(1, txtBox, SearchThis) - 1
If endIndex > 0 Then
input1 = Mid(txtBox, 1, endIndex)
input2 = addString & vbNewLine
input3 = Mid(txtBox, endIndex, Len(txtBox))
' Return with added text
addText = CStr(input1 & input2 & input3)
End If
End Function
then call in your button to update your text box:
Private Sub cmdTransfer_Click()
Dim tx2 As String
If cb9.Value = True Then
tx2 = "ADDRESS: " & vbTab & text2.Text & vbNewLine
Else
' Stop if there is nothing to add
End
End If
If textbox1.Value <> vbNullString Then
textbox1.Value = addText(textbox1.Value, tx2)
End If
End Sub
Solution #2: Call everything from within your button:
Private Sub cmdTransfer_Click()
Dim endIndex As Long
Dim SearchThis As String
Dim input1, input2, input3 As String
Dim txtBox As String, tx2 As String
'set tx2
If cb9.Value = True Then
tx2 = "ADDRESS: " & vbTab & text2.Text & vbNewLine
Else
' Stop if nothing to add
End
End If
If textbox1.Value <> vbNullString Then
' set txtBox variable
txtBox = textbox1.Value
Else
' Avoid Error if text box is null
End
End If
SearchThis = "Hospitalization"
' Get index of Hospitalization
endIndex = InStr(1, txtBox, SearchThis) - 1
If endIndex > 0 Then
input1 = Mid(txtBox, 1, endIndex)
input2 = tx2 & vbNewLine
input3 = Mid(txtBox, endIndex, Len(txtBox))
textbox1.Value = input1 & input2 & input3
End If
End Sub
What i would do is split text1 into an array then just add the text in the middle, mainString is text1, midStr is text2:
Dim mainStr as String, midStr as String, ArreStr() as String
mainStr=text1.text:midStr=text2.text
ArreStr=Split(mainStr,VBNewLine)
text1.text=ArreStr(0) & vbnewline & midStr & vbnewline & ArreStr(1)
I need to take a range from Excel and have it paste over into an Outlook email message. The issue being when I do this it just pastes the text and not the table. Below is the code. I tried picture, but I don't want to have to embed it, don't understand why it won't just paste it like any other time I copy an image. I am working with Office 2013.
Private Sub btnSubmit_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnSubmit.Click
Dim objexcel As New Excel.Application
Dim objWorkbook As Excel.Workbook
Dim objWorksheet As Excel.Worksheet
Dim Range As Excel.Range
objexcel.DisplayAlerts = False
objWorkbook = objexcel.Workbooks.Open("c://Derp")
objWorksheet = CType(objWorkbook.Worksheets.Item("Sheet1"), Excel.Worksheet)
objWorksheet.Unprotect()
objWorksheet.Cells(2, 1).value = txtTravEmails.Text
objWorksheet.Cells(2, 4).value = Txttravemdate.Text
objWorksheet.Cells(3, 1).value = txtTravUnread.Text
objWorksheet.Cells(3, 4).value = Txttravundate.Text
objWorksheet.Cells(6, 1).value = txtITweb.Text
objWorksheet.Cells(6, 4).value = Txtwebdate.Text
objWorksheet.Cells(7, 1).value = txtITAPI.Text
objWorksheet.Cells(7, 4).value = Txtapidate.Text
objWorksheet.Cells(8, 1).value = txtITpend.Text
objWorksheet.Cells(8, 4).value = Txtpenddate.Text
'objWorksheet.Range("A1:D9").CopyPicture()
Range = objWorksheet.Range("A1:D9")
Range.Copy()
If Chkmorning.Checked = True Then
Dim Email As New Email_Templates
Email.Morning()
ElseIf Chkmid.Checked = True Then
Dim Email As New Email_Templates
Email.Mid()
ElseIf Chkevening.Checked = True Then
Dim Email As New Email_Templates
Email.Evening()
ElseIf Chkmidnight.Checked = True Then
Dim Email As New Email_Templates
Email.Midnight()
End If
objWorkbook.Save()
objWorkbook.Close()
objexcel.Quit()
End Sub
Public Sub Morning()
Dim Morning As String = "<html>" +
"<HEAD>" +
"<TITLE>Email</TITLE>" +
"</HEAD>" +
"<BODY>" +
"<font face=Calibri>" +
"<b> This is the morning report sent at " + DateAndTime.Now.ToShortTimeString + " EST! " +
"<br><br>" + Clipboard.GetText +
"</font>" +
"</BODY>" +
"</HTML>"
mail.Recipients.Add("derp#derp.com")
mail.BCC = ""
mail.Subject = Date.Now.ToShortDateString
mail.HTMLBody = Morning
'mail.Body = "This is the morning report sent at " & DateAndTime.Now.ToShortTimeString & " EST!" & vbNewLine & Clipboard.GetText
mail.Display()
End Sub
You have to pass the format that you want off the clipboard data.
Dim Morning As String = "<html>" +
"<HEAD>" +
"<TITLE>Email</TITLE>" +
"</HEAD>" +
"<BODY>" +
"<font face=Calibri>" +
"<b> This is the morning report sent at " + DateAndTime.Now.ToShortTimeString + " EST! " +
"<br><br>" + Clipboard.GetText(TextDataFormat.Html) +
"</font>" +
"</BODY>" +
"</HTML>"
The Clipboard.GetText method has an optional format parameter using the TextDataFormat constants.
Added the following to the morning sub
Dim Report As String
Report = Clipboard.GetText(TextDataFormat.Html)
Report = Report.Substring(Report.IndexOf("<html"))
and changed
mail.HTMLBody = Midnight & Report
Removed the sourceurl information before the pasted table