Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


36121 / 76732 ←次へ | 前へ→

【45794】Re:エクセル
回答  Kein  - 07/1/14(日) 16:57 -

引用なし
パスワード
   ファイルを開く必要はありますが、アクティブシートのスナップショットを
画像ファイルに落として、ネットワーク越しに相手のマシンのルートフォルダーへ
送る。ということは出来ます。以下のマクロを標準モジュールの先頭から入れて
>WshShell.CurrentDirectory = "\\IBM\F"
を相手先に変更してから任意のシートを開き、実行して下さい。
作成されるファイル名は、"ExcelSt" & 現在の日時 & ".jpg" です。

Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Const KEYEVENTF_EXTENDEDKEY = &H1
Const KEYEVENTF_KEYUP = &H2
Const VK_SNAPSHOT = &H2C

Sub Mk_Excel_SShot()
  Dim WshShell As Object
  Dim DefP As String, DvN As String, XLSc As String
 
  Set WshShell = CreateObject("WScript.Shell")
  On Error Resume Next
  WshShell.CurrentDirectory = "\\IBM\F"
  If Err.Number <> 0 Then
   MsgBox "コピー先PCがLANに接続されていません", 48
   Set WshShell = Nothing: Exit Sub
  Else
   MsgBox "アクティブウィンドウのスナップショットを" & _
   vbLf & "画像ファイルにして送ります。", 64
  End If
  On Error GoTo 0
  With Application
   .ScreenUpdating = False
   .DisplayAlerts = False
  End With
  Call keybd_event(VK_SNAPSHOT, 0, 0, 0)
  DoEvents
  Call keybd_event(VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0)
  DoEvents
  With Application
   If IsError(.Match(xlClipboardFormatBitmap, _
   .ClipboardFormats, 0)) Then
     MsgBox "スクリーンショットは失敗しました", 48: GoTo ELine
   End If
  End With
  XLSc = WshShell.CurrentDirectory & "\ExcelSt" & _
  Format(Now(), "yymmdd_hhmm") & ".jpg"
  With Charts.Add
   .Paste
   .Export XLSc, "JPEG"
   .Delete
  End With
ELine:
  With Application
   .CutCopyMode = False
   .DisplayAlerts = True
   .ScreenUpdating = True
   DefP = .DefaultFilePath
  End With
  DvN = Left$(DefP, InStr(1, DefP, "\")): ChDrive DvN
  WshShell.CurrentDirectory = DefP: Set WshShell = Nothing
End Sub

1 hits

【45784】エクセル kyuzou 07/1/14(日) 11:31 質問
【45785】Re:エクセル ぱっせんじゃー 07/1/14(日) 11:36 発言
【45786】Re:エクセル kyuzou 07/1/14(日) 12:24 回答
【45787】Re:エクセル ぱっせんじゃー 07/1/14(日) 12:37 発言
【45788】Re:エクセル ぱっせんじゃー 07/1/14(日) 12:39 発言
【45789】Re:エクセル kyuzou 07/1/14(日) 12:59 お礼
【45790】Re:エクセル ぱっせんじゃー 07/1/14(日) 13:21 発言
【45791】Re:エクセル ぱっせんじゃー 07/1/14(日) 13:22 発言
【45794】Re:エクセル Kein 07/1/14(日) 16:57 回答

36121 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free