| |
>提案して頂いた件について：隠しシートに描画するとの事ですが、描画
>の過程を見せるというのを抜きにして、保存＞表示という事でしょうか？
シートに描画しているのを見せないという事です。見せたくないでしょう。
描画したものをユーザーフォームへ表示もできますし、保存も出来ます。
エクセルをつかうからには図形描画で絵を描いたほうが非常に簡単で何でも出来ます。
apiで描くのは大変でしょう。
>余談ですが、メッセージ系の処理っていうのは、本当に難しいですね。
>(100回以上、Excelを落としてしまいまいた。）Debug.Printでしか動作確認
>ができないんですね。
モードレスのユーザーフォームでメッセージフックは難しいと思います。
コツがわからないとすぐ落ちますから。
>私のようなアプリ系のソフトを作るのは本当はVBの方がいいんですよね？
場合によると思います。
エクセルの描画やデータベースの機能を使いこなせば楽にアプリが作成できます。
(始めから機能が備わっているので)
それで提案した方法で簡単なサンプルを作ってみました。
ユーザーフォームに
Image1
CommandButton1
CommandButton2
CommandButton3
を配置して以下をお試しください。
'標準モジュール
Option Explicit
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type UPICDESC
Size As Long
Type As Long
hPic As Long
hPal As Long
Reserved As Long
End Type
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (picdesc As UPICDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hmf As Long) As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function CopyImage Lib "user32" (ByVal Handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Const CF_ENHMETAFILE = 14
Const PICTYPE_ENHMETAFILE = 4
Const CF_BITMAP = 2 '=xlBitmap
Const PICTYPE_BITMAP = 1
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = 4
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
'GetPictureメソッド クリップボードの画像オブジェクトを得る
Public Function GetPicture(ByVal Format As XlCopyPictureFormat) As IPicture
Dim Handle&, desc As UPICDESC, id As GUID
If OpenClipboard(0&) > 0 Then
If Format = xlBitmap Then
Handle = CopyImage(GetClipboardData(CF_BITMAP), IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
Handle = CopyEnhMetaFile(GetClipboardData(CF_ENHMETAFILE), vbNullString)
End If
CloseClipboard
End If
If Handle = 0 Then Exit Function 'イメージ取得失敗
IIDFromString StrConv("{7BF80981-BF32-101A-8BBB-00AA00300CAB}", vbUnicode), id
With desc
.Size = Len(desc)
.Type = IIf(Format = xlBitmap, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
.hPic = Handle
End With
'Pictureオブジェクトを作成
OleCreatePictureIndirect desc, id, 1, GetPicture
If GetPicture Is Nothing Then
If Format = xlBitmap Then DeleteObject Handle Else DeleteEnhMetaFile Handle
End If
End Function
'作業シート(非表示)を取得
Function SheetTemp() As Worksheet
Const TNAME = "SheetTemp"
With ThisWorkbook.Worksheets
On Error Resume Next
Set SheetTemp = .Item(TNAME)
On Error GoTo 0
If SheetTemp Is Nothing Then '無ければ作成
Set SheetTemp = .Add
SheetTemp.Name = TNAME
SheetTemp.Visible = xlSheetVeryHidden
End If
End With
End Function
'↑標準モジュールここまで
'ユーザーフォームモジュール
Option Explicit
'描画例 放射線上に円を書く
Private Sub CommandButton1_Click()
Dim pi#, tmp As Worksheet, ch As Chart, ii&, xl&, yl&, x0&, y0&, rr&
xl = 200: yl = 200 '描画サイズ(横及び縦) ポイント単位
rr = 100 '半径
pi = WorksheetFunction.pi
Set tmp = SheetTemp
tmp.DrawingObjects.Delete
Set ch = tmp.ChartObjects.Add(0, 0, xl, yl).Chart
With ch
.ChartArea.Border.LineStyle = 0
x0 = .ChartArea.Width / 2: y0 = .ChartArea.Height / 2
For ii = 1 To 360
With .Shapes.AddLine(x0, y0, x0 + (rr * Sin(ii * pi / 180)), y0 - (rr * Cos(ii * pi / 180)))
.Line.ForeColor.RGB = vbRed
End With
Next
End With
ch.CopyPicture xlScreen, xlBitmap, xlScreen
Set Image1.Picture = GetPicture(xlBitmap)
tmp.DrawingObjects.Delete
tmp.Parent.Saved = True
End Sub
'bmp保存
Private Sub CommandButton2_Click()
SavePicture Image1.Picture, ThisWorkbook.Path & "\test1.bmp"
End Sub
'閉じる
Private Sub CommandButton3_Click()
Unload Me
End Sub
Private Sub UserForm_Initialize()
Image1.BorderStyle = fmBorderStyleNone
Image1.PictureSizeMode = fmPictureSizeModeZoom
CommandButton1.Caption = "描画"
CommandButton2.Caption = "保存"
CommandButton3.Caption = "閉じる"
End Sub
|
|
yuu1
- 08/3/18(火) 12:55 -
