none
Printing Phantom Labels RRS feed

  • Question

  • Hello,

    BACKGROUND:

    I have a form which has a command button which automatically gives you the ability to read up to 6 addresses from a table in a document and place these addresses into up to 6 cells in a table on a new document -- these will be mailing labels (6 per sheet).   The command button also runs code which detects one of six radio buttons for the starting cell on the new document (the labels document ).  This is in case one or more labels have been used already.  If the number of labels exceed the number of labels left on a sheet, a second sheet is added.  Once the addresses are in the labels, more code detects which labels document cells have data in them and adds a logo picture, but this is only if another radio button is selected -- the option being that "no Logo" is selected, where blank lines are inserted instead.

    PROBLEM:

    This works -- Excelpt that in random uses, there are phantom logos and spaces placed in label sheet pages.  This occurs in cells/labels after the addresses/logos which are intended to be there.

    This is very random, and while I would like a solution, knowledge on why this is happining would be appreciated.

    CODE:

    Command Button code:

    Private Sub cmdCreate_Click()

    Select Case True
        Case Me.opt1: ActiveDocument.Tables(1).Cell(1, 1).Select
                            StartCellLoc = 1
        Case Me.opt2: ActiveDocument.Tables(1).Cell(1, 2).Select
                            StartCellLoc = 2
        Case Me.opt3: ActiveDocument.Tables(1).Cell(2, 1).Select
                            StartCellLoc = 3
        Case Me.opt4: ActiveDocument.Tables(1).Cell(2, 2).Select
                            StartCellLoc = 4
        Case Me.opt5: ActiveDocument.Tables(1).Cell(3, 1).Select
                            StartCellLoc = 5
        Case Me.opt6: ActiveDocument.Tables(1).Cell(3, 2).Select
                            StartCellLoc = 6

      End Select

    LogoVal1 = Me.oOpt1.Value
    LogoVal2 = Me.oOpt2.Value

    Call InitialLabels


    Me.Hide

    End Sub

    Supporting code in a Module:

    Public LabelDocNm As String  'JS
    Public LetterHDocNm As String  'JS
    Public Letter_cell_count As String  'JS
    Public LogoStatus As Boolean  'JS
    Public StartCellLoc As Double  'JS
    Public LogoVal1 As Boolean 'JS
    Public LogoVal2 As Boolean 'JS

    Sub InitialLabels()

    Dim rngTable As Range    ' Apps7 2011 03100017  JS  --go to first cell as selected for sheets w/labels missing
    Dim oLab As Document

     

    LetterHDocNm = ActiveDocument.Name

          ActiveDocument.Tables(1).Select
     
      Set oLab = Documents.Add(DataSourcePath & "Shipping Label.dotm")
     

    LabelDocNm = ActiveDocument.Name
    '2011 0312 Apps7.  Add Logo or Not - set variable
       If LogoVal1 = True Then LogoStatus = True
       If LogoVal2 = True Then LogoStatus = False

    OneOrMultipleLabels

    End Sub


    Sub OneOrMultipleLabels()


        If Right(LetterHDocNm, 5) = ".docx" Then
         Windows(LetterHDocNm).Activate
        Else
         Windows(LetterHDocNm & ".docx").Activate
        End If

     
     Letter_cell_count = 0
     
        Dim oCell   As Word.Cell
         ActiveDocument.Tables(1).Select
        'Add page if needed------------
        'Count all letter cells
          With Selection
                For Each oCell In .Tables(1).Range.Cells     'Loop Through all cells in table
                    oCell.Select
                    If Len(oCell.Range.Text) = 2 Then GoTo EMPT_cell  'EMPTY cell.
                   Letter_cell_count = Letter_cell_count + 1   'count cells
                Next
          End With

    EMPT_cell:

          'Add page if needed
          If Letter_cell_count + StartCellLoc >= 8 Then
            Windows(LabelDocNm).Activate
            Selection.InsertRowsBelow 3
                    If Right(LetterHDocNm, 5) = ".docx" Then
                        Windows(LetterHDocNm).Activate
                    Else
                        Windows(LetterHDocNm & ".docx").Activate
                    End If
          End If
          '-----------------------------
         
    'Windows(LabelDocNm).Activate

          ActiveDocument.Tables(1).Select
         
          'Copy and paste
          With Selection
                For Each oCell In .Tables(1).Range.Cells     'Loop Through all cells in table
                   oCell.Select
                    If Len(oCell.Range.Text) = 2 Then
                   
                        GoTo EMPT_cell2 'EMPTY cell.
                    
                    Else
                        Selection.Copy
                       
                        Windows(LabelDocNm).Activate
                        Call FindLastEmptyCell
                       
                        Windows(LabelDocNm).Activate
                        Selection.Paste
                       

                    End If
                Next
           End With

    EMPT_cell2:

    Windows(LabelDocNm).Activate
    Call insertPic
                   
    'Deselect Cell
                    If Right(LetterHDocNm, 5) = ".docx" Then
                        Windows(LetterHDocNm).Activate
                    Else
                        Windows(LetterHDocNm & ".docx").Activate
                    End If
                   
                    Selection.MoveUp Unit:=wdLine, Count:=1
                         'Selection.GoTo What:=wdGoToBookmark, Name:="bkDD"

                   
    Windows(LabelDocNm).Activate
    Windows(LabelDocNm & ".docx").Activate

    End Sub

     


    Sub FindLastEmptyCell()
    ' Apps7 2011 03100017  JS
        Dim oCell   As Word.Cell
       
         cell_count = 0
        
         ActiveDocument.Tables(1).Select
         'Count all label cells
          With Selection
                For Each oCell In .Tables(1).Range.Cells     'Loop Through all cells in table
                   cell_count = cell_count + 1
                Next
          End With
         'Select Initial Cell and determine if it is blank--------------
      
             If StartCellLoc = 1 Then ActiveDocument.Tables(1).Cell(1, 1).Select
             If StartCellLoc = 2 Then ActiveDocument.Tables(1).Cell(1, 2).Select
             If StartCellLoc = 3 Then ActiveDocument.Tables(1).Cell(2, 1).Select
             If StartCellLoc = 4 Then ActiveDocument.Tables(1).Cell(2, 2).Select
             If StartCellLoc = 5 Then ActiveDocument.Tables(1).Cell(3, 1).Select
             If StartCellLoc = 6 Then ActiveDocument.Tables(1).Cell(3, 2).Select
        
         'If Initial Cell is not blank find next blank cell--------------
        
              Dim RowNum As Long, ColNum As Long

         'Check for blank
          For g = 1 To Letter_cell_count
             RowNum = Selection.Cells(1).RowIndex
             ColNum = Selection.Cells(1).ColumnIndex
            
            
             If Len(ActiveDocument.Tables(1).Cell(RowNum, ColNum).Range.Text) = 2 Then Exit Sub  'EMPTY cell.
            
            
             Selection.Cells(1).Next.Select 'Move one cell
          Next g
      
       
    End Sub

     


    Sub insertPic()

    Dim oCell   As Word.Cell
         ActiveDocument.Tables(1).Select
        
        With Selection
                For Each oCell In .Tables(1).Range.Cells     'Loop Through all cells in table
                    Set rng = oCell.Range
                     'MsgBox Len(oCell.Range.Text)
                   
                    If Len(oCell.Range.Text) = 2 Or Len(oCell.Range.Text) = 2 Then 'EMPTY cell.
                        GoTo NextLabl
                    
                    Else
                        rng.MoveStart
                        rng.Select
                        Selection.MoveLeft Unit:=wdCharacter, Count:=1
                   
                       '2011 0312 Apps7.  Add Logo or Not
                        If LogoStatus = True Then
                            Selection.InlineShapes.AddPicture FileName:= _
                            "C:\Program Files\LawSuite\LogoPic.jpg" _
                            , LinkToFile:=False, SaveWithDocument:=True
                            Selection.TypeParagraph
                            Selection.TypeParagraph
                            Selection.TypeParagraph
                        End If
                       
                        If LogoStatus = False Then  'no logo
                            For y = 1 To 5
                            Selection.TypeParagraph
                            Next y
                        End If
                       
                    'Justify text
                  Selection.TypeText Text:=vbTab
                    For i = 1 To 4
                    Selection.MoveDown Unit:=wdLine, Count:=1
                    Selection.HomeKey Unit:=wdLine
                    Selection.TypeText Text:=vbTab
                    Next i

                    End If
    NextLabl:
                Next
        End With
       
    End Sub

     

    Thanks in advance.

     

    Friday, March 18, 2011 4:14 AM

All replies

  • Hi JimApps7,

    Thanks for posting in the MSDN Forum.

    Would you please reproduce your issue with a simple project and share your project on skydrive? I think it will be easier to analysis the case and faster to be a workaround.

    Have a good day,

    Tom


    Tom Xu [MSFT]
    MSDN Community Support | Feedback to us
    Get or Request Code Sample from Microsoft
    Please remember to mark the replies as answers if they help and unmark them if they provide no help.

    Tuesday, March 22, 2011 1:58 AM
    Moderator