VBAにGDI+を参照させる方法

質問

VBAの参照設定でSystem.Drawing.dllクラスを参照設定させると、設定できませんと出ます。
VBAではグラフィック操作を行うことはできないのでしょうか。ユーザーフォームに数値目盛りを描きたいとおもっています。どなか分かる方ご教授願います。

回答No.3

mitarashi · ベストアンサー

#2です。
煩雑なので、API宣言はPublicにして標準モジュールに置く事にします。
C言語ならヘッダーファイルに持っている情報をVBAでは自前で宣言してやる必要がありますので、面倒くさいです。

Public Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

Public Type PICTDESC
cbSizeofstruct As Long
picType As Long
hbitmap As Long
hpal As Long
unused_wmf_yExt As Long
End Type

Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public Type POINTAPI
x As Long
y As Long
End Type

Public Type LOGPEN
lopnStyle As Long
lopnWidth As POINTAPI
lopnColor As Long
End Type

Public Const PICTYPE_BITMAP = 1
Public Const SRCCOPY = &HCC0020

Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, _
ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hdc As Long, ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreatePenIndirect Lib "gdi32" (lpLogPen As LOGPEN) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Public Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Public Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Public Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As Any) As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32" _
(lpPictDesc As PICTDESC, riid As GUID, _
ByVal fOwn As Long, lplpvObj As Object) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hgdiobj As Long) As Long
Public Declare Function WindowFromAccessibleObject Lib "oleacc.dll" _
(ByVal IAcessible As Object, ByRef hWnd As Long) As Long

回答No.2

mitarashi

昔作成したのをアレンジしてみました。
GDI+でなくて、GDIを使います。というか、WindowsAPIですが。
APIでUserFormに描画する場合、ウィンドウが隠れると描画したものが消えてしまうという問題があります。Windowsの再描画のメッセージをキャッチして、自前で再描画させる方法もありますが、VBAでは処理速度が追いつかない等課題があります。ここではPictureに変換して書き戻すことで、Pictureの再描画の機能を利用しています。コマンドボタン等もひっくるめて絵になってしまう訳ですが、少し試した限りでは問題なく動作する様です。
UserFormモジュールに記述します。APIの宣言は別途投稿します。

Private Sub UserForm_activate()
Dim pic As StdPicture
Dim rc As RECT
Dim hwndForm As Long
Dim hdcForm As Long
Dim hdc As Long
Dim hbmp As Long
Dim hbmpOld As Long
Dim hNewPen As Long
Dim hOldPen As Long
Dim NewPen As LOGPEN

WindowFromAccessibleObject Me, hwndForm
Me.Repaint
GetClientRect hwndForm, rc
hdcForm = GetDC(hwndForm)
hdc = CreateCompatibleDC(hdcForm)
hbmp = CreateCompatibleBitmap(hdcForm, rc.Right, rc.Bottom)
hbmpOld = SelectObject(hdc, hbmp)
'UserFormのクライアント領域をメモリ上のビットマップに複写
BitBlt hdc, 0, 0, rc.Right, rc.Bottom, hdcForm, 0, 0, SRCCOPY
ReleaseDC hwndForm, hdcForm

'メモリ上のビットマップに描画
NewPen.lopnColor = vbRed
NewPen.lopnWidth.x = 10
hNewPen = CreatePenIndirect(NewPen)
hOldPen = SelectObject(hdc, hNewPen)
Call MoveToEx(hdc, 10, 10, Null)
Call LineTo(hdc, 10, rc.Bottom - 10)
Call LineTo(hdc, rc.Right - 10, rc.Bottom - 10)
Call LineTo(hdc, rc.Right - 10, 10)
Call LineTo(hdc, 10, 10)

hNewPen = SelectObject(hdc, hOldPen)
DeleteObject hNewPen '
SelectObject hdc, hbmpOld
DeleteDC hdc
Set pic = GetPictureObject(hbmp)
If pic Is Nothing Then DeleteObject hbmp
'メモリ上のビットマップをPictureに変換してUserFormに設定
Set Me.Picture = pic
' Me.Repaint
End Sub

'====================================================
' HBITMAPからPictureオブジェクトを作成する関数
Private Function GetPictureObject(ByVal hbmp As Long) As Object
Dim iid As GUID
Dim pd As PICTDESC

If hbmp = 0 Then Exit Function
With iid
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With pd
.cbSizeofstruct = Len(pd)
.picType = PICTYPE_BITMAP
.hbitmap = hbmp
End With
OleCreatePictureIndirect pd, iid, 1, GetPictureObject
End Function

参考URL：

http://homepage1.nifty.com/rucio/main/tyukyu/tyukyu6.htm

回答No.1

temtecomai2

System.Drawing.dll って .NET Framework 用のライブラリでしょ。
VBA 用じゃありません。
使ったことはないですが、こんなのがあるようです。
http://www.f3.dion.ne.jp/~element/msaccess/AcTipsFrmGdiClass.html