| |
初心者さん、IROC さん、こんばんは。
ユーザーフォーム（Userform1）にイメージコントロール（Image1）とコマンドボタン
（Commandbutton1）があると想定しましょう。
まず、コピー&ペーストで画像が表示されているユーザーフォーム上のImageコントロールのみの処理ならば、
例えば、コマンドボタンのクリックイベントで、
'==========================================================
Private Sub CommandButton1_Click()
Call SavePicture(Image1.Picture, ThisWorkbook.Path & "\temp.gif")
ActiveSheet.Pictures.Insert ThisWorkbook.Path & "\temp.gif"
End Sub
なんてコードでイメージコントロールの内容をシートに表示する事は可能です
（このコードのあるマクロは一度保存してから実行して下さい。Thisworkbook.Path
を使用しているため・・）。
イメージコントロールの上にラベルが貼り付けてあるのならそれだけ新たにシート上に
作成しても良いかと思います（それの方が簡単だから）。
他の方法としては､ユーザーフォームに対してハードコピーをとって、シートに貼り付けた後、トリミングするという方法。
但し、ラベルは、イメージコントロールの中にあるという想定です。
Print Screenって、Sendkeysではできないんでしょうか？
仕方ないんで調べました。
ＡＰＩの細かいところは、
http://support.microsoft.com/default.aspx?scid=kb;en-us;240653
↑を参考にしました（というより、ほぼコピー）。
最初と同様に
ユーザーフォーム（Userform1）にイメージコントロール（Image1）とその中に収まるようなラベル（Label1）とコマンドボタン（Commandbutton1）があると想定しましょう。
標準モジュールに
'================================================================
Option Explicit
Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Declare Function GetVersionExA Lib "kernel32" _
(lpVersionInformation As OSVERSIONINFO) As Integer
Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Public Const KEYEVENTF_KEYUP = &H2
Public Const VK_SNAPSHOT = &H2C
Public Const VK_MENU = &H12
'============================================================
Sub main()
UserForm1.Show
End Sub
'Userform1のモジュールには、
'=============================================================
Dim blnAboveVer4 As Boolean
'=============================================================
Private Sub CommandButton1_Click()
Dim shp As Shape
If blnAboveVer4 Then
keybd_event VK_SNAPSHOT, 1, 0, 0
Else
keybd_event VK_MENU, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
End If
DoEvents
ActiveSheet.Select
Range("a1").Select
ActiveSheet.Paste
Call Trimming
End Sub
'=================================================================
Private Sub UserForm_Initialize()
Dim osinfo As OSVERSIONINFO
Dim retvalue As Integer
osinfo.dwOSVersionInfoSize = 148
osinfo.szCSDVersion = Space$(128)
retvalue = GetVersionExA(osinfo)
If osinfo.dwMajorVersion > 4 Then blnAboveVer4 = True
End Sub
'===================================================================
Sub Trimming()
With ActiveSheet
Set shp = .Shapes(.Shapes.Count)
With shp.PictureFormat
.CropTop = Image1.Top + 15.75
.CropLeft = Image1.Left
.CropRight = Me.Width - Image1.Left - Image1.Width
.CropBottom = Me.Height - Image1.Top - Image1.Height - 15.75
End With
End With
End Sub
mainを実行して、コマンドボタンをクリックしてみてください。
（イメージコントロールのPictureには予め画像データをセットして置いてください）
確認してみて下さい。
|
|
ichinose
- 04/9/28(火) 23:31 -
