I have a simple VBS script below that opens Word and creates a table with 4 cells, I need to add a bottom border only for the cell with TEXT inside and not for the entire table, any ideas?
Set objWord = CreateObject("Word.Application")
objword.visible = true
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
Set objRange = objDoc.Range()
objDoc.Tables.Add objRange,2,2
Set objTable = objDoc.Tables(1)
objTable.Cell(2,1).Range.Font.Name = "Arial"
objTable.Cell(2,1).Range.Text = "TEXT"
objTable.Cell(2,1).Borders(-3).LineStyle = 1 'wdLineStyleSingle
Related
I am writing a macro to generate pie chart in OpenOffice Basic but I can't find the method to change the colour of the different part of the pie.
We can take as example the macro of this subject:
OpenOffice Calc macro to add pie chart
That is, my data are:
And my code:
Sub Macro1
Dim oRange as Object
Dim oRangeAddress(1) As New com.sun.star.table.CellRangeAddress
Dim oRect As New com.sun.star.awt.Rectangle
Dim cTitle as String
oRange = thisComponent.getCurrentSelection.getRangeAddress
oSheets = ThisComponent.getSheets()
oSheet = oSheets.getByIndex(0)
oCharts = oSheet.Charts
oRect.Width = 10000
oRect.Height = 10000
oRect.X = 8000
oRect.Y = 1000
oRangeAddress(0).Sheet = oRange.Sheet
oRangeAddress(0).StartColumn = 0
oRangeAddress(0).StartRow = 0
oRangeAddress(0).EndColumn = 1
oRangeAddress(0).EndRow = 2
cTitle = "Test Results"
oCharts.addNewByName(cTitle,oRect,oRangeAddress(),TRUE, TRUE)
oChart = oCharts.getByName(cTitle).embeddedObject
oChart.Diagram = oChart.createInstance("com.sun.star.chart.PieDiagram")
oChart.HasMainTitle = True
oChart.Title.String = cTitle
End Sub
How can I get some green in my chart, instead of blue, for example?
Thank you for your help.
Here is one solution.
Sub Macro1
...
oFirstDiagram = oChart.getFirstDiagram()
oColorScheme = CreateUnoListener("XColorScheme_", "com.sun.star.chart2.XColorScheme")
oFirstDiagram.setDefaultColorScheme(oColorScheme)
End Sub
Function XColorScheme_getColorByIndex(index As Integer) As Long
Dim result As Long
result = &H0000FF ' blue
If index = 0 Then
result = &H00FF00 ' green
ElseIf index = 1 Then
result = &HFFFF00 ' yellow
End If
XColorScheme_getColorByIndex = result
End Function
The only relevant documentation I could find for this approach is the API docs: https://www.openoffice.org/api/docs/common/ref/com/sun/star/chart2/XDiagram.html.
Another way is to put the colors in column C.
Status Count Color
Unfinished 20 =COLOR(0,255,0)
Finished 30 =COLOR(255,0,0)
Then set the Range for Fill Color to use column C. If you want to see code for this second approach, post a comment and I'll look into it.
Yet another way is from https://forum.openoffice.org/en/forum/viewtopic.php?t=36001.
oChart.Diagram.DataRowSource = com.sun.star.chart.ChartDataRowSource.COLUMNS
oChart.FirstDiagram.CoordinateSystems(0).ChartTypes(0).DataSeries(0).Color = &H00FF00
However, this last approach did not change the color when I tried it.
I'm trying to set a company signature and then implement it with GPO.
Here's what I'm trying to accomplish:
John Hancock | Paralegal | Company, PC
<Logo (to the left of text)> 60 Test Street | PO Box 1389 | Testing, PA 19820
Phone: 555.555.5555| Fax: 555.555.5555 | Email: testing#testing.com (need this hyperlinked)
EDIT: Additional information from comments.
I'm trying to have different attributes (font size, font type, bold, etc) for the text in each particular line within the second row of the table. For example: Test text (this is bold and Calibri) - Test Text 2 (this is not bold and Arial). When I run the script as it stands, I get the logo on the left, in the first column, and a line of text to the right of the logo, in the second column. What I can't figure out is how to add another line of text, on the right, directly underneath the first line, and have that line of text show with different font attributes and such.
Here's the code I have so far:
Set objSysInfo = CreateObject("ADSystemInfo")
Set WshShell = CreateObject("WScript.Shell")
strUser = objSysInfo.UserName
Set objUser = GetObject("LDAP://" & strUser)
strName = objUser.FullName
strFirst = objUser.FirstName
strLast = objUser.LastName
strInitials = objUser.Initials
strOffice = objUser.physicalDeliveryOfficeName
strPOBox = objUser.postOfficeBox
strTitle = objUser.Description
strCred = objUser.info
strStreet = objUser.StreetAddress
strLocation = objUser.l
strPostCode = objUser.PostalCode
strPhone = objUser.TelephoneNumber
strMobile = objUser.Mobile
strFax = objUser.FacsimileTelephoneNumber
strEmail = objUser.mail
strCompany = objUser.Company
Const NUMBER_OF_ROWS = 1
Const NUMBER_OF_COLUMNS = 2
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries
Set objRange = objDoc.Range()
objDoc.Tables.Add objRange, NUMBER_OF_ROWS, NUMBER_OF_COLUMNS
Set objTable = objDoc.Tables(1)
Set objShape = objTable.Cell(1, 1).Range.Hyperlinks.Add(objSelection.InlineShapes.AddPicture("\\eg-fileserver\admin space\signature\logo.jpg"), "http://www.eastburngray.com",,,"")
objTable.Columns(1).Width = 20
objTable.Columns(2).Width = 320
objTable.Cell(1, 2).Range.Font.Bold = True
objTable.Cell(1, 2).Range.Font.Name = "Calibri"
objTable.Cell(1, 2).Range.Font.Size = 10
objTable.Range.ParagraphFormat.SpaceAfter = 0
objTable.Cell(1, 2).Range.Text = strFirst & strInitials & strLast & " | " & strOffice & " | " & strCompany
Set objSelection = objDoc.Range()
objSignatureEntries.Add "Full Signature", objSelection
objSignatureObject.NewMessageSignature = "Full Signature"
objDoc.Saved = True
objWord.Quit
The key to adding text with various formatting in Word is to work with a Range object. You can think of a Range like an invisible Selection, with the major difference that you can have as many Range objects as you need - there can be only one Selection. The trick to changing the formatting is to "collapse" the Range (think of it like pressing the Right- or Left-Arrow keys to a blinking "point", then continuing to type).
Edit Note: Based on bibadia's surmise that this is actually about VBScript and not VBA I've changed the tags in your question and am editing my Answer to fit VBScript. VBScript cannot use Word-specific object declarations and enumerations, so I've removed the "Dim As" and replaced all wdEnum with the Integer equivalent.
Using your code as a starting point, the approach could look something like this:
Dim rngCell
Set rngCell = objTable.Cell(1,2).Range
rngCell.ParagraphFormat.SpaceAfter = 0
rngCell.Text = strFirst & strInitials & strLast & " | " & _
strOffice & " | " & strCompany & vbCr
rngCell.Font.Bold = True
rngCell.Font.Name = "Calibri"
rngCell.Font.Size = 10
rngCell.Collapse 0 'wdCollapseEnd
rngCell.MoveEnd 1, -1 'wdCharacter, -1
rngCell.Text = strPhone & " | " & strFax & " | " & strEmail
rngCell.Font.Bold = False
rngCell.Font.Size = 8
Note 1: The order in which you do things is usually reversed from that when typing as a user: First populate the Range, then apply the formatting.
Note 2: When collapsing at the end of a cell, Word will move the Range position to the beginning of the following cell. Thus, the code moves the point back one character, putting it at the end of the previous (original) cell: rngCell.MoveEnd wdCharacter, -1
Note 3: I added a vbCr at the end of the first rngCell.Text to create the new paragraph within the table cell.
I need the below macro to reference another sub change event to loop reference to the row number of the scroll bar, i and then adjust the cell Bi . So far I can only get 100 scroll bars to reference only B2
Sub Tester88()
Dim ScrollBar As Object
Dim rng As Range
Dim i As Long
Dim lastRow As Long
lastRow = 99 'Modify as needed this will be the last possible row to add a button
For i = 2 To lastRow Step 4
Set rng = ActiveSheet.Cells(i, 18) 'Column 3, row i
'## Create the button object and assign a variable to represent it
Set ScrollBar = ActiveSheet.ScrollBars.Add(1, 1, 1, 1)
'## use the btn variable to manipulate the button:
With ScrollBar
.Top = rng.Top
.Left = rng.Left
.width = rng.width
.height = rng.RowHeight
.Value = 1
.Min = 1
.Max = 100
.SmallChange = 1
.LargeChange = 10
.LinkedCell = "$B$2"
.Display3DShading = True
End With
Next
End Sub
It looks like you can just put the row in .LinkedCell instead of having it hardcoded. You've set it to a range of 1-100; keep in mind if you are using LinkedCell you are directly controlling the value of the cell, so if you are controlling data that has an existing set of values you need to either set the range (and the value) to the existing value of the cell, or have it as a cell that just shows the scroll bar value and use a formula referencing that cell for the final result you want.+
I've solved this task, so:
Sub Tester88()
Dim ScrollBar As Object
Dim rng As Range
Dim i As Long
Dim lastRow As Long
lastRow = 99 'Modify as needed this will be the last possible row to add a button
For i = 2 To lastRow Step 4
Set rng = ActiveSheet.Cells(i, 13) 'Column 3, row i
'## Create the button object and assign a variable to represent it
Set ScrollBar = ActiveSheet.ScrollBars.Add(1, 1, 1, 1)
'## use the btn variable to manipulate the button:
With ScrollBar
.Top = rng.Top
.Left = rng.Left
.Width = rng.Width
.Height = rng.RowHeight
.Min = 1
.Max = 100
.SmallChange = 1
.LargeChange = 1
.LinkedCell = "B" & i
End With
Next
End Sub
I have a .txt file that needs to be cleaned up. It needs to have a page break before the word "Individual" on every page. It also needs to be Courier New 8.5pts, top and bottom margin of 0.5in, left and right margin of 1in. I modified another script I found (shown below) and it almost gets me there. the problem is there is some unneeded text before "Individual", which is the number 1 followed by several spaces and 3 carraige returns. I need to delete this text. Below is the script as it is currently:
Sub InsertPageBeforeDate()
Dim lngPos As Long
Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory
Selection.WholeStory
Selection.Font.Name = "Courier New"
Selection.Font.Size = 8.5
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "Individual"
.Format = False
.MatchCase = False
.MatchWholeWord = True
.MatchWildcards = False
Do While .Execute
If Selection.Information(wdFirstCharacterLineNumber) > 1 Then
lngPos = Selection.Start
Selection.MoveLeft Unit:=wdWord, Count:=2, Extend:=True
If LCase(Selection.Text) <> "of " Then
Selection.Collapse Direction:=wdCollapseEnd
Selection.InsertBreak Type:=wdPageBreak
End If
ActiveDocument.Range(Start:=lngPos + 4, End:=lngPos + 4).Select
End If
Loop
End With
Application.ScreenUpdating = True
End Sub
I have about 40 workbooks with 1000+ columns and near 1 million records.
Unfortunately, most of the data was imported as a text format, and I am trying to convert particular columns to a number format.
Aside from manually editing every file using the paste special > multiply technique, is there a way to macro this so that it would iterate through all the excel files in a particular folder?
You know the columns and numbers to change. You can record a macro of that and insert it into this basic DIR() technique:
Option Explicit
Sub LoopThroughFolder()
Dim fPATH As String, fNAME As String
Dim wb As Workbook
fPATH = "C:\Path\To\My\Files\" 'remember the final \
fNAME = Dir(fPATH & "*.xl*") 'get first filename from fPATH
Application.ScreenUpdating = False 'speed up execution
Do While Len(fNAME) > 0
Set wb = Workbooks.Open(fPATH & fNAME)
'your code here to format that activesheet
wb.Close True 'save and close the edited file
fNAME = Dir 'get the next filename
Loop
Application.ScreenUpdating = True
End Sub
Option Compare Database
Public Function format(filepath, sheetname, sheetpath)
Set xls = CreateObject("EXCEL.APPLICATION")
xls.screenupdating = False
xls.displayalerts = False
xls.Visible = True
xls.workbooks.Open filepath
Set xlsdd = xls.ActiveWorkbook
'deleting headers
xls.Range("1:1").Select
xls.Selection.Delete Shift:=xlUp
'adding one column
xls.Columns("A:A").Select
xls.Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
'adding 5 rows
'ActiveWorkbook.Sheets("sheet1").Select
xls.Rows("1:5").Insert Shift:=xlDown
' fetching rows from access and putting them into excel
' strsql = "select top 5 " & sheetname & ".* into top5_records from " & sheetname
' DoCmd.RunSQL strsql
' outputFileName = "C:\Users\hp\Desktop\top5_records.xls"
' DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "top5_records", outputFileName, True
'then open that excel and copy the rows
Set xls2 = CreateObject("EXCEL.APPLICATION")
xls2.screenupdating = False
xls2.displayalerts = False
xls2.Visible = True
xls2.workbooks.Open sheetpath
Set xlsdd2 = xls2.ActiveWorkbook
xls2.Rows("1:5").Select
xls2.Selection.Copy
xls.Cells(1, 1).Select
xls.activesheet.Paste
'making first 6th row to be bold
xls.Rows("6:6").Select
With xls.Selection.Font
.Bold = True
.Name = "Arial"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
End With
'autofit the data
xls.Sheets(sheetname).Cells.Columns.autofit
xls.CutCopyMode = False
'making both the excel objects to be free
With xlsdd
.Save
.Close
End With
xls.Visible = False
Set xlsdd = Nothing
Set xls = Nothing
With xlsdd2
.Save
.Close
End With
xls2.Visible = False
Set xlsdd2 = Nothing
Set xls2 = Nothing
End Function