ソフト広告配信SoftAd をVBで

質問

VBで作成した自作ソフトに ソフト広告配信SoftAdを実装し、配布したいのですが、当ＨＰにVB仕様が掲載されてませんでした。
ソフト広告配信SoftAdとは メニューバー右側に一行広告を設けるシステムです。

ソフト広告配信SoftAd
http://www.tamasoft.co.jp/ad/index.html

ソフト広告配信SoftAd - SoftAdの仕様
http://www.tamasoft.co.jp/ad/SoftAd_Readme.html

C/C++やDelphiの例はあるのですが、初心者の私にはVB用に変換するスキルも無いので お手上げ状態です(^^;

SoftAdをVBで使用されたことがある方、またC/C++やDelphiの例からVB仕様に変換できる方、是非ご教授下さい。
宜しくお願いしますm(__)m

回答No.1

1050 円（@1050YEN） · ベストアンサー

VB6サンプルを作成してみました。
私の変換がおかしいでしょうか、Menuの終了からでないと、プロセスが残ります。
終了するときは×をクリックせず、Menuの終了から終了するようにしてください。

これはあくまでサンプルです。(心無いツッコミはご遠慮ください!)

・フォームと標準モジュールを含んだプロジェクトを作成してください。
・サンプルは「C:\SoftAd.DLL」があることが前提です。
・フォームには、メニューを必要とします。
　　キャプション:終了(&E)
　　名前:mnuEnd

'--------------------------------------------
'Form1
'--------------------------------------------
Option Explicit

Private myWnd As Long

Private Sub Form_Load()
　　myWnd = Me.hWnd

　　Call SA_Initialize(Me.hWnd, 0, FC_AD, 30000)　'//SoftAdd

　　glngWndProc = _
　　　　SetWindowLong(myWnd, _
　　　　　　　　　　　　GWL_WNDPROC, _
　　　　　　　　　　　　AddressOf WinProc _
　　　　　　　　　　　　)
　　Me.Show
　　Me.Refresh
End Sub

Private Sub mnuEnd_Click()
　　Unload Me
End Sub

'--------------------------------------------
'Module1
'--------------------------------------------
Option Explicit

Public Const GWL_WNDPROC　　　　As Long = (-4)

Private Const WM_PAINT　　　　　As Long = &HF
Private Const WM_DESTROY　　　　As Long = &H2
Private Const WM_MEASUREITEM　　As Long = &H2C
Private Const WM_DRAWITEM　　　 As Long = &H2B

Private Const DT_CENTER　　　　 As Long = &H1
Private Const DT_VCENTER　　　　As Long = &H4
Private Const DT_SINGLELINE　　 As Long = &H20

Public Const FC_EXIT　 As Long = 100
Public Const FC_AD　　 As Long = 200

Public glngWndProc As Long

Private Type RECT
　　Left　　As Long
　　Top　　 As Long
　　Right　 As Long
　　Bottom　As Long
End Type
Private Type PAINTSTRUCT
　　hdc　　　　　　 As Long
　　fErase　　　　　As Long
　　rcPaint　　　　 As RECT
　　fRestore　　　　As Long
　　fIncUpdate　　　As Long
　　rgbReserved(32) As Byte
End Type

Public Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function BeginPaint Lib "user32" (ByVal hWnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function EndPaint Lib "user32" (ByVal hWnd As Long, lpPaint As PAINTSTRUCT) As Long

Public Declare Function SA_Initialize Lib "c:\SoftAd.dll" (ByVal hWnd As Long, ByVal hMenu As Long, ByVal fc As Long, ByVal softId As Long) As Long
Public Declare Sub SA_Cleanup Lib "c:\SoftAd.dll" ()
Public Declare Sub SA_InitMenuItem Lib "c:\SoftAd.dll" (ByVal lpDRAWITEMSTRUCT As Long)
Public Declare Sub SA_DrawMenuItem Lib "c:\SoftAd.dll" (ByVal lpDRAWITEMSTRUCT As Long)

Public Function WinProc( _
　　　　　　ByVal hWnd As Long, _
　　　　　　ByVal iMsg As Long, _
　　　　　　ByVal wParam As Long, _
　　　　　　ByVal lParam As Long _
　　　　) As Long

　　WinProc = False
　　Select Case iMsg
　　　　Case WM_PAINT
　　　　　　Dim ps　As PAINTSTRUCT
　　　　　　Dim hdc As Long
　　　　　　Dim rc　As RECT

　　　　　　hdc = BeginPaint(hWnd, ps)
　　　　　　Call GetClientRect(hWnd, rc)
　　　　　　Call DrawText(hdc, "Hello World!", -1, rc, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
　　　　　　Call EndPaint(hWnd, ps)

　　　　Case WM_DESTROY
　　　　　　Call SA_Cleanup　　　　　　　　　　　　 '//SoftAdd
　　　　　　Call SetWindowLong(hWnd, GWL_WNDPROC, glngWndProc)

　　　　Case WM_MEASUREITEM
　　　　　　Call SA_InitMenuItem(ByVal lParam)　　　'//SoftAdd
　　　　Case WM_DRAWITEM
　　　　　　Call SA_DrawMenuItem(ByVal lParam)　　　'//SoftAdd
　　End Select

　　WinProc = DefWindowProc(hWnd, iMsg, wParam, lParam)
　　Call CallWindowProc(glngWndProc, hWnd, iMsg, wParam, lParam)
End Function

お礼

回答ありがとうございましたm(__)m

自作ソフトでは「Case WM_PAINT」以下がいらなかったので、その部分を削除したのですが、メニューバーからツールバーまでの間が２行程度空いてしまいました。

色々やってみます。
ありがとうございました。