| |
こんにちわ。もうみてへんかな？
>開いてみたのですが、圧縮（ＺＩＰ形式）フォルダは無効であるか、または
>壊れています、となります。
ダウンロードに失敗したんやと思うよ。こっちではちゃんとＤＬできてます。
>VBからAPIのCall方法を勉強されることをお勧めします。
同感。ＶＢからの使い方をご存知ないみたいやね・・・
TypeとDeclareくらいはヘルプで確認してみてな。
ＤＬしたクラスモジュールはめっちゃコードが多いんで、そのままではわかりにくいし、
ＶＢ用なんで、ＶＢＡで使うとそのままではエラーが出るさかいに、
ポップアップの部分だけ抽出・単純化して、エクセルのＶＢＡで使えるように変更して
みました。
シートを右クリックしたらポップアップが表示されます。
'シートモジュール=================================================================
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Dim PopupHelp As New clsPopup
PopupHelp.ShowPopup "これはテスト用の表示です。"
Cancel = True
End Sub
'クラスモジュール（モジュール名：clsPopup）=======================================
Private Const HH_DISPLAY_TEXT_POPUP = &HE
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type tagHH_POPUP
cbStruct As Integer
hinst As Long
idString As Long
pszText As String
pt As POINTAPI
clrForeground As Long
clrBackground As Long
rcMargins As RECT
pszFont As String
End Type
Private Declare Function HtmlHelpTextPopup Lib "hhctrl.ocx" _
Alias "HtmlHelpA" _
(ByVal hwnd As Long, _
ByVal lpHelpFile As String, _
ByVal wCommand As Long, _
ByRef dwData As tagHH_POPUP) As Long
Private Declare Function GetCursorPos Lib "user32" _
(ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Public Sub ShowPopup(ByRef PopupText As String)
Dim pPoint As POINTAPI
Dim hPopup As tagHH_POPUP
Dim rRect As RECT
Dim hWnd As Long
GetCursorPos pPoint
With rRect
.Bottom = -1
.Left = -1
.Right = -1
.Top = -1
End With
With hPopup
.cbStruct = Len(hPopup)
.clrForeground = vbBlack
.clrBackground = vbYellow
.idString = 0
.pszText = PopupText
.pt = pPoint
.rcMargins = rRect
.pszFont = "ＭＳ 明朝, 12"
End With
hWnd = GetActiveWindow()
HtmlHelpTextPopup hWnd, vbNullString, HH_DISPLAY_TEXT_POPUP, hPopup
End Sub
あとは元のクラスモジュールを解析してみておくれやす。
ほな。
|
|
ｂｙｋｉｎ
- 05/4/29(金) 11:37 -
