I have supplied my code below.
Right now, there is an error in my code.
I want the page number to list 1,2,3,4,5 in order for each page, but it is instead listed like 5,5,5,5,5.
It may be because of the code I added:
Dim PageNum As String
PageNum = CStr(PageCnt)
TOCEntry.Text = PageNum + " -------- " + PageObj.Name
Here's the complete code:
Option Explicit
Sub TableOfContents()
' creates a shape for each page in the drawing on the first page of the drawing
' then add a dbl-clk GoTo to each shape so you can double click and go to that Page
Dim PageObj As Visio.Page
Dim TOCEntry As Visio.Shape
Dim CellObj As Visio.Cell
Dim PosY As Double
Dim PageCnt As Double
' ActiveDocument.Pages.Count will give the number of pages, but we are interested
' the number of foreground pages
PageCnt = 0
For Each PageObj In ActiveDocument.Pages
If PageObj.Background = False Then PageCnt = PageCnt + 1
Next
' loop through all the pages
For Each PageObj In ActiveDocument.Pages
If PageObj.Background = False Then ' Only foreground pages
' where to put the entry on the page?
PosY = (PageCnt - PageObj.Index) / 4 + 1
' draw a rectangle for each page to hold the text
Set TOCEntry = ActiveDocument.Pages(1).DrawRectangle(1, PosY, 4, PosY + 0.25)
' write the page name in the rectangle
Dim PageNum As String
PageNum = CStr(PageCnt)
TOCEntry.Text = PageNum + " -------- " + PageObj.Name
' add a link to point to the page to you can just go there with a Double Click
Set CellObj = TOCEntry.CellsSRC(visSectionObject, visRowEvent, visEvtCellDblClick) 'Start
CellObj.Formula = "GOTOPAGE(""" + PageObj.Name + """)"
End If
Next
'Clean Up
Set CellObj = Nothing
Set TOCEntry = Nothing
Set PageObj = Nothing
End Sub
You've set PageCnt to the number of non-Background pages, but then used that total as your page index. You don't need to count the number of pages, so remove the first loop and set PageCnt to 1 initially, then increment it after you set the CellObj.Formula value.
You are getting 5,5,5,5,5 because of this line:
PageNum = CStr(PageCnt)
To fix this this line should be:
PageNum = CStr(PageObj.Index)
So, it can give you 1,2,3,4,5.
Related
My code searches for certain numbers in textboxes and replaces them. The code however does not change the number if it is in a textbox that is created from a detail view(see figure 1). Do these not count as textboxes?
Figure 1
Dim Totalsheets As Integer
Dim target_text As String
Dim FirstPage As Integer
Dim replace_text As String
Dim result As String
Dim n As Integer 'count No. of text frames changed
Dim i As Integer 'count views for the sheet
Dim x As Integer 'takes the value of the first page of the old config
Dim y As Integer 'takes the value of the total number of sheets of the old config
Dim z As Integer 'takes the value of the number that needs to be added to update the zoning
Dim a As String 'takes the value of the letter found in the zoning box
Dim b As Integer
n = 0
Set osheets = odoc.Sheets
Set osheets = osheets.Item("DRAFT") 'makes sure only sheet "DRAFT" is edited
Set oViews = osheets.Views
Totalsheets = Totalsheets1.Value 'draws value from the textbox
FirstPage = FirstPage1.Value 'draws value from the textbox
For i = 3 To oViews.Count 'scans through all views in sheet
Set oView = oViews.Item(i)
Set oTexts = oView.Texts
For Each SrcText In oTexts 'scans through all text in view
x = FirstPage
y = Totalsheets
b = x + y
Do Until x = b + 1
z = x + Totalsheets
a = "A"
Do Until a = "[" 'goes from A to Z
result = SrcText.Text
target_text = " " & x & a 'gets space in front and letter at back to ensure only zone box are updated
replace_text = " " & z & a
If InStr(result, target_text) Then
result = Replace(result, target_text, replace_text)
SrcText.Text = result
n = n + 1
End If
a = Chr(Asc(a) + 1)
Loop
x = x + 1
Loop
Next
Next
Although the detail view identifier is a DrawingText, it does not belong to the DrawingTexts-collection.
You could access the DrawingText by searching in the view.
Better would be to rename the property of the view.
EDIT:
Example for using the (slower) selection:
Set oSel = oDoc.Selection
oSel.Clear
oSel.Add oView
oSel.Search "CATDrwSearch.DrwText,sel"
for i = 1 to oSel.Count2
Set oDrwText = oSel.Item2(i).Value
'do something with the text
next
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
I have a simple question, but i can not find the answer. For my job i have to make print sheets of 150x200 cm. Within these sheets a number of copies that are set border to border to fill out the sheet. Then we will print it.
Now i always start with one copy on the artboard, set my cut lines, group them up and to get the number of copies i want, i manually copy them with ctrl+shift+Alt (and CTRL+D ) to fill the artboard in width and length.
Now i was wondering if there is a tool or script where i can tell illustrator that i want 100 copies border to border and it automatically fills my artboard with the copies.
Any ideas?
AI has a rich object model. The object model allows to do everything you can do manually, and much more. Object model guides can be downloaded from the Adobe official web site.
The object model can be accessed from any programming or script language that supports automation. Examples include any modern C language IDEs, VBA, JavaScript and many others.
The thing you are looking for is the Duplicate method. The Duplicate method works times faster than Copy/Paste. The Duplicate method can be applied to many AI objects such as paths, group items, raster images, text frames etc.
The VBA code below draws a pattern and then fills the sheet with this pattern. You can use this code a basic tutorial for accessing the AI object model. Just open the VBA editor from any MS Office app, paste and run the code.
Good luck!
Option Explicit
Const CM2PT As Double = 28.3465
Const DOC_W As Double = 15# ' Document width (cm)
Const DOC_H As Double = 20# ' Document height (cm)
' NB: The combination of PATTERN_W, PATTERN_H, PAD_W, PAD_H should
' conform the Netherlands flag proportions 3:2
Const PATTERN_W As Double = 3# ' Pattern width (cm)
Const PATTERN_H As Double = 2# ' Pattern height (cm)
Const PAD_W As Double = 3# ' Flag pad width (pt)
Const PAD_H As Double = 2# ' Flag pad height (pt)
Sub Test()
Dim aiApp As Object ' Illustrator.Application
Dim aiDoc As Object ' Illustrator.Document
Dim aiPath As Object ' Illustrator.PathItem
Dim srcGroup As Object ' Illustrator.GroupItem
Dim dstGroup As Object ' Illustrator.GroupItem
Dim StripeColor_1 As Object ' Illustrator.RGBColor
Dim StripeColor_2 As Object ' Illustrator.RGBColor
Dim StripeColor_3 As Object ' Illustrator.RGBColor
Dim FrameColor As Object ' Illustrator.RGBColor
Dim Stripe_L As Double ' Left of a flag stripe (pt)
Dim Stripe_T As Double ' Top of a flag stripe (pt)
Dim Stripe_H As Double ' Height of a flag stripe (pt)
Dim Stripe_W As Double ' Width of a flag stripe (pt)
Dim i As Long
Dim j As Long
'*******************************************************************************
' Init
'*******************************************************************************
On Error Resume Next
Set aiApp = CreateObject("Illustrator.Application") ' Late binding
' Set aiApp = New Illustrator.Application ' Early binding
If (Err <> 0) Then Exit Sub
Set aiDoc = aiApp.Documents.Add(1, CM2PT * DOC_W, CM2PT * DOC_H) ' 1 = AiDocumentColorSpace.aiDocumentRGBColor
If (Err <> 0) Then Exit Sub
Set StripeColor_1 = CreateObject("Illustrator.RGBColor")
Set StripeColor_2 = CreateObject("Illustrator.RGBColor")
Set StripeColor_3 = CreateObject("Illustrator.RGBColor")
Set FrameColor = CreateObject("Illustrator.RGBColor")
Set srcGroup = aiDoc.GroupItems.Add
On Error GoTo 0
'*******************************************************************************
' Draw the flag of Netherlands
'*******************************************************************************
Stripe_L = PAD_W
Stripe_T = aiDoc.Height - PAD_H
Stripe_H = (CM2PT * PATTERN_H - 2 * PAD_H) / 3
Stripe_W = CM2PT * PATTERN_W - 2 * PAD_W
' Top stripe = Bright Vermilion RGB(174, 28, 40)
StripeColor_1.Red = 174
StripeColor_1.Green = 28
StripeColor_1.Blue = 40
' Center stripe = White RGB(255, 255, 255)
StripeColor_2.Red = 255
StripeColor_2.Green = 255
StripeColor_2.Blue = 255
' Bottom stripe = Cobalt Blue RGB(33, 70, 139)
StripeColor_3.Red = 33
StripeColor_3.Green = 70
StripeColor_3.Blue = 139
' Frame color = Black
FrameColor.Red = 0
FrameColor.Green = 0
FrameColor.Blue = 0
' Top stripe
Set aiPath = aiDoc.PathItems.Rectangle(Stripe_T, Stripe_L, Stripe_W, Stripe_H)
aiPath.Filled = True
aiPath.FillColor = StripeColor_1
aiPath.Stroked = False
Call aiPath.Move(srcGroup, 1) ' 1 = AiElementPlacement.aiPlaceAtBeginning
' Center stripe
Set aiPath = aiDoc.PathItems.Rectangle(Stripe_T - Stripe_H, Stripe_L, Stripe_W, Stripe_H)
aiPath.Filled = True
aiPath.FillColor = StripeColor_2
aiPath.Stroked = False
Call aiPath.Move(srcGroup, 1) ' 1 = AiElementPlacement.aiPlaceAtBeginning
' Bottom stripe
Set aiPath = aiDoc.PathItems.Rectangle(Stripe_T - 2 * Stripe_H, Stripe_L, Stripe_W, Stripe_H)
aiPath.Filled = True
aiPath.FillColor = StripeColor_3
aiPath.Stroked = False
Call aiPath.Move(srcGroup, 1) ' 1 = AiElementPlacement.aiPlaceAtBeginning
' The cover
Set aiPath = aiDoc.PathItems.Rectangle(aiDoc.Height, 0, CM2PT * PATTERN_W, CM2PT * PATTERN_H)
aiPath.Filled = True
aiPath.FillColor = StripeColor_2
aiPath.Opacity = 50#
aiPath.Stroked = True
aiPath.StrokeColor = FrameColor
aiPath.StrokeWidth = 0.25
Call aiPath.Move(srcGroup, 1) ' 1 = AiElementPlacement.aiPlaceAtBeginning
'*******************************************************************************
' Duplicate
'*******************************************************************************
For i = 1 To DOC_H / PATTERN_H
For j = 1 To DOC_W / PATTERN_W
Set dstGroup = srcGroup.Duplicate
dstGroup.Left = PATTERN_W * CM2PT * (j - 1)
dstGroup.Top = aiDoc.Height - PATTERN_H * CM2PT * (i - 1)
Next
Next
Call srcGroup.Delete
'*******************************************************************************
' Finish
'*******************************************************************************
FINISH:
Set StripeColor_1 = Nothing
Set StripeColor_2 = Nothing
Set StripeColor_3 = Nothing
Set FrameColor = Nothing
Set aiDoc = Nothing
Set aiApp = Nothing
End Sub
I created some kind of phone protocol sheet in excel and I wanted to add a section with quadrille paper for sketching purposes. Therefore I wrote a quite simple macro in VBA that draws horizontal and vertical lines in a selected range:
Public Sub Fill()
Dim angepeilteMaschenWeiteInPixel As Integer
angepeilteMaschenWeiteInPixel = 15
Dim LinienFarbe As Long
LinienFarbe = RGB(220, 220, 220)
Dim obenLinks As Double, obenRechts As Double
Dim untenLinks As Double, untenRechts As Double
Dim ausgewaehlteRange As Range
Set ausgewaehlteRange = Selection
' Anzahl Spalten und Zeilen ermitteln bei idealer Breite/Höhe 10px
Dim idealeSpaltenAnzahl As Integer
Dim idealeZeilenAnzahl As Integer
idealeSpaltenAnzahl = CInt(Round((ausgewaehlteRange.Width / angepeilteMaschenWeiteInPixel), 0))
idealeZeilenAnzahl = CInt(Round((ausgewaehlteRange.Height / angepeilteMaschenWeiteInPixel), 0))
' Aus der idealen Spalten- und Zeilenanzahl die ideale Maschenweite und - höhe in Pixeln ermitteln
Dim idealeMaschenBreite As Double
Dim idealeMaschenHoehe As Double
idealeMaschenBreite = ausgewaehlteRange.Width / CDbl(idealeSpaltenAnzahl)
idealeMaschenHoehe = ausgewaehlteRange.Height / CDbl(idealeZeilenAnzahl)
' vertikale Linien zeichnen
Dim i As Integer
For i = 1 To idealeSpaltenAnzahl - 1
Dim horizontal As Integer
horizontal = CInt(ausgewaehlteRange.Left + i * idealeMaschenBreite)
Dim oben As Integer
oben = Round(ausgewaehlteRange.Top, 0)
Dim unten As Integer
unten = Round(oben + ausgewaehlteRange.Height, 0)
With ActiveSheet.Shapes.AddLine(horizontal, oben, horizontal, unten).Line
.ForeColor.RGB = LinienFarbe
End With
Next i
' horizontale Linien zeichnen
Dim j As Integer
For j = 1 To idealeZeilenAnzahl - 1
Dim vertikal As Integer
vertikal = CInt(ausgewaehlteRange.Top + j * idealeMaschenHoehe)
Dim links As Integer
links = CInt(Round(ausgewaehlteRange.Left, 0))
Dim rechts As Integer
rechts = CInt(Round(links + ausgewaehlteRange.Width, 0))
With ActiveSheet.Shapes.AddLine(links, vertikal, rechts, vertikal).Line
.ForeColor.RGB = LinienFarbe
End With
Next j
End Sub
in excel everything looks fine:
but in the print preview and also printed out, the horizontal line gap is uneven and I have no idea why:
Anybody out there who can help me?
I suspect the lines are moving with the cells. Try setting the object positioning property to "Don't move or size with cells" which the English value is xlFreeFloating.
Example:
With ActiveSheet.Shapes.AddLine(links, vertikal, rechts, vertikal)
.Line.ForeColor.RGB = LinienFarbe
.Placement = xlFreeFloating
End With
Edit
Interesting behavior... I still think it's related to cells & margins as the lines move with cell width changes in print preview even though position is set to freeform.
I did find a workaround by grouping the lines together.
Added three lines of code. Add the following to both With blocks after Horizontal and Vertical lines are created.
.Select Replace:=False
Now add this line at the end of the sub:
Selection.Group
Now all the lines that were just created are grouped together.
Result image from print preview.
Example of last code block for your reference:
' horizontale Linien zeichnen
Dim j As Integer
For j = 1 To idealeZeilenAnzahl - 1
Dim vertikal As Integer
vertikal = CInt(ausgewaehlteRange.Top + j * idealeMaschenHoehe)
Dim links As Integer
links = CInt(Round(ausgewaehlteRange.Left, 0))
Dim rechts As Integer
rechts = CInt(Round(links + ausgewaehlteRange.Width, 0))
With ActiveSheet.Shapes.AddLine(links, vertikal, rechts, vertikal)
.Line.ForeColor.RGB = LinienFarbe
.Placement = xlFreeFloating
.Select Replace:=False
End With
Next j
Selection.Group
End Sub
Final Update: It has been resolved in an answer below. Thanks!
Probelm has been NOT been resolved :-(. The script does not interact well with MSword Fields.
Goal: Delete lines in MSWord 2007 that contain any number of spaces, tabs, and the obvious pilcrow (paragraph mark).
Steps Taken: I googled it and found this forum.
I then found this in a samble of a book on google and tried to modify it.
The modified is below:
Dim oPara As Word.Paragraph
Dim var
Dim SpaceTabCounter As Long
Dim oChar As Word.Characters
For Each oPara In ActiveDocument.Paragraphs
If Len(oPara.Range) = 1 Then
oPara.Range.Delete
Else
SpaceTabCounter = 0
Set oChar = oPara.Range.Characters
For var = 1 To oChar.Count
Select Case Asc(oChar(var)) ' ' ' ' 'ERROR is here
Case 32, 9
SpaceTabCounter = SpaceTabCounter + 1
End Select
Next
If SpaceTabCounter + 1 = Len(oPara.Range) Then
' paragraph contains ONLY spaces
oPara.Range.Delete
End If
End If
Next
The issue is that I get an error at "Select Case Asc(oChar(var))" half way down the code.
"Run-time error '5': Invalid procedure call or argument"
I'm new to VBA and...I can't figure this out. Please send your love!
Thanks
The error is still occuring.
Code as it stands now:
Dim oPara As Word.Paragraph
Dim var
Dim SpaceTabCounter As Long
Dim oChar As Word.Characters
For Each oPara In ActiveDocument.Paragraphs
If Len(oPara.Range) = 1 Then
oPara.Range.Delete
Else
SpaceTabCounter = 0
Set oChar = oPara.Range.Characters
For var = 1 To oChar.Count
Select Case Asc(oChar(var).Text) 'modified this line: added ".Text"
Case 32, 9
SpaceTabCounter = SpaceTabCounter + 1
End Select
Next
If SpaceTabCounter + 1 = Len(oPara.Range) Then
' paragraph contains ONLY spaces
oPara.Range.Delete
End If
End If
Next
When your code comes across a content control field, it reads the first character in the paragraph as an empty string. This behavior can be observed by checking the oChar.First.Text field in the local variables window. Asc() will throw an error when passed an empty string. This can be easily reproduced by running this procedure.
Sub throwError5()
Debug.Print Asc("")
End Sub
You will need to test the value of oChar(var) to ensure it is not an empty string prior to returning its ASCII value.
Option Explicit
Sub deleteEmptyParagraphs()
Dim oPara As Word.Paragraph
Dim var
Dim SpaceTabCounter As Long
Dim oChar As Word.Characters
For Each oPara In ActiveDocument.Paragraphs
If Len(oPara.Range) = 1 Then
oPara.Range.Delete
Else
SpaceTabCounter = 0
Set oChar = oPara.Range.Characters
For var = 1 To oChar.Count
If oChar(var) <> "" Then ' stops Asc from throwing runtime error 5
Select Case Asc(oChar(var)) ' no more errrors!
Case 32, 9
SpaceTabCounter = SpaceTabCounter + 1
End Select
End If
Next
If SpaceTabCounter + 1 = Len(oPara.Range) Then
' paragraph contains ONLY spaces
oPara.Range.Delete
End If
End If
Next
End Sub
I don't work with the Word object model often, so I have no idea why the fields' first character is an empty string. Please note that my comment about having to call oChar(index).Text was wrong. Text is the default property of a characters item.