Dim Linha3 = WordDoc.Paragraphs.Add
Dim Tabela = WordDoc.Tables.Add(Linha3.Range, 7, 5)
Tabela.Range.Font.Name = "Calibri"
Tabela.Range.Font.Size = 8
Tabela.Columns(2).Width = 50
Tabela.Columns(3).Width = 150
Tabela.Columns(4).Width = 80
Tabela.Columns(5).Width = 80
Tabela.Range.ParagraphFormat.Alignment = Microsoft.Office.Interop.Word.WdParagraphAlignment.wdAlignParagraphCenter
Tabela.Cell(1, 4).Merge(Tabela.Cell(1, 5))
My question is. I wanna do this on a loop, cuz I gotta create mutiple tables. The problem is, when the loop occours it gives me a error saying that like Columns(2) was alredy resized, and kind double it... So I was thinking I gotta create like "Tabela2" but how can I create a dynamic variable ?
Imports Microsoft.Office.Interop
Public Class Form1
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
Dim objApp = New Word.Application
Dim objDoc As Word.Document
'For New Page = Word.WdBreakType.wdPageBreak
'For New section without a corresponding page break = Word.WdBreakType.wdSectionBreakContinuous
Dim objPageBreak As Object = Word.WdBreakType.wdSectionBreakContinuous
objApp = CreateObject("Word.Application")
objApp.Visible = True
objDoc = objApp.Documents.Add
For i = 1 To 3
CreateTableInWordDocument(objDoc.Bookmarks.Item("\endofdoc").Range, objDoc, objApp)
objDoc.Bookmarks.Item("\endofdoc").Range.InsertBreak(objPageBreak)
Next
End Sub
Private Sub CreateTableInWordDocument(objRange As Word.Range, objDoc As Word.Document, objApp As Word.Application)
Dim objTable As Word.Table
objTable = objRange.Tables.Add(objRange, 7, 5)
objTable.Borders.Enable = True
objTable.Borders.OutsideLineStyle = Word.WdLineStyle.wdLineStyleDouble
objTable.Borders.InsideLineStyle = Word.WdLineStyle.wdLineStyleSingle
Dim r As Integer, c As Integer
For r = 1 To 7
For c = 1 To 5
objTable.Cell(r, c).Range.Text = "Row" & r & " Column" & c
Next
Next
objTable.Rows.Item(1).Range.Font.Bold = True
objTable.Rows.Item(1).Range.Font.Italic = True
Me.Close()
End Sub
End Class
You must add one Button1 control in Windows desktop App and use this code - in loop For i=1 To 3 - here 3 is the count of tables to add in a Word document.
The thing on add more tables was. On my code, here:
Dim Tabela = WordDoc.Tables.Add(Linha3.Range, 7, 5)
The "WordDoc.Paragraphs.Add" wasnt the same I was using on the WordDoc. I was using "Linha" for the rest of the document instead of Linha3. Idk why it make diference, but that is what was giving me error.
So I just change it to "Linha", and it worked fine, with some custom editing to the Text of some cells.
Dim WordDoc = WordApp.Documents.Add
Dim Linha = WordDoc.Paragraphs.Add
The answer is just dont add another WordDoc.Paragraphs, And u should be fine.
Related
Does anyone know a method to sort Visio pages alphabetically using VBA?
I looked to see if a method such as vzdVisioDocument.Pages.Sort exists, but found nothing in documentation or through internet searches.
Do I need to write my own sorting function using the Application.ActiveDocument.Pages.ItemU("Page Name").Index property? That seems to be the method suggested by recording a macro of the action.
So that wasn't as painful as expected. With vzdVisioDocument as an already defined Visio.Document:
' Make a collection of titles to iterate through
Dim colPageTitles As Collection
Set colPageTitles = New Collection
Dim intPageCounter As Integer
For intPageCounter = 1 To vzdVisioDocument.Pages.Count
colPageTitles.Add vzdVisioDocument.Pages.Item(intPageCounter).Name
Next intPageCounter
' For each title in the collection, iterate through pages and find the appropriate new index
Dim intPageIndex As Integer
Dim varPageTitle As Variant
For Each varPageTitle In colPageTitles
For intPageIndex = 1 To vzdVisioDocument.Pages.Count
' Check to see if the title comes before the index's current page title
If StrComp(varPageTitle, vzdVisioDocument.Pages.Item(intPageIndex).Name) < 0 Then
' If so, set the new page index
vzdVisioDocument.Pages.ItemU(varPageTitle).Index = intPageIndex
Exit For
End If
Next intPageIndex
Next varPageTitle
' Clean up
Set colPageTitles = Nothing
I mentioned this in another comment, but when I made some test pages, it was always shuffling the pages around when I ran it because I the way that this is implemented, I don't believe that Exit For should be in there.
I also swapped the comparison to StrCompare due to personal preference along with the order of the for loops.
Sub PageSort()
Dim titlesColl As Collection
Set titlesColl = New Collection
Dim i As Long
For i = 1 To ActiveDocument.Pages.Count
titlesColl.Add ActiveDocument.Pages.Item(i).Name
Next i
Dim title As Variant
For i = 1 To ActiveDocument.Pages.Count
For Each title In titlesColl
If StrComp(ActiveDocument.Pages.Item(i).Name, title, vbTextCompare) < 0 Then
ActiveDocument.Pages.Item(title).index = i
End If
Next title
Next i
Set titlesColl = Nothing
End Sub
Private Sub reorderPages()
Dim PageNameU() As String
Dim isBackgroundPage As Boolean
Dim vsoPage As Visio.Page
Dim vsoCellObj As Visio.Cell
'// Get All Pages
Dim i As Integer
For Each vsoPage In ActiveDocument.Pages
i = i + 1
ReDim Preserve PageNameU(i)
PageNameU(i) = vsoPage.NameU
Next vsoPage
For i = 1 To UBound(PageNameU)
Set vsoPage = vsoPages.ItemU(PageNameU(i))
Set vsoCellObj = vsoPage.PageSheet.Cells("UIVisibility")
isBackgroundPage = vsoPage.Background
'// Make foreground page to set page index
If isBackgroundPage = True Then
vsoCellObj.FormulaU = visUIVNormal
vsoPage.Background = False
End If
vsoPage.Index = NumNonAppSysPages + i
'// Set to background page
If isBackgroundPage = True Then
vsoCellObj.FormulaU = visUIVHidden
vsoPage.Background = True
End If
Next i
End Sub
Hello,
I am trying to set up a form which is a calendar from which the user can select a date (by default the current month appears). The form consists of 42 command buttons (I have left the default name ie. CommandButton1) which I am setting the day number.
At the moment I have a long-winded section of code for each button (I used Excel to generate this rather than type it all out) which locks and hides the button if it is outside of the month in question which looks like this:
NewDate.CommandButton1.Caption = Format(DATlngFirstMonth - DATintDayNumFirst + DATintX, "dd")
If DATintX < DATintDayNumFirst Then
With NewDate.CommandButton1
.Locked = True
.Visible = DATbooShowExtraDays
.ForeColor = RGB(150, 150, 150)
End With
Else
With NewDate.CommandButton1
.Locked = False
.Visible = True
.ForeColor = RGB(0, 0, 0)
End With
End If
I know that I can refer to a command button by:
Dim objCommandButton As Object
Set objCommandButton = NewDate.CommandButton1
..which neatens the code up somewhat. But what I would like to do is refer to the command button as a string so I can loop through all 42, ie.
Dim n as integer
n = 1
Do Until n > 42
Set objCommandButton = NewDate.CommandButton & n
'Some operations
n = n + 1
Loop
Many thanks in advance for assistance.
You can loop through all controls of the form. Try
Sub LoopButtons()
Dim it As Object
For Each it In NewDate.Controls
Debug.Print it.Name
Next it
End Sub
Then you can put conditional expression (if ... then) in place of Debug.Print or whatever. For example
If Instr(it.Name, "CommandButton") Then
'do your code
end if
Here's code which iterates over ActiveX controls on active sheet:
Sub IterateOverActiveXControlsByName()
Dim x As Integer
Dim oleObjs As OLEObjects
Dim ctrl As MSForms.CommandButton
Set oleObjs = ActiveSheet.OLEObjects
For x = 1 To 10
Set ctrl = oleObjs("CommandButton" & x).Object
Next
End Sub
I have the below code which does everything except insert the page break after row 35. can anyone help please?
Sub PrintSet()
Dim rs As Worksheet
Dim sPrintArea As String
sPrintArea = "A1:AE65"
For Each rs In Sheets
rs.PageSetup.Orientation = xlLandscape
rs.PageSetup.Zoom = False
rs.PageSetup.FitToPagesWide = 1
rs.PageSetup.FitToPagesTall = 2
rs.PageSetup.PrintArea = sPrintArea
rs.HPageBreaks.Add before:=Range("A36")
Next rs
End Sub
Rewrite the last line like this:
rs.HPageBreaks.Add before:=rs.Range("A36")
Thus, you are adding a reference rs also. It should work better. See what Microsoft says about referencing ranges:
https://msdn.microsoft.com/en-us/library/office/aa221547(v=office.11).aspx
Try something like this:
Dim hpgbr As HPageBreak
Dim hpgbrs As HPageBreaks
Set hpgbr = hpgbrs.Add(Before:=Range("A36"))
This works for me. I removed the Zoom
Sub PrintSet()
Dim rs As Worksheet
Dim sPrintArea As String
sPrintArea = "A1:AE65"
For Each rs In Sheets
rs.PageSetup.Orientation = xlLandscape
rs.PageSetup.FitToPagesWide = 1
rs.PageSetup.FitToPagesTall = 2
rs.PageSetup.PrintArea = sPrintArea
rs.HPageBreaks.Add before:=Range("A36")
Next rs
End Sub
I have TextBoxes on UserForm and in Excel File (unfortunately).
I can do the loop on those in UserForm, and it works perfectly:
Dim txt(1 To 20) As String
txt(3)=("txtCompany")
txt(4)=("txtDataSource")
....
For i = 1 To 20
If frmInfo.Controls(txt(i)).Value <>
Worksheets(SheetNameDataBaze).Cells(ERow, i).Value Then ....
However, there is a huge problem with controls placed on the worksheet.
I tried:
Worksheets(SheetNameDataBaze).Controls(txt(i)).Value
Worksheets(SheetNameDataBaze).TextBox(txt(i)).Value
Worksheets(SheetNameDataBaze).OLEObjects(txt(i)).Value
Worksheets(SheetNameDataBaze).Shapes(txt(i)).Value
Worksheets(SheetNameDataBaze).txt(i).Value
nothing worked.
How should I define it?
It would be much easier then preparing the if statement for each TextBox.
I'm assuming that your textboxes on the worksheet are ActiveX controls and not forms controls. If so, then does this work for you?
Sub ReferToTextboxes()
Dim txt As MSForms.TextBox
Dim o As OLEObject
For Each o In Sheet1.OLEObjects
If o.progID = "Forms.TextBox.1" Then
Set txt = o.Object
'now you can refer to txt and do what you need
Debug.Print txt.Text
End If
Next o
End Sub
I finally used:
Private Sub FunctionalProgramNew()
Dim bLoop As Double
Dim eLoop As Double
bLoop = 8
eLoop = 13
Dim txt(8 To 13) As String
txt(8) = ("txtFuel_1")
txt(9) = ("txtFuel_2")
txt(10) = ("txtFuel_3")
txt(11) = ("txtProduct_1")
txt(12) = ("txtProduct_2")
txt(13) = ("txtProduct_3")
Dim txtBox(8 To 13) As MSForms.TextBox
For i = bLoop To eLoop
Set txtBox(i) = Worksheets(SheetNameModel).OLEObjects(txt(i)).Object
Next i
For i = bLoop To eLoop
If txtBox(i).Value <> CStr(Cells(ActiveCell.row, ActiveCell.Column + i - 2).Value) Then
MsgBox ("Error code: " & txt(i))
End If
Next i
End Sub
My application currently extracts data from an excel document, putting the data into a listview. I then am able to open each of the strings/items within the listview (which are pdf files in a given directory). However the pdf files within the given directory have revision letters at the end of their file names, starting with 'A' for the first revision and 'B' for the second revision...and so on.
So I am trying to approach it like comparing the string to the files in the directory and then once it's found, check what the latest rev letter is if any.
So if there is 07010302A.pdf file in the directory and there's also a 07010302B.pdf in the directory, I want to store that file name (07010302B.pdf) to a new string in my vb application. Any help on this would be much appreciated.
Here's what I am working with:
Imports Excel = Microsoft.Office.Interop.Excel
Public Class Form1
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
Dim xlApp As Excel.Application
Dim xlWorkBook As Excel.Workbook
Dim xlWorkSheet As Excel.Worksheet
Dim range As Excel.Range
Dim rCnt As Integer
Dim cCnt As Integer
Dim Obj As Object
xlApp = New Excel.Application
xlWorkBook = xlApp.Workbooks.Open("C:\Users\Admin\Desktop\Exp_Master.xlsm")
xlWorkSheet = xlWorkBook.Worksheets("Sheet1")
range = xlWorkSheet.Range("H1:H100") 'xlWorkSheet.UsedRange
For rCnt = 1 To range.Rows.Count
For cCnt = 1 To range.Columns.Count
Obj = CType(range.Cells(rCnt, cCnt), Excel.Range)
If IsNumeric(CType(range.Cells(rCnt, cCnt), Excel.Range).Value) Then
'MsgBox(Obj.value)
ListView1.Items.Add(Obj.value)
ListView1.View = View.List
End If
Next
Next
xlWorkBook.Close()
xlApp.Quit()
releaseObject(xlApp)
releaseObject(xlWorkBook)
releaseObject(xlWorkSheet)
'Kill Excel Process that wouldn't close
Process.Start("C:\Users\Admin\Desktop\batch archive\EXCEL_KILLER.bat")
'MsgBox("Total Item(s) in ListView:" & ListView1.Items.Count)
Dim i As Integer = 0
Dim n As Integer = 0
Dim str As String
For i = 1 To (ListView1.Items.Count)
Dim strng As String = "R:\"
n = (i - 1)
str = strng & (ListView1.Items.Item(n).Text) & (".pdf")
MsgBox(str)
'----
'System.Diagnostics.Process.Start(str)
'Here I want to check the R:\ directory and compare it with each string to see
'what the latest revision letter of the filename is and store it in another string to add to
'a pdf merging list later in this for loop
'----
Next
End Sub
Private Sub releaseObject(ByVal obj As Object)
Try
System.Runtime.InteropServices.Marshal.ReleaseComObject(obj)
obj = Nothing
Catch ex As Exception
obj = Nothing
Finally
GC.Collect()
End Try
End Sub
End Class
I was able to use your Directory.getfiles suggestion and I added a for loop to display only the last of the files labeled within that criteria. Thanks a bunch, just took a little more playing with it to determine what I actually wanted and how to put it in code.
If anyone cares, here is the update that works and gets the last file name and path of the directory.getfiles group within a search criteria.
Cheers!
For i = 1 To (ListView1.Items.Count)
Dim strng As String = "R:\"
n = (i - 1)
str = strng & (ListView1.Items.Item(n).Text) & (".pdf")
'MsgBox(str)
Dim substr As String
substr = str.Substring(3, 8)
'MsgBox(substr)
'----
'System.Diagnostics.Process.Start(str)
' Only get files that begin with...
Dim dirs As String() = Directory.GetFiles("R:\", (substr & ("*.pdf")))
'MsgBox("The number of files starting with your string is {0}.", dirs.Length)
Dim dir As String
For Each dir In dirs
If dir Is dirs.Last Then
MsgBox(dir)
'do something with your last item'
End If
Next
'----
Next
End Sub