Thread: [Solved] Numbering labels prints
View Single Post
 
Old 11-29-2013, 07:00 AM
valeriab valeriab is offline Windows XP Office 2007
Novice
 
Join Date: Nov 2013
Posts: 5
valeriab is on a distinguished road
Default Numbering labels prints

Hello
I am trying to number the printing of labels. I cannot do it the "easy" way, by generating a file sent to the printer per label number, as our printer cannot cope with it (when it comes to > 100 labels it takes 30 min to print and all labels are out of order).

So I thought I might just duplicate the label the required number of times, number the pages and print so it will be a single file. However, the way the code is set up today works for certain formats and not for others - while depending on the product the labels will have different formats and I need the operators here to be able to print quickly and easily via 1 button.

I have added some examples of labels - one of which only is working.

I do hope somebody will be able to help me (I have a very limited knowledge of word VBA!!!)

Many thanks,
Kind regards
valeria

My not fully working code is:

Code:
Public EndPage
Public IBCtoBeOrNotToBe
 '
Sub MacroLabels()
Dim Message As String, Title As String, Default As String, NumCopies As Long
Dim Rng1 As Range
Dim objTemplate As Template
Dim objBB As BuildingBlock
Msg = "Est-ce que le packaging c'est des IBCs?" ' Define message.
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons.
Title = "Type de Packaging" ' Define title.
 ' Display message.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then
  IBCtoBeOrNotToBe = "Yes"
Else ' User chose No.
  IBCtoBeOrNotToBe = "No"
End If
 ' Set prompt.
Message = "Rentrer le nombre d'etiquettes dont vous avez besoin"
 ' Set title.
Title = "Print"
 ' Set default.
Default = "1"
 ' Display message, title, and default value.
NumCopies = Val(InputBox(Message, Title, Default))
SerialNumber = System.PrivateProfileString("C:\Settings.Txt", _
"MacroSettings", "SerialNumber")
If NumCopies = 0 Then Exit Sub
NumCopies = NumCopies + 1
If SerialNumber = "" Then
  SerialNumber = 1
End If
Dim Rng As Range
With ActiveDocument
  Set Rng = .GoTo(What:=wdGoToPage, Name:="1")
  Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
  Rng.Copy
  counter = 1
  While counter < NumCopies
    With .Range.Characters.Last
      .InsertBefore vbCr & Chr(12)
      .Collapse wdCollapseEnd
      .PasteAndFormat (wdFormatOriginalFormatting)
    End With
    SerialNumber = SerialNumber + 1
    counter = counter + 1
  Wend
End With
Call InsertTrianglePageNumber
ActivePrinter = "active printer"
EndPage = NumCopies - 1
End Sub
 '
Sub Print1()
If IBCtoBeOrNotToBe = "No" Then
  ActiveDocument.PrintOut Range:=wdPrintRangeOfPages, Pages:="1-" & EndPage, Copies:=1
Else
  ActiveDocument.PrintOut Range:=wdPrintRangeOfPages, Pages:="1-" & EndPage, Copies:=2
End If
End Sub
 '
Sub InsertTrianglePageNumber()
Dim tmp As Template
Dim shp As Shape
Dim rg As Range
With ActiveDocument
  Set rg = .Sections(1).Footers(wdHeaderFooterPrimary).Range
  If rg.ShapeRange.Count > 0 Then rg.ShapeRange.Delete
  Set tmp = GetBBTemplate
  If Not tmp Is Nothing Then
    tmp.BuildingBlockEntries("Triangle 1").Insert _
    Where:=rg, RichText:=True
    Set shp = rg.ShapeRange(1)
    With shp
      .Fill.ForeColor.ObjectThemeColor = wdThemeColorBackground1
      .Fill.ForeColor.TintAndShade = -0.15
      .Fill.Solid
      .Fill.Visible = msoFalse
      With .TextFrame.TextRange.Font
        .Color = 0 'seems to give the same black as  -587137025
        .Name = "Calibri"
        .Size = 36
        .Bold = True
      End With
    End With
  Else
    MsgBox "Could not find Building Blocks.dotx template", , "Error"
  End If
End With
End Sub
 '
Function GetBBTemplate() As Template
Dim tmp As Template
Templates.LoadBuildingBlocks
For Each tmp In Templates
  If LCase(tmp.Name) = "building blocks.dotx" Then
    Set GetBBTemplate = tmp
    Exit For
  End If
Next
End Function

ex1 label.docx

ex working labels.docx

ex 3 label.docx

ex. label 4.docx

ex label 5.docx

Last edited by macropod; 11-29-2013 at 05:08 PM. Reason: Added code tags & formatting
Reply With Quote