Private Declare Function ActivateKeyboardLayout _
Lib "user32" (ByVal HKL As Long, ByVal flags As Long) As Long
Const kb_lay_ru As Long = 68748313, kb_lay_en As Long = 67699721
Sub PassportAutomatizationDV()
Const kb_lay_ru As Long = 68748313, kb_lay_en As Long = 67699721 ' изменение на английскую раскладку
x = ActivateKeyboardLayout&(kb_lay_en, 0) ' изменение на английскую раскладку
Dim ProdName, ProdAddress, PrevProdName, PrevProdAddress, ProdS, TwelveP, Serial, PrevSerial, Pass, mnumber, Passpath, Errorbox, PrintSetBox, thirteen As String, k, Qty, c As Integer
c = 0
On Error GoTo 1:
PrintSetBox = MsgBox("Вы правильно указали настройки принтера (Компоновка: 2 стр. на лист; Двусторонняя печать: переворачивать относительно короткого края)?", vbYesNo)
If PrintSetBox = vbNo Then Exit Sub
Passpath = ActiveDocument.Path & "/DeltaV/" 'Путь к паспортам (впоследствии изменить на папку из ворка, пока же папка находится в одной директории с настоящим файлом)
2:
mnumber = InputBox("Введите код комплекта", "Введение кода комплекта") 'Сканирование кода комплекта
If mnumber = "" Then Exit Sub
TwelveP = InputBox("Введите номер модели (12Pxxxx или 13Pxxx или SDN...)", "Введение номера модели")
If Left(TwelveP, 3) = "12P" And Left(TwelveP, 7) <> "12P4448" And Left(TwelveP, 7) <> "12P4449" And Left(TwelveP, 7) <> "12P4450" And Left(TwelveP, 7) <> "12P4451" And Left(TwelveP, 7) <> "12P4452" And Left(TwelveP, 7) <> "12P4453" And Left(TwelveP, 7) <> "12P4454" And Left(TwelveP, 7) <> "12P4455" And Left(TwelveP, 7) <> "12P4456" And Left(TwelveP, 7) <> "12P4983" Then
Pass = Left(TwelveP, 7) 'Сканирование 12P-номера
Else
If Left(TwelveP, 3) = "13P" Then 'определяет 13Р- номера по первым 7 символам
Pass = Left(TwelveP, 7)
Else
Pass = TwelveP
End If
End If
If Pass = "" Then Exit Sub
If Left(mnumber, 1) = "R" Then
Pass = Pass & Left(mnumber, 1)
End If
Documents.Open (Passpath & Pass & ".docx") 'открытие файла с шаблоном паспорта
Qty = InputBox("Введите количество паспортов", "Введение количества паспортов")
For k = 1 To Qty
3:
Serial = InputBox("Введите серийный номер", "Введение серийного номера, осталось паспортов: " & Qty - c)
If Left(Serial, 3) = "12P" Or Left(Serial, 3) = "002" Or Left(Serial, 3) = "13p" Then
MsgBox "Неправильно введен серийный номер", vbOKOnly, "Ошибка при вводе серийного номера"
GoTo 3:
End If
ProdS = Left(Serial, 1)
If Serial = "" Then
Application.DisplayAlerts = False
ActiveDocument.Close (False) 'закрытие документа для обновления полей
Application.DisplayAlerts = True
Exit Sub
End If
Select Case ProdS
Case Is = "M"
ProdName = "MTL"
ProdAddress = "Great Marlings, Butterfield, Luton LU2 8DL"
Case Is = "L"
ProdName = "Fisher Rosemount"
ProdAddress = "Meridan East, Leicester, LEI9 1UX"
Case Is = "A"
ProdName = "Fisher Rosemount"
ProdAddress = "1100 West Louis Henna Blvd. Bldg. 1, Round Rock, Texas, 78681-7430"
Case Is = "3"
ProdName = "Fisher Rosemount"
ProdAddress = "1100 West Louis Henna Blvd. Bldg. 1, Round Rock, Texas, 78641 USA"
Case Is = "T"
ProdName = "Benchmark Electronics"
ProdAddress = "94 Moo 1, Hi-Tech Industrial Estate, Banlane, Bang Pa-In, Ayudhaya 13160"
Case Is = "S"
ProdName = "P & F"
ProdAddress = "Great Marlings, Butterfield, Luton LU2 8DL"
Case Is = "M"
ProdName = "Astec"
ProdAddress = "Main Road Cor. Road J, Cavite Economic Zone Authority Tejeros Convention, Rosario, Cavite, 4106"
Case Is = "F"
ProdName = "Astec"
ProdAddress = "104 Laguna Blvd., Laguna Technopark Sta.Rosa, Laguna, Philippines 4026"
Case Is = "O"
ProdName = "Orienson"
ProdAddress = "7th Team lndustrial Zone,Xi'niupo Village,Dalang Town,Dongguan City,Guangdong Province"
Case Is = "J"
ProdName = "Jinpao"
ProdAddress = "631 Moo Soi 12 Phraksa, Amphur Muang, Samutprakarn 10280"
Case Is = "P"
If Left(Serial, 2) = "PH" Then
ProdName = "Astec Power Phillipines inc."
ProdAddress = "Main Ave, Corner Road J, PEZA Complex, Rosario, 4106 Cavite"
Else
ProdName = "Benchmark Electronics"
ProdAddress = "Malaysia, Free Industrial Zone, Phase 1, Bayan Lepas, 11900"
End If
Case Is = "N"
ProdName = "Nation Gate"
ProdAddress = "1413, Solok Perusahaan Satu, Kawasan Perindustrian Prai, Prai, 13600, Malaysia, 13600 Perai"
Case Is = "H"
ProdName = "Hotayi"
ProdAddress = "Taman Iks Bkt Tengah, 14000 Bukit Mertajam"
Case Is = "K"
ProdName = "Benchmark Electronics"
ProdAddress = "Thailand, 109 Moo 4, Tambol Chaimongkol, Amphur Muang, Nakornrachasima 30000"
Case Is = "C"
ProdName = "Puls"
ProdAddress = "Prague 5639, 430 01 Chomutov"
Case Is = "B"
ProdName = "Kin Fat"
ProdAddress = "FLAT G, 5/F, BLOCK 2, WAH FUNG IND. CENTRE, 33-39 KWAI FUNG CRESCENT, KWAI CHUNG, N.T., HONG KONG"
Case Is = "E"
ProdName = "Jabil"
ProdAddress = "China, Huangpu, 128 JunCheng Road., Huangpu Economic and Technological Development District, PRC 510530 Guangdong Province"
Case Is = "R"
ProdName = "Jabil"
ProdAddress = "China, Huangpu, 128 JunCheng Road., Huangpu Economic and Technological Development District, PRC 510530 Guangdong Province"
Case Is = "D"
ProdName = "Филиал ООО ''Эмерсон''"
ProdAddress = "454003, Российская Федерация, Челябинская область, город Челябинск, проспект Новоградский, дом 15"
Case Is = "X"
ProdName = "Xian Technology"
ProdAddress = "3F R&D Building Xi'an Software Park, 34 1st Jinye Rd., Xi'an High-Tech Industrial Zone"
Case Is = "U"
ProdName = "Phoenix Contact"
ProdAddress = "586 Fulling Mill Rd, Middletown, PA 17057"
Case Is = "9"
ProdName = "Hirschmann Automation and Control GmbH."
ProdAddress = "Germany, Stuttgarter Strasse 45-51, 72654 Neckartenzlingen"
Case Is = "1"
ProdName = "Fisher-Rosemount Systems, inc."
ProdAddress = "USA, 1100 W.Louis Henna Blvd. Round Rock, TX 78681"
Case Else
MsgBox "Неправильно введен серийный номер", vbOKOnly, "Ошибка при вводе серийного номера"
GoTo 3:
End Select
With ActiveDocument.Range.Find
.ClearFormatting
.Text = "mnumber"
.Replacement.Text = mnumber
.Execute Replace:=wdReplaceAll
.Text = "serialnumber"
.Replacement.Text = Serial
.Execute Replace:=wdReplaceAll
.Text = PrevSerial
.Replacement.Text = Serial
.Execute Replace:=wdReplaceAll
.Text = "currentdate"
.Replacement.Text = Date
.Execute Replace:=wdReplaceAll
.Text = "ProdName"
.Replacement.Text = ProdName
.Execute Replace:=wdReplaceAll
.Text = "ProdAddress"
.Replacement.Text = ProdAddress
.Execute Replace:=wdReplaceAll
.Text = PrevProdName
.Replacement.Text = ProdName
.Execute Replace:=wdReplaceAll
.Text = PrevProdAddress
.Replacement.Text = ProdAddress
.Execute Replace:=wdReplaceAll
PrevSerial = Serial
PrevProdName = ProdName
PrevProdAddress = ProdAddress
End With
Application.PrintOut FileName:="", Range:=wdPrintRangeOfPages, Item:= _
wdPrintDocumentWithMarkup, Copies:=1, Pages:="4,1,2,3", PageType:= _
wdPrintAllPages, Collate:=True, Background:=False, PrintToFile:=False, _
PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
PrintZoomPaperHeight:=0 'вывод на печать
c = c + 1
Next k
Application.DisplayAlerts = False
ActiveDocument.Close (False) 'закрытие документа для обновления полей
Application.DisplayAlerts = True
Exit Sub
1:
Errorbox = MsgBox("Неправильно введены данные, продолжить выполнение программы?", vbYesNo)
If Errorbox = vbNo Then
Application.DisplayAlerts = False
ActiveDocument.Close (False) 'закрытие документа для обновления полей
Application.DisplayAlerts = True
Exit Sub
End If
Resume 2:
End Sub
|
