| |
ichinose 様
いつも回答ありがとうございます。
>では、bykinさんの
>
>http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=5437;id=excel
>
>これを参考にしてjpgに落としてみる方法はいかがですか？
>例では、セルをjpgに保存していますが、ちょっと応用をきかして
>Pictureでも出来ましたよ！！
>
bykinさんには、当質問でも初めにレスを付けていただきましたし、上記内容も有難く参考にいたします。ただ、別件の作業が忙しく、検証には少し時間がかかってしまいそうです。
>遅くなってしまったので見ていないかもしれませんが、
>もし気が付いたら、試してみてください。
現プロジェクトに参考になるものはないか流し読みをしていたら、自分宛の回答が付いていたので驚きました。（もう回答は無いだろうなと思っていました）いつも質問者の勝手なお願いに、丁寧に最後まで対応して頂き、大変感謝しています。
−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−−
前回のコメントで画像の直貼操作で調整するとし以下のリスト作りましたが、
表示位置がズレる、拡縮した画像がぼやける、スクロールに連動しない（スクロールイベントが無い）、相対参照にするとエラーなど、不満爆発、これらを調整していくと時間が掛りそうで、作業保留としながらも悩んでいました。今回、新たな情報を得ましたのでまた考え直してみます。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 3 Then
Application.ScreenUpdating = False
Macro1
Application.ScreenUpdating = True
End If
End Sub
Sub Macro1()
A_W = ActiveWindow.Width
A_H = ActiveWindow.Height
R = ActiveCell.Row
C = ActiveCell.Column
j = ActiveSheet.Cells(R, 1).Value
'左上のセル情報取得(スクロールに対応するため）
Cell_Text = Application.Evaluate("=INFO(""origin"")")
Cell_len = Len(Cell_Text)
Cell_Add = Mid(Cell_Text, 4, Cell_len - 3)
OC_L = Range(Cell_Add).Left
OC_T = Range(Cell_Add).Top
Select Case j
Case 1, 2, 3: P_Name = "Picture " & j
Case Else: Exit Sub
End Select
With ActiveSheet
k = .DrawingObjects.Count
If k > 1 Then .DrawingObjects(k).Delete
End With
Sheets("Sheet2").Select
ActiveSheet.Shapes(P_Name).Select
Selection.Copy
Sheets("Sheet3").Select
With ActiveSheet
.Paste
.DrawingObjects(2).Select
End With
'画面サイズ変更時の表示画像サイズ補正
With Selection.ShapeRange
.LockAspectRatio = msoTrue
.Height = .Height * (100 / ActiveWindow.Zoom) ^ 0.5
.Width = .Width * (100 / ActiveWindow.Zoom) ^ 0.5
End With
'画面サイズ変更時の表示画像位置補正
With Selection.ShapeRange
.Left = (A_W - 44 + OC_L) * 100 / ActiveWindow.Zoom - .Width
.Top = (A_H - 55 + OC_T) * 100 / ActiveWindow.Zoom - .Height
End With
ActiveSheet.Cells(R, C).Select
End Sub
|
|
わいわい
- 06/7/13(木) 13:31 -
