Lấy danh sách máy in bằng VBA

hsm.ksxd · 1/6/18

Các bác cho em hỏi tí.
Em muốn lấy danh sách máy in với tên đầy đủ ví dụ như:
- RICOH Aficio MP 6001 PCL 6 on Ne00:
- pdfFactory Pro on FPP5:
- Canon LBP2900 on Ne03:
thì phải viết như thế nào ạ?

phulien1902 · 1/6/18

hsm.ksxd đã viết:
Các bác cho em hỏi tí.
Em muốn lấy danh sách máy in với tên đầy đủ ví dụ như:
- RICOH Aficio MP 6001 PCL 6 on Ne00:
- pdfFactory Pro on FPP5:
- Canon LBP2900 on Ne03:
thì phải viết như thế nào ạ?

Bạn thử:
Application.Dialogs(xlDialogPrinterSetup).Show

♫ђöล♥ßล†♥†µ♫ · 1/6/18

hsm.ksxd đã viết:
Các bác cho em hỏi tí.
Em muốn lấy danh sách máy in với tên đầy đủ ví dụ như:
- RICOH Aficio MP 6001 PCL 6 on Ne00:
- pdfFactory Pro on FPP5:
- Canon LBP2900 on Ne03:
thì phải viết như thế nào ạ?

Sau một thời gian Copy Copy ... Paste Paste thì cũng được cái đoạn loàng ngoàng này

Mã:

Sub List_Printer()
    Dim aPrinters As Object
    Dim I As Long, Arr(), n As Long, Str As String
    With CreateObject("WScript.Network")
        Set aPrinters = .EnumPrinterConnections
        For I = 1 To aPrinters.Count Step 2
            n = n + 1
            ReDim Preserve Arr(1 To n)
            Arr(n) = aPrinters.Item(I)
        Next
    End With
    If n Then
        Str = Join(Arr, Chr(10))
        MsgBox Str
    Else
        MsgBox "Nothing"
    End If
End Sub

Bạn tham khảo thử

hsm.ksxd · 1/6/18

♫ђöล♥ßล†♥†µ♫ đã viết:
Sau một thời gian Copy Copy ... Paste Paste thì cũng được cái đoạn loàng ngoàng này

Mã:

Sub List_Printer() Dim aPrinters As Object Dim I As Long, Arr(), n As Long, Str As String With CreateObject("WScript.Network") Set aPrinters = .EnumPrinterConnections For I = 1 To aPrinters.Count Step 2 n = n + 1 ReDim Preserve Arr(1 To n) Arr(n) = aPrinters.Item(I) Next End With If n Then Str = Join(Arr, Chr(10)) MsgBox Str Else MsgBox "Nothing" End If End Sub

Bạn tham khảo thử

Cảm ơn bạn. Nhưng code này chỉ cho tên máy in chứ không có cổng máy in.
Nếu chạy code này chỉ có:
RICOH Aficio MP 6001 PCL 6
pdfFactory Pro
Canon LBP2900
ý mình là muốn danh sách máy in gồm cả cổng on nữa. ví dụ như:
- RICOH Aficio MP 6001 PCL 6 on Ne00:
- pdfFactory Pro on FPP5:
- Canon LBP2900 on Ne03:
Mong bạn giúp với

ndu96081631 · 1/6/18

hsm.ksxd đã viết:
Cảm ơn bạn. Nhưng code này chỉ cho tên máy in chứ không có cổng máy in.
Nếu chạy code này chỉ có:
RICOH Aficio MP 6001 PCL 6
pdfFactory Pro
Canon LBP2900
ý mình là muốn danh sách máy in gồm cả cổng on nữa. ví dụ như:
- RICOH Aficio MP 6001 PCL 6 on Ne00:
- pdfFactory Pro on FPP5:
- Canon LBP2900 on Ne03:
Mong bạn giúp với

Thử code này xem:

Mã:

Public Const HKEY_CLASSES_ROOT      As Long = &H80000000
Public Const HKEY_CURRENT_USER      As Long = &H80000001
'Public Const HKEY_LOCAL_MACHINE     As Long = &H80000002
'Public Const HKEY_USERS             As Long = &H80000003
'Public Const HKEY_PERFORMANCE_DATA  As Long = &H80000004
'Public Const HKEY_CURRENT_CONFIG    As Long = &H80000005
'Public Const HKEY_DYN_DATA          As Long = &H80000006
Public Const WMI_CLASS              As String = "winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv"
Public Const DEVICES                As String = "Software\Microsoft\Windows NT\CurrentVersion\Devices"
Function GetAllPrinters()
  Dim arr()
  Dim prn
  Dim aPrinters
  Dim prnName   As String
  Dim regValue  As String
  Dim n         As Long
  With GetObject(WMI_CLASS)
    .enumvalues HKEY_CURRENT_USER, DEVICES, aPrinters
    For Each prn In aPrinters
      .getstringvalue HKEY_CURRENT_USER, DEVICES, prn, regValue
      prnName = prn & " on " & Split(regValue, ",")(1)
      n = n + 1
      ReDim Preserve arr(1 To n)
      arr(n) = prnName
      'Debug.Print prnName
    Next
  End With
  If n Then
    GetAllPrinters = arr
  End If
End Function

Gõ vào cell nào đó trên bảng tính công thức: =GetAllPrinters() rồi Ctrl + Shift + Enter. Bấm F2 rồi F9 sẽ thấy các phần tử trong mảng
-------------
Tặng luôn file có form làm sẵn (bằng Dialog sheet)

hhoang_56 · 1/6/18

Tham khảo nhé :

https://www.excelforum.com/excel-programming-vba-macros/337960-list-of-printers.html

ndu96081631 · 1/6/18

hhoang_56 đã viết:
Tham khảo nhé :

https://www.excelforum.com/excel-programming-vba-macros/337960-list-of-printe,rs.html

Code đó không đúng yêu cầu của người ta đâu bạn à, vì kết quả thiếu phần đươi On Ne00:, On Ne01:.... vân vân...

hhoang_56 · 1/6/18

ndu96081631 đã viết:
Code đó không đúng yêu cầu của người ta đâu bạn à, vì kết quả thiếu phần đươi On Ne00:, On Ne01:.... vân vân...

Code chạy lên thì thấy như hình. Có đầy đủ On Ne00: .... luôn mà

hsm.ksxd · 1/6/18

ndu96081631 đã viết:

Thử code này xem:

Mã:

Public Const HKEY_CLASSES_ROOT      As Long = &H80000000
Public Const HKEY_CURRENT_USER      As Long = &H80000001
'Public Const HKEY_LOCAL_MACHINE     As Long = &H80000002
'Public Const HKEY_USERS             As Long = &H80000003
'Public Const HKEY_PERFORMANCE_DATA  As Long = &H80000004
'Public Const HKEY_CURRENT_CONFIG    As Long = &H80000005
'Public Const HKEY_DYN_DATA          As Long = &H80000006
Public Const WMI_CLASS              As String = "winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv"
Public Const DEVICES                As String = "Software\Microsoft\Windows NT\CurrentVersion\Devices"
Function GetAllPrinters()
  Dim arr()
  Dim prn
  Dim aPrinters
  Dim prnName   As String
  Dim regValue  As String
  Dim n         As Long
  With GetObject(WMI_CLASS)
    .enumvalues HKEY_CURRENT_USER, DEVICES, aPrinters
    For Each prn In aPrinters
      .getstringvalue HKEY_CURRENT_USER, DEVICES, prn, regValue
      prnName = prn & " on " & Split(regValue, ",")(1)
      n = n + 1
      ReDim Preserve arr(1 To n)
      arr(n) = prnName
      'Debug.Print prnName
    Next
  End With
  If n Then
    GetAllPrinters = arr
  End If
End Function

Gõ vào cell nào đó trên bảng tính công thức: =GetAllPrinters() rồi Ctrl + Shift + Enter. Bấm F2 rồi F9 sẽ thấy các phần tử trong mảng
-------------
Tặng luôn file có form làm sẵn (bằng Dialog sheet)

Cảm ơn bác nhiều ạ

hsm.ksxd · 1/6/18

hhoang_56 đã viết:
Code chạy lên thì thấy như hình. Có đầy đủ On Ne00: .... luôn mà

Sao máy em nó không ra On Ne0... nhỉ? Bác cho em xin code bác chạy với. Em muốn thử nhiều phương án mà

hhoang_56 · 1/6/18

hsm.ksxd đã viết:
Sao máy em nó không ra On Ne0... nhỉ? Bác cho em xin code bác chạy với. Em muốn thử nhiều phương án mà

Mã:

Option Explicit

Private Declare Function GetProfileString Lib "kernel32" _
Alias "GetProfileStringA" (ByVal lpAppName As String, _
ByVal lpKeyName As String, ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long) As Long


Sub Test()
Dim vaList
'Get all printers
vaList = PrinterFind
'Show m
MsgBox Join(vaList, vbLf), , "List of printers"

'Get all laserjets
vaList = PrinterFind(Match:="Laserjet")

'Switch to the first laserjet found
If UBound(vaList) = -1 Then
MsgBox "Printer not found"
ElseIf MsgBox("from " & vbTab & ": " & ActivePrinter & vbLf & _
"to " & vbTab & ": " & vaList(0), _
vbOKCancel, "Switch Printers") = vbOK Then
Application.ActivePrinter = vaList(0)
End If
End Sub




Public Function PrinterFind(Optional Match As String) As String()
Dim n%, lRet&, sBuf$, sCon$, aPrn$()
Const lLen& = 1024, sKey$ = "devices"

'------------------------------------------------------------------
'written by keepITcool

'requires xl2000 or newer.
'returns a zerobased array of complete localized printer strings
'results are filtered on Match string, if no result the ubound = -1
'------------------------------------------------------------------

'Split ActivePrinter string to get localized word for "on"
aPrn = Split(Excel.ActivePrinter)
sCon = " " & aPrn(UBound(aPrn) - 1) & " "

'Read all installed printers (1k bytes s/b enough)
sBuf = Space(lLen)
lRet = GetProfileString(sKey, vbNullString, vbNullString, sBuf, lLen)
If lRet = 0 Then
Err.Raise vbObjectError + 513, , "Can't read Profile"
Exit Function
End If

'Split buffer string
aPrn = Split(Left(sBuf, lRet - 1), vbNullChar)
'Filter array on Match
If Match <> vbNullString Then aPrn = Filter(aPrn, Match, -1, 1)

For n = LBound(aPrn) To UBound(aPrn)
'Add 16bit portname for each Printer
sBuf = Space(lLen)
lRet = GetProfileString(sKey, aPrn(n), vbNullString, sBuf, lLen)
aPrn(n) = aPrn(n) & sCon & _
Mid(sBuf, InStr(sBuf, ",") + 1, lRet - InStr(sBuf, ","))
Next
'Return the result
PrinterFind = aPrn

End Function

phulien1902 · 1/6/18

Đúng yêu cầu...roài
'----------------

hsm.ksxd · 1/6/18

hhoang_56 đã viết:

Mã:

Option Explicit

Private Declare Function GetProfileString Lib "kernel32" _
Alias "GetProfileStringA" (ByVal lpAppName As String, _
ByVal lpKeyName As String, ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long) As Long


Sub Test()
Dim vaList
'Get all printers
vaList = PrinterFind
'Show m
MsgBox Join(vaList, vbLf), , "List of printers"

'Get all laserjets
vaList = PrinterFind(Match:="Laserjet")

'Switch to the first laserjet found
If UBound(vaList) = -1 Then
MsgBox "Printer not found"
ElseIf MsgBox("from " & vbTab & ": " & ActivePrinter & vbLf & _
"to " & vbTab & ": " & vaList(0), _
vbOKCancel, "Switch Printers") = vbOK Then
Application.ActivePrinter = vaList(0)
End If
End Sub




Public Function PrinterFind(Optional Match As String) As String()
Dim n%, lRet&, sBuf$, sCon$, aPrn$()
Const lLen& = 1024, sKey$ = "devices"

'------------------------------------------------------------------
'written by keepITcool

'requires xl2000 or newer.
'returns a zerobased array of complete localized printer strings
'results are filtered on Match string, if no result the ubound = -1
'------------------------------------------------------------------

'Split ActivePrinter string to get localized word for "on"
aPrn = Split(Excel.ActivePrinter)
sCon = " " & aPrn(UBound(aPrn) - 1) & " "

'Read all installed printers (1k bytes s/b enough)
sBuf = Space(lLen)
lRet = GetProfileString(sKey, vbNullString, vbNullString, sBuf, lLen)
If lRet = 0 Then
Err.Raise vbObjectError + 513, , "Can't read Profile"
Exit Function
End If

'Split buffer string
aPrn = Split(Left(sBuf, lRet - 1), vbNullChar)
'Filter array on Match
If Match <> vbNullString Then aPrn = Filter(aPrn, Match, -1, 1)

For n = LBound(aPrn) To UBound(aPrn)
'Add 16bit portname for each Printer
sBuf = Space(lLen)
lRet = GetProfileString(sKey, aPrn(n), vbNullString, sBuf, lLen)
aPrn(n) = aPrn(n) & sCon & _
Mid(sBuf, InStr(sBuf, ",") + 1, lRet - InStr(sBuf, ","))
Next
'Return the result
PrinterFind = aPrn

End Function

Cảm ơn bác nhé

keke355992 · 10/8/18

ndu96081631 đã viết:

Thử code này xem:

Mã:

Public Const HKEY_CLASSES_ROOT      As Long = &H80000000
Public Const HKEY_CURRENT_USER      As Long = &H80000001
'Public Const HKEY_LOCAL_MACHINE     As Long = &H80000002
'Public Const HKEY_USERS             As Long = &H80000003
'Public Const HKEY_PERFORMANCE_DATA  As Long = &H80000004
'Public Const HKEY_CURRENT_CONFIG    As Long = &H80000005
'Public Const HKEY_DYN_DATA          As Long = &H80000006
Public Const WMI_CLASS              As String = "winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv"
Public Const DEVICES                As String = "Software\Microsoft\Windows NT\CurrentVersion\Devices"
Function GetAllPrinters()
  Dim arr()
  Dim prn
  Dim aPrinters
  Dim prnName   As String
  Dim regValue  As String
  Dim n         As Long
  With GetObject(WMI_CLASS)
    .enumvalues HKEY_CURRENT_USER, DEVICES, aPrinters
    For Each prn In aPrinters
      .getstringvalue HKEY_CURRENT_USER, DEVICES, prn, regValue
      prnName = prn & " on " & Split(regValue, ",")(1)
      n = n + 1
      ReDim Preserve arr(1 To n)
      arr(n) = prnName
      'Debug.Print prnName
    Next
  End With
  If n Then
    GetAllPrinters = arr
  End If
End Function

Gõ vào cell nào đó trên bảng tính công thức: =GetAllPrinters() rồi Ctrl + Shift + Enter. Bấm F2 rồi F9 sẽ thấy các phần tử trong mảng
-------------
Tặng luôn file có form làm sẵn (bằng Dialog sheet)

Thầy cho em hỏi, có phải cái On Ne1, On Ne2, On Ne3 mỗi lần tắt máy tính mở lại có thể nó bị thay đổi ko ạ. Ví dụ như hôm qua em thấy nó hiện là Canon 2900 on Ne02, Hôm nay lại thấy là Canon 2900 On Ne03

ndu96081631 · 10/8/18

keke355992 đã viết:
Thầy cho em hỏi, có phải cái On Ne1, On Ne2, On Ne3 mỗi lần tắt máy tính mở lại có thể nó bị thay đổi ko ạ. Ví dụ như hôm qua em thấy nó hiện là Canon 2900 on Ne02, Hôm nay lại thấy là Canon 2900 On Ne03

Thay đổi thì kệ nó đi! Đằng nào thì mấy cái On Ne01, Ne02... gì gì đó cũng đâu phải do mình tự ghi mà lo. Cái chuỗi ấy ta lấy trong Registry mà

keke355992 · 11/8/18

ndu96081631 đã viết:
Thay đổi thì kệ nó đi! Đằng nào thì mấy cái On Ne01, Ne02... gì gì đó cũng đâu phải do mình tự ghi mà lo. Cái chuỗi ấy ta lấy trong Registry mà

Tại vì máy tính của em cài 2 máy in Canon 2900. Mỗi máy e đặt lệnh in phần việc của nó. Nhưng hôm trước, do thay đổi cái Ne01, Ne02 mà nó bị ngược lại đó thầy ơi

Lấy danh sách máy in bằng VBA

hsm.ksxd

Thành viên chính thức

phulien1902

GPE - My love

♫ђöล♥ßล†♥†µ♫

Thành viên tiêu biểu

hsm.ksxd

Thành viên chính thức

ndu96081631

Huyền thoại GPE

File đính kèm

hhoang_56

Thành viên hoạt động

ndu96081631

Huyền thoại GPE

hhoang_56

Thành viên hoạt động

File đính kèm

hsm.ksxd

Thành viên chính thức

hsm.ksxd

Thành viên chính thức

hhoang_56

Thành viên hoạt động

phulien1902

GPE - My love

hsm.ksxd

Thành viên chính thức

keke355992

Thành viên thường trực

ndu96081631

Huyền thoại GPE

keke355992

Thành viên thường trực

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian