• 締切済み

Execl VBA UserForm1の印刷先

Execl VBA UserForm1の印刷先を変更したいのですが Execl VBAで困っています。 UserFormの印刷を条件を変えてプリンター１とプリンター２に振り分けたいのですが ネットを検索してもいい方法が見つかりません。 UserFormはOSのプリンターを参照するため思うように印刷できません。 一度下記を試しましたが、試通常使うプリンターでしか印刷出来ません UserFormのプリンター切替方法のご伝授宜しくお願い致します。 =========================================== Sub チェンジプリンター() Dim myPrinter As String myPrinter = Application.ActivePrinter '現在のプリンターを記憶 If Worksheets("DeviceRead-Write").Cells(6, 11).Value = 2 Then 'Ｉ６が２ならEPSON_2プリンターに印刷する Application.ActivePrinter = "EPSON_2 on Ne02:" 'プリンターを切り替える Range("A4").Value = Application.ActivePrinter 'プリンターの確認 UserForm1.PrintForm 'フォームの印刷 Application.ActivePrinter = myPrinter 'プリンターを元に戻す Range("A2").Value = Application.ActivePrinter 'プリンターの確認 End If If Worksheets("DeviceRead-Write").Cells(6, 11).Value = 1 Then 'Ｉ６が２ならEPSON_1プリンターに印刷する Range("D2").Value = Application.ActivePrinter 'プリンターの確認 UserForm1.PrintForm 'フォームの印刷 End If End Sub

  • mgm_0
  • お礼率71% (5/7)

みんなの回答

  • queuerev2
  • ベストアンサー率78% (96/122)
回答No.1

質問者様のコードでうまくいきそうに思えたのでやってみましたがやっぱりだめでした。 試してみた範囲では、どうやらVBEのプリンタ設定が使われているようです。 (Excel2007, Windows XP) VBEのプリンタ設定をVBAから変更する方法ですが、探した範囲では見つかりませんでした。 そうなると、思いつくのはSendKeysでVBEを無理やり操作する方法や、画面キャプチャで代用する方法などです。 いずれもかなり複雑になりそうで安定性にも不安がありますのであまりおすすめできませんが、ご要望があれば検討してみます。

mgm_0
質問者

お礼

ご意見ありがとうございます。 どうも、ＶＢでレジストリーをいじらないとだめみたいですね。 アクティブシートを保護し触れないようにして印刷します。

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. オフィス系ソフト

関連するQ&A

  • EXECL　VBAにて自動印刷１００枚でフリーズ

    フィリーズの原因 とりあえず、アクティブプリンターのみで印刷を連続すると異常なし 交互に印刷すると今度はリソース不足が出ました。 最後に、EPSON LPプリンターのみに連続印刷でやはりリソース不足が出ました。 どうもアクティブプリンターからの切替でリソースを必要としているみたいですが 対策はをご教示下さい。 ======================================== Sub チェンジプリンター() '印刷切り替え Dim myPrinter As String myPrinter = Application.ActivePrinter '現在のプリンターを記憶 If Worksheets("DeviceRead-Write").Cells(6, 13).Value = 2 Then 'I6が２ならEPSON_2プリンターに印刷する Application.ActivePrinter = "EPSON_2 on Ne00:" 'プリンターを切り替える ActiveSheet.PrintOut 'シートFormの印刷 Application.ActivePrinter = myPrinter 'プリンターを元に戻す End If If Worksheets("DeviceRead-Write").Cells(6, 13).Value = 1 Then 'I6が1ならEPSON LPプリンターに印刷する ActiveSheet.PrintOut 'シートFormの印刷 End If End Sub ==========================================

  • EXECL　VBAにて自動印刷１００枚でフリーズ

    非常に困っています。 VBAにてシーケンサからのデータを印刷するプログラムでシーケンサのトリガーで 印刷をしています。 シーケンサのデータは５秒に１回５１２点のデータを読み込み １番目が印刷命令だと印刷すると言った具合ですが、 何度シミュレーションしても１０５～１１０枚印刷するとフィリーズします。 何が影響しているかイベントビュワー等解析しても分からず困っています。 ご教示願います。 ==================================== Private Sub Auto_Open() 一定時間周期でプロシージャー実行 End Sub Sub 一定時間周期でプロシージャー実行() myReserveTime = Now + TimeValue("00:00:5") Application.OnTime EarliestTime:=myReserveTime, Procedure:="一定時間周期でプロシージャー実行" ActiveWorkbook.Worksheets("form").Activate 'シートformをアクティブにする データ読み込み チェンジプリンター End Sub 'すべての変数を明示的に宣言するようにします。 Sub データ読み込み() Dim wRet As Long '戻り値　wRetは長整数型を宣言する Dim wdata(513) As Long 'Integer '読み出したデバイス値 Dim wcnt As Integer 'ワークカウンタ Dim iRet As Long '戻り値　iRetは長整数型を宣言する Dim idata(1) As Integer '書き込むデバイス値 Dim szData As String 'デバイス名 On Error GoTo Error 'エラー処理ルーチン先設定 '論理局番をActUtlTypeコントロールのプロパティに設定する。 Worksheets("DeviceRead-Write").ActUtlType1.ActLogicalStationNumber = 1 '論理局番１を指定 '通信回線１をオープンする。 wRet = Worksheets("DeviceRead-Write").ActUtlType1.Open() '異常終了の場合 ' If (wRet <> 0) Then 'エラーコードに対応したトラブルシュートメッセージを表示する。 ' ErrorViewMessage (wRet) ' Exit Sub 'VBA終了する ' End If '---------------------D10000～読み出し----------------------------- 'D10000-D10511を読み出し、セルに表示する。 'シーケンサからデバイス値を読み出す。 wRet = Worksheets("DeviceRead-Write").ActUtlType1.ReadDeviceBlock("D10000", 512, wdata(0)) 'D10000～取込点数を指定(512) '読み出し成功の場合 If (wRet = 0) Then '正常終了の場合 With Worksheets("DeviceRead-Write") '読み出したデバイス値をセルに設定する。 For wcnt = 0 To 511 .Cells(6 + wcnt, 4).Value = wdata(wcnt) 'セルD6～D6+512まで繰り返す Next wcnt End With Else '読み出し失敗の場合 'エラーコードに対応したトラブルシュートメッセージを表示する。 ' ErrorViewMessage (wRet) End If '=====================D10001～書込===================================== 'PLC　D10002　に印刷命令を返す 'PLC　D10001　に　D10000の値を返す。セルにも表示する。 'M6(D10000) のセルデータをシーケンサデバイス(D10002)に書き込む。 'セルのデータを書き込むデバイス値(idata)に格納する。 With Worksheets("DeviceRead-Write") idata(1) = CInt(.Cells(6, 4).Value) End With 'シーケンサデバイスに値を書き込む。 szData = "D10001" & vbLf iRet = Worksheets("DeviceRead-Write").ActUtlType1.WriteDeviceRandom2(szData, 1, idata(1)) '==================== D10001～書込終了 ================================== '機種G,生産区分,納入先データ代入 Worksheets("DeviceRead-Write").Range("N28").Value = Worksheets("DeviceRead-Write").Range("M28").Value Worksheets("DeviceRead-Write").Range("N33").Value = Worksheets("DeviceRead-Write").Range("L33").Value Worksheets("DeviceRead-Write").Range("N36").Value = Worksheets("DeviceRead-Write").Range("L36").Value '---------------------D10000～読み出し終了----------------------------- '回線のクローズを行なう。 wRet = Worksheets("DeviceRead-Write").ActUtlType1.Close() Exit Sub Error: '例外処理 '回線のクローズを行なう。 wRet = Worksheets("DeviceRead-Write").ActUtlType1.Close() 'エラーを表示する。 ' MsgBox Error$(Err), vbCritical End End Sub Sub チェンジプリンター() '印刷切り替え Dim myPrinter As String myPrinter = Application.ActivePrinter '現在のプリンターを記憶 If Worksheets("DeviceRead-Write").Cells(6, 13).Value = 2 Then 'Ｉ６が２ならEPSON_2プリンターに印刷する（Ｄ１００００上位２ビットが２） Application.ActivePrinter = "EPSON_2 on Ne00:" 'プリンターを切り替える ActiveSheet.PrintOut 'シートFormの印刷 Application.ActivePrinter = myPrinter 'プリンターを元に戻す End If If Worksheets("DeviceRead-Write").Cells(6, 13).Value = 1 Then 'Ｉ６が1ならEPSON LPプリンターに印刷する（Ｄ１００００上位２ビットが１） ActiveSheet.PrintOut 'シートFormの印刷 End If End Sub

  • エクセルVBAでPDFを1枚目のみ印刷したい

    下記のVBAに複数PDFが重なっている場合は、一枚目のみ印刷する文面を 挿入したいのですがうまくいきません Sub Test() Dim z As Object Dim i As Long Dim f, p As String Application.ScreenUpdating = False Set z = CreateObject("WScript.Shell") p = Application.ActivePrinter For i = 1 To Range("A1").End(xlDown).Row f = "h:\hozei\" & Cells(i, 1).Value & ".pdf" If Dir(f) <> "" Then z.Run ("AcroRd32.exe /t " & f) Else Cells(i, 2).Value = Cells(i, 1).Value Cells(i, 1).Value = "" End If Next i Set z = Nothing End Sub お忙しいところ申し訳ございません どなたかご教示願います。

  • 印刷後のVBAの実行　(3)

    Private Sub Workbook_BeforePrint(Cancel As Boolean) If ActiveSheet.Name = "Sheet1" Then If Range("D6").Value = "" Then Cancel = True MsgBox ("名前を入力してください") Range("D6").Select Exit Sub End If Else If ActiveSheet.Name = "Sheet2" Then If Range("C11").Value = "" Then Cancel = True MsgBox ("受付時間を入力してください") Range("C11").Select Exit Sub End If Else Exit Sub End If End If If Worksheets("Sheet1").Range("D5") = "不要" Then GoTo P1 ActiveSheet.Range("A70:Y70").Copy If Worksheets("Sheet3").Range("A1").Value = "" Then Worksheets("Sheet3").Range("A1").PasteSpecial Paste:=xlPasteValues Else Worksheets("Sheet3").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial _ Paste:=xlPasteValues End If Application.CutCopyMode = False P1: ActiveSheet.Range("A1").Select End Sub sheet1のD5に「不要」と入っていたら 24～33行目の作業がキャンセルになりますが sheet2のD5にも「不要」と入っていたら、同じ様にキャンセルできる様に出来ますでしょうか？ ご回答お願いします

  • Userform内のFrameのCaptionが印刷できないのですが

    VBAでUserFormを印刷しようとしたのですが、UserForm内のFrameのCaptionのみ印刷されません。その他Frameの枠とかUserForm内のLabelとかは印刷できるのですが、何か設定等あるのでしょうか？一応UserForm内にCommandButtonを作りクリックで印刷させようと考えているのですが、ちなみにコードは Private Sub CommandButton1_Click() Userform1.Printform End Sub としています。なにか方法があれば教えてもらえないでしょうか。よろしくお願いします。

  • vbaプログラミングについて教えてください。

    vba初心者です。下記のようにプログラミングしましたがもっといいプログラムの仕方はないでしょうか。ちょっとごちゃごちゃしていて見にくいです。どなかたお力をお貸しください。 Private Sub データUPDATE輸入_Click() ActiveSheet.Unprotect Dim Line As String Dim Maxrow As String Sheets("Invoice").Select Line = 5 　 Do Until Cells(Line, 7).Value = "" On Error Resume Next 'A列の空欄をコピーして埋める If Cells(5, 1).Value = "" Then Cells(Line, 1).Value = "" ElseIf Cells(Line, 1).Value = "" Then Cells(Line, 1).Value = Cells(Line - 1, 1).Value End If 'B列の空欄をコピーして埋める If Cells(5, 2).Value = "" Then Cells(Line, 2).Value = "" ElseIf Cells(Line, 2).Value = "" Then Cells(Line, 2).Value = Cells(Line - 1, 2).Value End If 'C列の空欄をコピーして埋める If Cells(5, 3).Value = "" Then Cells(Line, 3).Value = "" ElseIf Cells(Line, 3).Value = "" Then Cells(Line, 3).Value = Cells(Line - 1, 3).Value End If 'D列の空欄をコピーして埋める If Cells(5, 4).Value = "" Then Cells(Line, 4).Value = "" ElseIf Cells(Line, 4).Value = "" Then Cells(Line, 4).Value = Cells(Line - 1, 4).Value End If 'E列の文字を「輸入シート」から検索しF列に貼り付ける If Cells(Line, 5).Value = "" Then Cells(Line, 5).Value = Cells(Line - 1, 5).Value End If Cells(Line, 6).Value = Application.WorksheetFunction.VLookup(Cells(Line, 5).Value, Worksheets("輸入Parts").Range("A2:R20000"), 2, 0) 'E列を検索しデータが存在しない場合はF列に「データがありません」を表記 If Cells(Line, 6).Value = "" Then Cells(Line, 6).Value = "データがありません" GoTo コピー貼り付け End If コピー貼り付け: If Cells(Line, 6).Value = "データがありません" Then Cells(Line, 5).Copy 'コピーする Maxrow = Worksheets("輸入Parts").Range("A1").End(xlDown).Row + 1 Worksheets("輸入Parts").Range("A" & Maxrow).PasteSpecial Paste:=xlPasteValues '値を貼り付け End If 'H列の空欄をコピーして埋める If Cells(5, 12).Value = "" Then Cells(Line, 12).Value = "" ElseIf Cells(Line, 12).Value = "" Then Cells(Line, 12).Value = Cells(Line - 1, 12).Value End If 'E列の文字を「輸入シート」から検索しZ列に貼り付ける Cells(Line, 26).Value = Application.WorksheetFunction.VLookup(Cells(Line, 5).Value, Worksheets("輸入Parts").Range("A2:R20000"), 3, 0) 'E列を検索しデータが存在しない場合はZ列に「データがありません」を表記 If Cells(Line, 26).Value = "" Then Cells(Line, 26).Value = "データがありません" End If 'AD列の空欄をコピーして埋める If Cells(5, 30).Value = "" Then Cells(Line, 30).Value = "" ElseIf Cells(Line, 30).Value = "" Then Cells(Line, 30).Value = Cells(Line - 1, 30).Value End If 'E列の文字を「輸入シート」から検索しAM列に貼り付ける Cells(Line, 39).Value = Application.WorksheetFunction.VLookup(Cells(Line, 5).Value, Worksheets("輸入Parts").Range("A2:R20000"), 18, 0) 'E列を検索しデータが存在しない場合はAM列に「データがありません」を表記 If Cells(Line, 39).Value = "" Then Cells(Line, 39).Value = "データがありません" End If '「Unit price」の計算・円建と外貨建が合わさったインボイスの場合の合計金額 If Cells(Line, 14).Value = "" Then Cells(Line, 13).Value = Cells(Line, 17).Value * Cells(Line, 33).Value / Cells(Line, 7).Value Else Cells(Line, 17).Value = Application.WorksheetFunction.RoundDown(Cells(Line, 14).Value * Cells(Line, 16), 0) Cells(Line, 15).Value = Cells(Line, 16).Value * Cells(Line, 33).Value / Cells(Line, 7).Value End If 'T.Invoice Priceの計算 Cells(Line, 23).Value = Application.WorksheetFunction.Sum(Cells(Line, 17), Cells(Line, 18), Cells(Line, 19), Cells(Line, 20), Cells(Line, 21), Cells(Line, 22)) 'VLOOKUP関数が終わり、エラーが発生したら止まる On Error GoTo 0 '次の行に移り最後の行まで検索 Line = Line + 1 Loop End Sub

  • ２つのVBAを組み合わせる方法

    お世話になります、２つのVBAを組み合わせる方法で迷っています。 １つ目が Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long, k As Long, myNum As Long If Intersect(Target, Range("C1,B9:B39")) Is Nothing Or Target.Count > 1 Then Exit Sub Application.EnableEvents = False With Target If .Column = 3 Then myNum = WorksheetFunction.Max(Range("B9:B39")) If IsDate(.Value) Then For i = 9 To 39 If Cells(i, "A").Value = "" Then Cells(i, "B").Value = "" Else Cells(i, "B") = myNum + i - 8 End If Next i End If Else i = .Row If .Value = "" Then Range(Cells(i + 1, "B"), Cells(39, "B")).ClearContents Else For k = i + 1 To 39 If Cells(k, "A").Value = "" Then Cells(k, "B").Value = "" Else Cells(k, "B") = Cells(k - 1, "B") + 1 End If Next k End If End If End With Application.EnableEvents = True End Sub です。 ２つめが Private Sub Worksheet_Change(ByVal Target As Range)　 Application.EnableEvents = True If Intersect(Target, Range("R8:R38")) Is Nothing Then Exit Sub Application.EnableEvents = False Range(Cells(Target.Row, 18), Cells(39, 18)).Value = Target.Value Application.EnableEvents = True End Sub です。２つのPrivate Sub Worksheet_Change(ByVal Target As Range)イベントのVBAですが、どのようにして組み合わせれば良いのでしょうか？

  • エクセル　マクロ　ファイルの再起動

    ネットワークプリンター２台にワークシートを出力するコードで悩んでいます。 下記のコードを繰り返すと１１０枚前後でリソース不足が発生することが分かりました。 保存しないで終了し再度開くとリセットされることも分かりました。 保存しないで終了は出来るのですが、同じファイルを再度開くことはマクロで出来ますか？ 宜しくお願い致します。 =================================== '全ての Book を保存しないで閉じる '最後に Excel も終了する Sub excel_Quit() Dim w As Workbook '全ての Book を保存したことにする (保存はしない) For Each w In Workbooks w.Saved = True Next 'Excel を終了する Application.Quit 'Book を閉じる ThisWorkbook.Close False End Sub ============================== Sub チェンジプリンター() '印刷切り替え処理 If Worksheets("DeviceRead-Write").Cells(6, 13).Value = 1 Then 'I6 が1ならEPSON_Aに印刷する(D10000上位2ビットが１) プリンターA出力 ElseIf Worksheets("DeviceRead-Write").Cells(6, 13).Value = 2 Then 'I6 が1ならEPSON_Bに印刷する(D10000上位2ビットが２) プリンターB出力 Else DoEvents End If End Sub Sub プリンターA出力(): 'プリンターAに印刷 Application.ActivePrinter = "EPSON_A on Ne01:" 'プリンターAを指定 Worksheets("form").PrintOut 'シートFormの印刷 Exit Sub End Sub Sub プリンターB出力(): 'プリンターBに印刷 Application.ActivePrinter = "EPSON_B on Ne00:" 'プリンターBを指定 Worksheets("form").PrintOut 'シートFormの印刷 Exit Sub End Sub

  • VBA　リストボックスについて

    VBA初心者です。どうぞよろしくお願いします。 ユーザーフォームにタブつきのリストボックスを作りたいと思っています。 リストはsheet1の中にあります。 　　A　　　　B　　　　C　　　　D・・・ 1　　NO　　品名　　売場 2　　1　　いちご　　果物 3　　2　　みかん　　果物 4　　3　　もも　　　　果物 5　　4　　ハクサイ　野菜 6　　5　　キャベツ 　野菜 7　　6　　きゅうり　　野菜 8　　7 9 果物のタブには、果物の品名が表示される。 1 いちご 2 みかん 3 もも 野菜のタブには、野菜の品名が表示される。 4 ハクサイ 5 キャベツ 6 きゅうり 青果のタブには、果物、野菜が表示される。 1 いちご 2 みかん 3 もも 4 ハクサイ 5 キャベツ 6 きゅうり 本を見ながら格闘しておりますが、きっと的違いで滅茶苦茶なことをしているのだと思います。 どうにも出来ず困っております。どなたか教えていただけないでしょうか。よろしくお願いします。 Private Sub UserForm_Initialize() Dim LastRow As Long Dim i As Integer Dim ListBoxNo As Integer Dim ListBox As Control Dim Listtabu(3) As Long 'タブの数 For i = 1 To 3 Listtabu(i) = 0 Next i Worksheets("sheet1").Activate With Worksheets("sheet1") LastRow = .Range("A65536").End(xlUp).Row For i = 2 To LastRow If Worksheets("sheet1").Range(Cells(i, 3)) = "果物" Then ListBoxNo = 1 Set ListBox = 果物 果物.List = Worksheets("sheet1").Range(Cells(i, 1), Cells(i, 2)).Value End If If Worksheets("sheet1").Range(Cells(i, 3)) = "野菜" Then ListBoxNo = 2 Set ListBox = 野菜 野菜.List = Worksheets("sheet1").Range(Cells(i, 1), Cells(i, 2)).Value End If If Worksheets("sheet1").Range(Cells(i, 3)) = "果物" & "野菜" Then ListBoxNo = 3 Set ListBox = 青果 青果.List = Worksheets("sheet1").Range(Cells(i, 1), Cells(i, 2)).Value End If ListBox.AddItem ListBox.List(Listtabu(LstBxNo), 0) = Worksheets("sheet1").Cells(i, 1).Value ListBox.List(Listtabu(LstBxNo), 1) = Worksheets("sheet1").Cells(i, 2).Value Listtabu(LstBxNo) = Listtabu(LstBxNo) + 1 Next End With End Sub

  • 印刷後のVBAの実行　(2)

    Private Sub Workbook_BeforePrint(Cancel As Boolean) 　　If ActiveSheet.Name = "Sheet1" Then 　　　　If Range("D6").Value = "" Then 　　　　　　Cancel = True 　　　　　　MsgBox ("名前を入力してください") 　　　　　　Range("D6").Select 　　　　　　Exit Sub 　　　　End If 　　Else 　　　　If ActiveSheet.Name = "Sheet2" Then 　　　　　　If Range("C11").Value = "" Then 　　　　　　　　Cancel = True 　　　　　　　　MsgBox ("受付時間を入力してください") 　　　　　　　　Range("C11").Select 　　　　　　　　Exit Sub 　　　　　　End If 　　　　Else 　　　　　　 　　　　　　Exit Sub 　　　　End If 　　End If 　　ActiveSheet.Range("A70:Y70").Copy 　　If Worksheets("Sheet3").Range("A1").Value = "" Then 　　　　Worksheets("Sheet3").Range("A1").PasteSpecial Paste:=xlPasteValues 　　Else 　　　　Worksheets("Sheet3").Range("A65536").End(xlUp).Offset(1, 0).PasteSpecial _ 　　　　　　Paste:=xlPasteValues 　　End If 　　Application.CutCopyMode = False 　　ActiveSheet.Range("A1").Select End Sub 先日、上記のコードを回答者の方から教えてもらい、とても助かっていますが sheet1のD5に「不要」という文字が入っていた場合、 sheet3への貼り付け(23～30行目の作業)をキャンセルして、最後にsheet1のA1を選択するようにはどの様にしたらいいでしょうか?

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する