デフォルトプリンタを一時的に変更する方法

TOP > デフォルトプリンタを一時的に変更する方法      [...]


Acrobat OLE(IAC)オブジェクトの AVDoc オブジェクト には各種の印刷関連メソッドが提供されています。

しかし、出力先プリンタの指定は出来ません。

出力先プリンタはデフォルトプリンタ(=通常使うプリンタに指定)とメソッドで条件が決まっています。

そこで一時的にデフォルトプリンタ(=通常使うプリンタに指定)を変更する Excel VBA + VB6.0 ロジックをココに公開します。

 

▼サンプルのダウンロード▼

ChangePrinter105.zip

注意:ReadMe.txtファイルを読んでから使用して下さい。

  


▼サンプルのソース内容 : ChangePrinter105.xls のみ▼

 

 





Option Explicit

Public Declare Sub Sleep Lib "kernel32" _
    (ByVal dwMilliseconds As Long)

Sub ボタン1_Click()
    
    Dim strChangePrinter    As String
    
    '★以下のステートメントは随時変更する必要が有る★
    strChangePrinter = Worksheets("Sheet1").Cells(4, 5)
    'strChangePrinter = "Canon BJ S600"
    
    If vbOK <> MsgBox("デフォルトプリンタを以下に変更してよいですか?" _
        & vbCrLf & vbCrLf & "(" & strChangePrinter & ")" _
        & vbCrLf & vbCrLf & "上記プリンタに印刷してもよいですか?", _
        vbOKCancel + vbDefaultButton1 + _
        vbQuestion + vbApplicationModal, _
        "確認") Then
        Exit Sub
    End If
    
    '▼デフォルトプリンタの変更
    If funChangePrinter(strChangePrinter) = False _
        Then Exit Sub

    '▼PDFの印刷
    
    'Acrobatオブジェクトの定義&作成
    
    'Acrobat 4,5,6の時
'    Dim objAcroApp    As Acrobat.CAcroApp
'    Dim objAcroAVDoc  As Acrobat.CAcroAVDoc
'    Set objAcroApp    = CreateObject("AcroExch.App")
'    Set objAcroAVDoc  = CreateObject("AcroExch.AVDoc")
    
    'Acrobat 7,8,9の時
    Dim objAcroApp      As New Acrobat.AcroApp
    Dim objAcroAVDoc    As New Acrobat.AcroAVDoc

    '以降はAcrobat全て共通
    Dim lRet As Long    '戻り値
    
    'Acrobatアプリケーションを起動する。
    lRet = objAcroApp.Show
    'PDFファイルを開いて表示する。
    lRet = objAcroAVDoc.Open("C:\work\Test01.pdf", "")
    'PDFファイルの頁を指定して印刷する。
    lRet = objAcroAVDoc.PrintPages(0, 0, 2, 0, 0)
    'PDFファイルを閉じます。
    lRet = objAcroAVDoc.Close(1)
    'Acrobatアプリケーションを終了する。
    lRet = objAcroApp.Hide
    lRet = objAcroApp.Exit
    'オブジェクトを強制解放する
    Set objAcroAVDoc = Nothing
    Set objAcroApp = Nothing

    '▼デフォルトプリンタの変更(元に戻す)
    If funChangePrinter("Brother DCP-535CN Printer") = False _
        Then Exit Sub
    
    '▼正常終了のメッセージ
    MsgBox "処理は正常終了しました", _
        vbInformation + vbSystemModal

End Sub

Public Function funChangePrinter _
    (ByVal strPrinterName As String) As Boolean

    Dim strAppPath      As String   'Excelワークブックのフルパス
    Dim verRet                      'Shell関数の戻り値
    Dim strCmd           As String   'コマンドライン
    Dim strLogFile       As String   'LOGファイル名
    Dim strLogFilePath  As String   'フルパス
    Dim strChangePrinter As String  '変更するプリンタ名
    Dim i                     As Long     '添え字
    
    funChangePrinter = False
    
    'アプリの監視MAX 60秒
    Const CON_MAX As Long = 60
    '起動アプリケーション名
    Const CON_APP As String = "ChangePrinter105.exe"

    '★以下のステートメントは随時変更する必要が有る★
    strChangePrinter = strPrinterName
        
    'Excelワークシートの実行フルパスを取得
    strAppPath = Application.ActiveWorkbook.Path & "\"
    
    '環境の事前チェック
    If Dir(strAppPath & CON_APP) = "" Then
        MsgBox "起動アプリケーション(" & CON_APP & ")が" _
            & "存在しません", _
            vbCrLf & vbCrLf & "処理は中断しました", _
            vbCritical + vbSystemModal, "実行エラー"
        Exit Function
    End If

    '▼「デフォルトプリンタの変更」アプリケーションの起動
    'ログファイルの命名
    Randomize   '乱数の初期化
    strLogFile = Format(Date, "YYYYMMDD") & _
                 Format(Time(), "HHMMSS") & "-" & _
                 Format(Int((9999 * Rnd) + 1), "0000") _
                 & ".log"
    
    'コマンド内容の作成
    strCmd = strAppPath & CON_APP & " " & _
             strChangePrinter & "," & strLogFile
    'アプリ起動 (非同期的で実行)
    verRet = Shell(strCmd, vbHide)

    '▼起動アプリケーションの完了を監視する
    strLogFilePath = strAppPath & strLogFile
    For i = 1 To CON_MAX
        Sleep 1000
        DoEvents
        If Dir(strLogFilePath) <> "" Then
            '起動アプリケーションの終了を検知した
            Exit For
        End If
    Next i
    If i >= CON_MAX Then
        MsgBox "起動アプリケーションは監視でタイムアウトになりました" & _
            vbCrLf & vbCrLf & "処理を中断します", _
            vbCritical + vbSystemModal, "実行エラー"
        '不要ファイルの削除
        Kill strLogFilePath
        Exit Function
    End If
    
    'テキストファイルの書込み時間分待つ
    Sleep 500
    '不要ファイルの削除
    Kill strLogFilePath

    '正常終了
    funChangePrinter = True
End Function

  


サンプルのソース内容 : ChangePrinter105.exe: のみ

ChangePrinter105.exeの画面1

 

Private Sub cmdEnd_Click()
    '画面を閉じる
    Unload Me
End Sub

Private Sub Command1_Click()
    'デフォルトプリンタ変更画面を表示
    Load Form1
    Form1.Show
    '自画面を閉じる
    Unload Me
End Sub

Private Sub Form_Load()
    Form2.Caption = CStr(App.EXEName) & "  引数の使い方   " & strVersion
    Label1.Caption = "ChangePrinter プリンター名 , テキストファイル.log" & vbCrLf _
        & "ChangePrinter /DP" & vbCrLf _
        & "ChangePrinter /AL" & vbCrLf _
        & "ChangePrinter /C" & vbCrLf & vbCrLf _
        & "・デフォルトプリンター変更の例:Canon BJ S600 , end.log" & vbCrLf _
        & "・/DP:デフォルトプリンター名のファイル(DefPrinter.txt)の出力" & vbCrLf _
        & "・/AL:プリンター名一覧ファイル(AllPrinter.txt)の出力" & vbCrLf _
        & "・/C :デフォルトプリンタの変更画面を表示" & vbCrLf _
        & "・/? :当引数説明画面の表示"
End Sub

  

ChangePrinter105.exeの画面2

 

Private Sub Form_Load()
    Dim r       As Long     '戻り値
    Dim Buffer  As String   'バッファ
    Dim i       As Long     '添え字

    ' Get the list of available printers from WIN.INI
    Buffer = Space(8192)
    r = GetProfileString("PrinterPorts", vbNullString, "", _
             Buffer, Len(Buffer))

    ' Display the list of printer in the ListBox List1
    ParseList List1, Buffer
    
    Form1.Caption = Form1.Caption & " " & strVersion
    Label1.Caption = vbNullString
    
    If List1.ListCount = 0 Then
        'プリンタが登録されて無い
        Command1.Enabled = False
        Exit Sub
    End If
    
    'デフォルトプリンタを選択状態にする
    For i = 0 To List1.ListCount - 1
        If List1.List(i) = Printer.DeviceName Then
            List1.ListIndex = i
            Exit For
        End If
    Next i
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'アプリケーションの終了
    End
End Sub

Private Sub Command1_Click()
    Dim osinfo      As OSVERSIONINFO
    Dim retvalue    As Integer

    'リストボックスが選択状態に無い時はスキップ
    If List1.Text = "" Then Exit Sub
    
    '作業中はボタン類を使用不可にする
    Command1.Enabled = False
    Command2.Enabled = False
    'マウスポインターを砂時計にする
    Me.MousePointer = vbHourglass
    Label1.Caption = "デフォルトプリンタの変更中..."
    Me.Refresh
    
    If List1.Text = Printer.DeviceName Then
        GoTo Command1_Skip:
    End If
    
    osinfo.dwOSVersionInfoSize = 148
    osinfo.szCSDVersion = Space$(128)
    retvalue = GetVersionExA(osinfo)
    
    gstrChangePrinterName = List1.Text

    'デフォルトプリンタの変更
    If osinfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
        'Widnows 95/98
        Call Win95SetDefaultPrinter
    Else
        'This assumes that future versions of Windows
        'use the NT method
        Call WinNTSetDefaultPrinter
    End If
    
    Command1_Skip:
    'ボタン類を使用可能にする
    Command1.Enabled = True
    Command2.Enabled = True
    Label1.Caption = "デフォルトプリンタの変更は完了しました"
    'マウスポインターをデフォルトに戻す
    Me.MousePointer = vbDefault
End Sub

Private Sub Command2_Click()
    '画面を閉じる
    Unload Me
End Sub

 

▼ Module1.basの内容 ▼

  

Attribute VB_Name = "Module1"
Option Explicit

'======================================================
'
'【機能】引数よりデフォルトプリンタを変更する。
' 引数より以下の情報をテキストファイルで出力する。
' 1)デフォルトプリンタを変更する
' 2)デフォルトプリンタを出力
' 3)プリンタ一覧を出力
'
'【作成者】http://pdf-file.nnn2.com/ サイト管理人
'
'【作成日】2010/08/31 (初版)
'
'【引数:例】
'
'【備考】1)以下のURLからメイン・ロジックを引用しました。
' http://support.microsoft.com/kb/266767/ja
'        2)多重起動可能チェックはしない。
' 3)単体でも、他アプリからのコマンドライン起動でも
' 使用出来るように設計してある。
' 4)引数の設定形式は固定とする。
' ・プリンタ名 , 処理完了を知らせるテキストファイル名
' ・プリンタ名
' ・/DP
' ・/AL
' ・/C
' ・/?
' ・無し
'======================================================

'ブロードキャスト(全てのトップレベルウインドウ)
Public Const HWND_BROADCAST = &HFFFF
'Windowsの初期化ファイルの更新を反映
Public Const WM_WININICHANGE = &H1A

' constants for DEVMODE structure
Public Const CCHDEVICENAME = 32
Public Const CCHFORMNAME = 32

' constants for DesiredAccess member of PRINTER_DEFAULTS
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const PRINTER_ACCESS_ADMINISTER = &H4
Public Const PRINTER_ACCESS_USE = &H8
Public Const PRINTER_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED _
                               Or PRINTER_ACCESS_ADMINISTER _
                               Or PRINTER_ACCESS_USE)

' constant that goes into PRINTER_INFO_5 Attributes member
' to set it as default
Public Const PRINTER_ATTRIBUTE_DEFAULT = 4

' Constant for OSVERSIONINFO.dwPlatformId
Public Const VER_PLATFORM_WIN32_WINDOWS = 1

Public Type OSVERSIONINFO
    dwOSVersionInfoSize As Long      '構造体のバイト数
    dwMajorVersion      As Long      'メジャーバージョン番号
    dwMinorVersion      As Long      'マイナーバージョン番号
    dwBuildNumber       As Long      'ビルド番号
    dwPlatformId        As Long      'プラットフォームのID
    szCSDVersion        As String * 128  'OSに関する付加情報
End Type

Public Type DEVMODE
    dmDeviceName    As String * CCHDEVICENAME
    dmSpecVersion   As Integer
    dmDriverVersion As Integer
    dmSize          As Integer
    dmDriverExtra   As Integer
    dmFields        As Long
    dmOrientation   As Integer
    dmPaperSize     As Integer
    dmPaperLength   As Integer
    dmPaperWidth    As Integer
    dmScale         As Integer
    dmCopies        As Integer
    dmDefaultSource As Integer
    dmPrintQuality  As Integer
    dmColor         As Integer
    dmDuplex        As Integer
    dmYResolution   As Integer
    dmTTOption      As Integer
    dmCollate       As Integer
    dmFormName      As String * CCHFORMNAME
    dmLogPixels     As Integer
    dmBitsPerPel    As Long
    dmPelsWidth     As Long
    dmPelsHeight    As Long
    dmDisplayFlags  As Long
    dmDisplayFrequency As Long
    dmICMMethod     As Long  '// Windows 95 only
    dmICMIntent     As Long  '// Windows 95 only
    dmMediaType     As Long  '// Windows 95 only
    dmDitherType    As Long  '// Windows 95 only
    dmReserved1     As Long  '// Windows 95 only
    dmReserved2     As Long  '// Windows 95 only
End Type

Private Type PRINTER_INFO_5
    pPrinterName        As String
    pPortName           As String
    Attributes          As Long
    DeviceNotSelectedTimeout As Long
    TransmissionRetryTimeout As Long
End Type

Public Type PRINTER_DEFAULTS
    pDatatype           As Long
    pDevMode            As Long
    DesiredAccess       As Long
End Type

Public 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

'Win.iniファイルに文字列を書き込む
Private Declare Function WriteProfileString Lib "kernel32" _
    Alias "WriteProfileStringA" _
    (ByVal lpszSection As String, _
     ByVal lpszKeyName As String, _
     ByVal lpszString As String) As Long

'ウィンドウにメッセージを送信
Private Declare Function SendMessage Lib "user32" _
    Alias "SendMessageA" _
    (ByVal hwnd As Long, _
     ByVal wMsg As Long, _
     ByVal wParam As Long, _
     lparam As String) As Long

Public Declare Function GetVersionExA Lib "kernel32" _
    (lpVersionInformation As OSVERSIONINFO) As Integer

Private Declare Function OpenPrinter Lib "winspool.drv" _
    Alias "OpenPrinterA" _
    (ByVal pPrinterName As String, _
     phPrinter As Long, _
     pDefault As PRINTER_DEFAULTS) As Long

Private Declare Function SetPrinter Lib "winspool.drv" _
    Alias "SetPrinterA" _
    (ByVal hPrinter As Long, _
     ByVal Level As Long, _
     pPrinter As Any, _
     ByVal Command As Long) As Long

Private Declare Function GetPrinter Lib "winspool.drv" _
    Alias "GetPrinterA" _
    (ByVal hPrinter As Long, _
     ByVal Level As Long, _
     pPrinter As Any, _
     ByVal cbBuf As Long, _
     pcbNeeded As Long) As Long

Private Declare Function lstrcpy Lib "kernel32" _
    Alias "lstrcpyA" _
    (ByVal lpString1 As String, _
     ByVal lpString2 As Any) As Long

Private Declare Function ClosePrinter Lib "winspool.drv" _
    (ByVal hPrinter As Long) As Long

Private strPrintDeviceName(500) As String
Private strPrintDriverName(500) As String
Private strPrintPort(500)       As String
Public gstrChangePrinterName    As String
'※配列は500程度待たせて置く。実際こんなに多くは無いはず。

'****************************************************
'
'▼スタートアップ処理
'
'****************************************************
Sub Main()

    'デフォルト・プリンタのファイル
    Const CON_DEF_PRINTER_FILE = "DefPrinter.txt"
    'プリンタ名一覧のファイル
    Const CON_ALL_PRINTER_FILE = "AllPrinter.txt"
    
    Dim strCmdLine()    As String   'コマンドライン引数
    Dim lFileNo         As Long     'ファイル番号
    Dim strAppPath      As String   'アプリケーションの実行パス
    Dim strVersion      As String
    Dim strOutputText(5) As String  '出力テキスト
    Dim strCmdLine_1    As String   'コマンドライン引数1
    Dim strCmdLine_2    As String   'コマンドライン引数2
    Dim prtObj          As Printer  'プリンターオブジェクト
    Dim bCheck          As Boolean
    Dim i               As Long     '添え字
    Dim j               As Long     '添え字
    
    '初期化
    j = -1
    For i = LBound(strOutputText) To UBound(strOutputText) - 1
        strOutputText(i) = vbNullString
    Next i
    For i = LBound(strPrintPort) To UBound(strPrintPort) - 1
        strPrintDeviceName(i) = vbNullString
        strPrintDriverName(i) = vbNullString
        strPrintPort(i) = vbNullString
    Next i
    strAppPath = App.Path & "\"

    '▼開始時間のテキスト出力
    j = j + 1
    strOutputText(j) = _
        "START " & Format(Date, "YYYY/MM/DD") & _
             " " & Format(Time(), "HH:MM:SS")
    
    'コマンドライン引数を配列に格納
    strCmdLine = Split(Command(), ",")

    '▼引数の存在チェックをする
    If UBound(strCmdLine) = -1 Then
        '引数が無い ※テスト済み
        '表示する
        Form2.Show vbModeless
        Exit Sub
    End If
    
    '▼コマンドライン引数を変数に格納
    If UBound(strCmdLine) = 0 Then
        strCmdLine_1 = Trim$(strCmdLine(0))
    ElseIf UBound(strCmdLine) = 1 Then
        strCmdLine_1 = Trim$(strCmdLine(0))
        strCmdLine_2 = Trim$(strCmdLine(1))
    Else
        strCmdLine_1 = Trim$(strCmdLine(0))
        strCmdLine_2 = Trim$(strCmdLine(1))
        '第三引数は無視
    End If
    
    If strCmdLine_2 <> vbNullString Then
        j = j + 1
        strOutputText(j) = _
            "CMD   " & Format(Date, "YYYY/MM/DD") & _
                 " " & Format(Time(), "HH:MM:SS") & _
                 " " & strCmdLine_1 & _
                 " , " & strCmdLine_2
    End If
    
    '▼引数紹介画面を表示するか?
    If strCmdLine_1 = "/?" Or strCmdLine_1 = "-?" Then
        '表示する
        Form2.Show vbModeless
        Exit Sub
    End If
    
    '▼デフォルトプリンタの変更画面を表示するか?
    If strCmdLine_1 = "/C" Or strCmdLine_1 = "/c" Then
        '表示する
        Form1.Show vbModal
        Exit Sub
    End If
    
    '▼デフォルトプリンタ名と引数の変更プリンタ名が同じなら
    ' 再度変更処置は行わない。※高速化、トラブル回避の為
    If strCmdLine_1 = Printer.DeviceName Then
        j = j + 1
        strOutputText(j) = _
            "SKIP  " & Format(Date, "YYYY/MM/DD") & _
                 " " & Format(Time(), "HH:MM:SS") & _
                 " " & strCmdLine_1
        GoTo Exit_Main:
    End If
    
    '▼パソコンにインストールしてあるプリンタ一覧の作成
    'プリンタの一覧作成
    i = -1
    For Each prtObj In Printers
        i = i + 1
        strPrintDeviceName(i) = prtObj.DeviceName
        strPrintDriverName(i) = prtObj.DriverName
        strPrintPort(i) = prtObj.Port
    Next
        
    '▼プリンタ名一覧のファイル出力
    If strCmdLine_1 = "/AL" Or strCmdLine_1 = "/al" Then
        '使用可能なファイル番号を出す
        lFileNo = FreeFile()
        ' ファイル名を作成します。
        Open strAppPath & CON_ALL_PRINTER_FILE For Output As #lFileNo
        
        For i = LBound(strPrintPort) To UBound(strPrintPort) - 1
            If strPrintPort(i) = vbNullString Then Exit For
            ' 文字列を出力します。
            Print #lFileNo, strPrintDeviceName(i) & "," & _
                            strPrintDriverName(i) & "," & _
                            strPrintPort(i)
        Next i
        ' ファイルを閉じます。
        Close #lFileNo
        GoTo Exit_Main:
    End If
    
    '▼デフォルト・プリンター名のファイル出力
    If strCmdLine_1 = "/DP" Or strCmdLine_1 = "/dp" Then
        '使用可能なファイル番号を出す
        lFileNo = FreeFile()
        ' ファイル名を作成します。
        Open strAppPath & CON_DEF_PRINTER_FILE For Output As #lFileNo
        ' 文字列を出力します。
        Print #lFileNo, Printer.DeviceName & "," & _
                        Printer.DriverName & "," & _
                        Printer.Port
        ' ファイルを閉じます。
        Close #lFileNo
        GoTo Exit_Main:
    End If
    
    '▼引数が一覧に存在するかのチェック
    bCheck = False
    For i = LBound(strPrintPort) To UBound(strPrintPort) - 1
        If strPrintDeviceName(i) = vbNullString Then Exit For
        If strPrintDeviceName(i) = strCmdLine_1 Then
            '一覧に合った。問題無し。
            bCheck = True
            Exit For
        End If
    Next i
    If bCheck = False Then
        '引数の記述が間違っている ?テスト済み
        MsgBox "引数のプリンター名が間違っています。" & vbCrLf & _
            "(" & strCmdLine_1 & ")", _
            vbOKOnly + vbDefaultButton1 + vbCritical + vbSystemModal, _
            CStr(App.EXEName) & " " & strVersion & " エラー"
        'エラーで処理を中断する
        GoTo Exit_Main:
    End If

    '▼アプリケーションの終了処理
    If strCmdLine_2 <> vbNullString Then
        j = j + 1
        strOutputText(j) = _
            "SET   " & Format(Date, "YYYY/MM/DD") & _
                 " " & Format(Time(), "HH:MM:SS") & _
                         " (" & strCmdLine(0) & ")"
    End If

    '▼デフォルト・プリンターを変更する
    gstrChangePrinterName = strPrintDeviceName(i)
    
    Dim osinfo      As OSVERSIONINFO
    Dim retvalue    As Integer

    osinfo.dwOSVersionInfoSize = 148
    osinfo.szCSDVersion = Space$(128)
    retvalue = GetVersionExA(osinfo)

    If osinfo.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
        ' Windows 95/98
        Call Win95SetDefaultPrinter
    Else
        ' This assumes that future versions of Windows
        ' use the NT method
        Call WinNTSetDefaultPrinter
    End If

Exit_Main:
    
    '▼アプリケーションの終了処理
    If strCmdLine_2 <> vbNullString Then
        
        On Error Resume Next
        
        j = j + 1
        strOutputText(j) = _
            "END   " & Format(Date, "YYYY/MM/DD") & _
                 " " & Format(Time(), "HH:MM:SS")
    
        '使用可能なファイル番号を出す
        lFileNo = FreeFile()
        ' ファイル名を作成します。
        Open strAppPath & strCmdLine_2 For Output As lFileNo
        ' 終了情報を出力します。
        For i = LBound(strOutputText) To UBound(strOutputText) - 1
            If strOutputText(i) = vbNullString Then Exit For
            Print #lFileNo, strOutputText(i)
        Next i
        ' ファイルを閉じます。
        Close #lFileNo
        
        '※このファイルの存在で当アプリが処理を終了したかの
        '※判断が出来る
    End If

    'アプリケーションの終了
    End

End Sub

Public Sub SelectPrinter(NewPrinter As String)
    Dim Prt     As Printer
    
    For Each Prt In Printers
        If Prt.DeviceName = NewPrinter Then
            Set Printer = Prt
        Exit For
        End If
    Next
End Sub

Public Function PtrCtoVbString(Add As Long) As String
    Dim sTemp   As String * 512
    Dim x       As Long

    x = lstrcpy(sTemp, Add)
    If (InStr(1, sTemp, Chr(0)) = 0) Then
         PtrCtoVbString = ""
    Else
         PtrCtoVbString = Left(sTemp, InStr(1, sTemp, Chr(0)) - 1)
    End If
End Function

Public Sub SetDefaultPrinter _
    (ByVal PrinterName As String, _
     ByVal DriverName As String, _
     ByVal PrinterPort As String)
    
    Dim DeviceLine  As String
    Dim r           As Long
    Dim l           As Long
    
    DeviceLine = PrinterName & "," & DriverName & "," & PrinterPort
    ' Store the new printer information in the [WINDOWS] section of
    ' the WIN.INI file for the DEVICE= item
    r = WriteProfileString("windows", "Device", DeviceLine)
    ' Cause all applications to reload the INI file:
    l = SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, "windows")
End Sub

Public Sub Win95SetDefaultPrinter()
    Dim Handle         As Long            'handle to printer
    Dim PrinterName As String
    Dim pd              As PRINTER_DEFAULTS
    Dim x               As Long
    Dim need         As Long            'bytes needed
    Dim pi5            As PRINTER_INFO_5  'your PRINTER_INFO structure
    Dim LastError   As Long

    ' determine which printer was selected
    PrinterName = gstrChangePrinterName
    ' none - exit
    If PrinterName = "" Then
        Exit Sub
    End If

    ' set the PRINTER_DEFAULTS members
    pd.pDatatype = 0&
    pd.DesiredAccess = PRINTER_ALL_ACCESS Or pd.DesiredAccess

    ' Get a handle to the printer
    x = OpenPrinter(PrinterName, Handle, pd)
    ' failed the open
    If x = False Then
        'error handler code goes here
        Exit Sub
    End If

    ' Make an initial call to GetPrinter, requesting Level 5
    ' (PRINTER_INFO_5) information, to determine how many bytes
    ' you need
    x = GetPrinter(Handle, 5, ByVal 0&, 0, need)
    ' don't want to check Err.LastDllError here - it's supposed
    ' to fail
    ' with a 122 - ERROR_INSUFFICIENT_BUFFER
    ' redim t as large as you need
    ReDim t((need \ 4)) As Long

    ' and call GetPrinter for keepers this time
    x = GetPrinter(Handle, 5, t(0), need, need)
    ' failed the GetPrinter
    If x = False Then
        'error handler code goes here
        Exit Sub
    End If

    ' set the members of the pi5 structure for use with SetPrinter.
    ' PtrCtoVbString copies the memory pointed at by the two string
    ' pointers contained in the t() array into a Visual Basic string.
    ' The other three elements are just DWORDS (long integers) and
    ' don't require any conversion
    pi5.pPrinterName = PtrCtoVbString(t(0))
    pi5.pPortName = PtrCtoVbString(t(1))
    pi5.Attributes = t(2)
    pi5.DeviceNotSelectedTimeout = t(3)
    pi5.TransmissionRetryTimeout = t(4)

    ' this is the critical flag that makes it the default printer
    pi5.Attributes = PRINTER_ATTRIBUTE_DEFAULT

    ' call SetPrinter to set it (Windows API)
    x = SetPrinter(Handle, 5, pi5, 0)

    If x = False Then   ' SetPrinter failed
         MsgBox "SetPrinter Failed. Error code: " & Err.LastDllError
         Exit Sub
    Else
         If Printer.DeviceName <> gstrChangePrinterName Then
         ' Make sure Printer object is set to the new printer
              Call SelectPrinter(gstrChangePrinterName)
         End If
    End If

    ' and close the handle (Windows API)
    ClosePrinter (Handle)
End Sub

Public Sub GetDriverAndPort _
        (ByVal Buffer As String, _
         DriverName As String, _
         PrinterPort As String)

    Dim iDriver As Integer
    Dim iPort   As Integer
    
    DriverName = ""
    PrinterPort = ""

    ' The driver name is first in the string terminated by a comma
    iDriver = InStr(Buffer, ",")
    If iDriver > 0 Then

        ' Strip out the driver name
        DriverName = Left(Buffer, iDriver - 1)

        ' The port name is the second entry after the driver name
        ' separated by commas.
        iPort = InStr(iDriver + 1, Buffer, ",")

        If iPort > 0 Then
            ' Strip out the port name
            PrinterPort = Mid(Buffer, iDriver + 1, _
            iPort - iDriver - 1)
        End If
    End If
End Sub

Public Sub ParseList(lstCtl As Control, _
                      ByVal Buffer As String)
    
    Dim i    As Integer
    Dim s   As String

    Do
        i = InStr(Buffer, Chr(0))
        If i > 0 Then
            s = Left(Buffer, i - 1)
            If Len(Trim(s)) Then lstCtl.AddItem s
            Buffer = Mid(Buffer, i + 1)
        Else
            If Len(Trim(Buffer)) Then lstCtl.AddItem Buffer
            Buffer = ""
        End If
    Loop While i > 0
End Sub

Public Sub WinNTSetDefaultPrinter()
    Dim Buffer      As String
    Dim DeviceName  As String
    Dim DriverName  As String
    Dim PrinterPort As String
    Dim PrinterName As String
    Dim r           As Long
    
    Buffer = Space(1024)
    PrinterName = gstrChangePrinterName
    r = GetProfileString("PrinterPorts", PrinterName, "", _
                          Buffer, Len(Buffer))

    ' Parse the driver name and port name out of the buffer
    Call GetDriverAndPort(Buffer, DriverName, PrinterPort)

    If DriverName <> "" And PrinterPort <> "" Then
        Call SetDefaultPrinter(gstrChangePrinterName, DriverName, PrinterPort)
        If Printer.DeviceName <> gstrChangePrinterName Then
        ' Make sure Printer object is set to the new printer
           SelectPrinter (gstrChangePrinterName)
        End If
    End If
End Sub

'****************************************************
'機能:VisualBasicプログラムのバージョン情報
'****************************************************
Public Function strVersion() As String
    With App
        strVersion = "v" & .Major & _
                     "." & .Minor & _
                     "." & .Revision
    End With
End Function

 


備考

  1. 当サンプルはメイン部分が実用的ではありません。Excel VBAを修正して下さい。
    [Alt]+[F11]キーを同時に押下するとVBA開発環境画面が表示されます。
  2. 動作確認は2つ
    1. WindowsXP(+SP3) + Office Excel 2003(+SP3) + Acrobat Pro 8.2.3
    2. Windows 98SE + Acrobat 4.0  ※プリンタの変更のみ
  3. 上記以外でも動作を確認した方はコメントを頂けると助かります。
  4. クラインパソコンだけでの使用でしたら、上記サンプルを参考で構いません。
    しかし、サーバーでの使用は並列稼動を阻止する必要があります。
    そこで AppオブジェクトLockメソッドUnlockメソッドを使用して、ロジックの同時走行を阻止する為の排他制御ロジックを入れて下さい。
    詳細は、LockメソッドUnlockメソッドを参照して下さい。
  5. パソコンのスペックや環境により変わると思いますが、デフォルトプリンタを変更するには4~6秒ほどの時間が掛かる場合があります。
  6. 詳細はダウンロードファイルの中の「ReadMe.txt」ファイルに書いています。
    必ず目を通して下さい」。

 

注意事項

  1. お決まり事ですが。
    当ロジックを使って生じたトラブル、責任、義務、その他の発生する事に関して、当サイトは一切を負いません。
    自分で動作確認をして、御使用下さい。
  2. WindowsAPI に関する質問は御遠慮下さい。
    ※難しすぎて返答出来ません。

 

TOPへ

コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です

CAPTCHA


出来るだけ早く返答する様には心がけています。
が、遅くなる時もありますのでご了承ください。


SAMURAI Plugin