Impression d'un code barre sur une étiquette
R
Bonjour à tous,
Je vous sollicite aujourd'hui car j'ai un problème avec l'impression de codes barres. J'ai une macro (pas réalisé par moi-même) qui s'occupe de récupérer des informations d'une feuille Excel (numéro d'enregistrement, nom du produit et emplacement). Le but étant d'imprimer ces informations sur une étiquette. Sur cette étiquette il y a le numéro d'enregistrement, le code barre correspondant et le nom du produit.
Le problème est le suivant :
Mon code barre s'imprime sur 3 lignes différentes, j'ai essayé de changer la taille de police, et même de police en soit, mais rien n'y fait.
Je joins le code où je n'ai essayé jusque là que de modifier la dernière partie qui s'occupe de l'impression (sub printout), et une photo exemple de l'étiquette.
(Les tâches sur la photo n'ont pas d'incidence, j'ai essayé sur une autre imprimante où l'impression est parfaite et cela ne change rien).
Dim defaultprinter
Sub auto_open()
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colPrinters = objWMIService.ExecQuery("Select * From Win32_Printer")
For Each objprinter In colPrinters
If objprinter.Default = True Then
defaultprinter = objprinter.Name
MsgBox (defaultprinter)
Exit For
End If
Next
End Sub
Sub Srlnbrprint()
' delcaration variables calcul cell
Dim row As String
Dim itemcell As String
Dim itemdesccell As String
Dim labelprintqtycell As String
Dim Item As String
Dim itemdesc As String
Dim answer As Integer
Dim labelprintqty As String
'declarations generation userform
Dim TempForm As Object
Dim NewButton As MSForms.CommandButton
Dim NewLabel As MSForms.Label
Dim NewTextBox As MSForms.TextBox
Dim NewOptionButton As MSForms.OptionButton
Dim NewCheckBox As MSForms.CheckBox
Dim X As Integer
Dim Line As Integer
Dim MyScript As String
Dim myresult As String
Dim Mycellvalue As String
Dim myquote As String
Dim s As String
Dim intlinecount As Integer
Dim nbrlabels As Integer
Dim cella As String
Dim cellb As String
Dim cellc As String
Dim celld As String
'calcule cellule
row = ActiveCell.row
itemcell = "B" & row
itemdesccell = "C" & row
labelprintqtycell = "A" & row
' recherche ligne
Item = Range(itemcell).Value
itemdesc = Range(itemdesccell).Value
labelprintqty = Range(labelprintqtycell).Value
answer = MsgBox("Print" & labelprinqty & "Labels for Item : " & Item & " / " & itemdesc, vbYesNo + vbQuestion, "mDF XLpages.com")
If answer = vbYes Then
'generation user form
'This is to stop screen flashing while creating form
Application.VBE.MainWindow.Visible = False
Set TempForm = ThisWorkbook.VBProject.VBComponents.Add(3)
'Create the User Form
With TempForm
.Properties("Caption") = "My User Form"
.Properties("Width") = 450
.Properties("Height") = 1000
.Properties("BackColor") = RGB(100, 161, 218)
End With
'Create Labels
'Item + designation
Set NewLabel = TempForm.designer.Controls.Add("Forms.label.1")
With NewLabel
.Name = "Itemnumberlabel"
.Caption = "Item : " + Item
.Top = 10
.Left = 2
.Width = 120
.Height = 16
.Font.Size = 12
.Font.Name = "Tahoma"
.BackColor = RGB(100, 161, 218)
End With
Set NewLabel = TempForm.designer.Controls.Add("Forms.label.1")
With NewLabel
.Name = "Itemdesclabel"
.Caption = " " + itemdesc
.Top = 10
.Left = 125
.Width = 400
.Height = 16
.Font.Size = 12
.Font.Name = "Tahoma"
.BackColor = RGB(100, 161, 218)
End With
'OK cancel button
Set NewButton = TempForm.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.Name = "ok"
.Caption = " OK "
.Top = 25
.Left = 350
.AutoSize = True
End With
'Check Box
'(True -> Upper Case of Text Box Value;False -> Lower Case of Text Box Value)
With TempForm.codemodule
intlinecount = .countoflines
intlinecount = intlinecount + 1
.insertlines intlinecount, "Sub OK_Click()"
For X = 0 To (labelprintqty - 1)
MyScript = "result_Text" & X + 1 & " = ucase(mytextbox" & X + 1 & ")"
intlinecount = intlinecount + 1
.insertlines intlinecount, MyScript
intlinecount = intlinecount + 1
Next
intlinecount = intlinecount + 1
.insertlines intlinecount, "End Sub"
End With
Set NewButton = TempForm.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.Name = "Cancel"
.Caption = " Cancel "
.Top = 25
.Left = 390
.AutoSize = True
End With
'Add event-hander subs for the CommandButtons
With TempForm.codemodule
intlinecount = .countoflines
.insertlines intlinecount + 1, "Private Sub Cancel_Click()"
.insertlines intlinecount + 2, ""
.insertlines intlinecount + 3, "unload me"
.insertlines intlinecount + 4, ""
.insertlines intlinecount + 5, "End Sub"
End With
'bouton imprimer
Set NewButton = TempForm.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.Name = "Print"
.Caption = " Print"
.Top = 25
.Left = 300
.AutoSize = True
End With
'Add event-hander subs for the CommandButtons
With TempForm.codemodule
intlinecount = .countoflines
intlinecount = intlinecount + 1
.insertlines intlinecount, "Private Sub Print_Click()"
intlinecount = intlinecount + 1
.insertlines intlinecount, "Worksheets.Add().Name =" & """serialnumbers"""
For X = 1 To (labelprintqty)
'A= Item
myquote = """"
Mycellvalue = myquote & Item & myquote
MyScript = "Worksheets(" & """serialnumbers""" & ").Range(" & """" & "A" & X & """" & ").Value =" & Mycellvalue
intlinecount = intlinecount + 1
.insertlines intlinecount, MyScript
'B=description
Mycellvalue = myquote & itemdesc & myquote
MyScript = "Worksheets(" & """serialnumbers""" & ").Range(" & """" & "B" & X & """" & ").Value =" & Mycellvalue
intlinecount = intlinecount + 1
.insertlines intlinecount, MyScript
'C= serial number
Mycellvalue = "Result_Text" & X
MyScript = "Worksheets(" & """serialnumbers""" & ").Range(" & """" & "C" & X & """" & ").Value =" & Mycellvalue
intlinecount = intlinecount + 1
.insertlines intlinecount, MyScript
'D= num piece
Mycellvalue = X
MyScript = "Worksheets(" & """serialnumbers""" & ").Range(" & """" & "D" & X & """" & ").Value =" & Mycellvalue
intlinecount = intlinecount + 1
.insertlines intlinecount, MyScript
'E= nbr totalpieces
Mycellvalue = labelprintqty
MyScript = "Worksheets(" & """serialnumbers""" & ").Range(" & """" & "E" & X & """" & ").Value =" & Mycellvalue
intlinecount = intlinecount + 1
.insertlines intlinecount, MyScript
Next
intlinecount = intlinecount + 1
.insertlines intlinecount, "Application.Run" & "(" & """Printout""" & ")"
'
intlinecount = intlinecount + 1
.insertlines intlinecount, "End Sub"
End With
'Create Labels
For X = 0 To (labelprintqty - 1)
Set NewLabel = TempForm.designer.Controls.Add("Forms.label.1")
With NewLabel
.Name = "FieldLabel" & X + 1
.Caption = X + 1
.Top = 50 + (30 * X)
.Left = 5
.Width = 20
.Height = 20
.Font.Size = 14
.Font.Name = "Tahoma"
.BackColor = RGB(100, 161, 218)
End With
Next
'Create Text Boxes
For X = 0 To (labelprintqty - 1)
Set NewTextBox = TempForm.designer.Controls.Add("Forms.textbox.1")
With NewTextBox
.Name = "MyTextBox" & X + 1
.Top = 50 + (30 * X)
.Left = 20
.Width = 200
.Height = 20
.Font.Size = 12
.Font.Name = "Tahoma"
.BorderStyle = fmBorderStyleSingle
.SpecialEffect = fmSpecialEffectFlat
End With
Next
'creation des champs calculés
For X = 0 To (labelprintqty - 1)
Set NewLabel = TempForm.designer.Controls.Add("Forms.label.1")
With NewLabel
.Name = "Result_Text" & X + 1
.Caption = ""
.Top = 50 + (30 * X)
.Left = 230
.Width = 200
.Height = 20
.Font.Size = 12
.Font.Name = "Tahoma"
.BorderStyle = fmBorderStyleSingle
.BackColor = RGB(100, 161, 218)
End With
Next
'Boutin print non visibel si pas fait OK
'Show the form
VBA.UserForms.Add(TempForm.Name).Show
'Delete the form (Optional)
ThisWorkbook.VBProject.VBComponents.Remove TempForm
Else
' ...
End If
End Sub
Sub Printout()
Dim net
Set net = CreateObject("WScript.Network")
'net.SetDefaultPrinter "\\crpsfrprt001\crppfrpr0015"
'Application.Dialogs(xlDialogPrinterSetup).Show
nbrlabels = CStr(ThisWorkbook.Sheets("Serialnumbers").Range("E1").Value)
For X = 0 To nbrlabels - 1
cella = "A" & (X + 1)
cellb = "B" & (X + 1)
cellc = "C" & (X + 1)
celld = "D" & (X + 1)
prt.prtitem = CStr(ThisWorkbook.Sheets("Serialnumbers").Range(cella).Value) & Chr(10) & CStr(ThisWorkbook.Sheets("Serialnumbers").Range(cellb).Value)
prt.prtsrlnbr.Font.Name = "CCode39"
prt.prtsrlnbr.Font.Size = 25
prt.prtsrlnbr = "*" & CStr(ThisWorkbook.Sheets("Serialnumbers").Range(cella).Value) & "*"
prt.prtsrlnbr1 = CStr(ThisWorkbook.Sheets("Serialnumbers").Range(cellc).Value)
prt.Printform
'Prt.Show
Next
Application.DisplayAlerts = False
Worksheets("serialnumbers").Delete
Application.DisplayAlerts = True
'Set net = CreateObject("WScript.Network")
'net.SetDefaultPrinter defaultprinter
End Sub