Active Basic 自分自身のショートカットを作成したい

質問

Active Basic　4.23.00でプログラムを書いています。
タイトルどおり、自分自身のショートカットを作成する方法を探しています。
どなたかご存知のかたがいらっしゃいましたら、ご教授ください。
お願いします。

回答No.1

machongola · ベストアンサー

こんばんは。
　win32APIで作成する事は無理なようで、IShellLink/IPersistFileと言う、COM/OLEのインターフェースを使用する事になるようです。

　以下辺りが参考になります。
　http://www.activebasic.com/forum/viewtopic.php?t=1110
　http://park6.wakwak.com/~wmasa/prog/srclib/0008.htm

　当方がActive Basic 5なので、もしかしたらCOM/OLEの呼び出し方が違うのかもしれません。
　とても説明出来るようなものではないので、以下を参考程度としてください。

'--------------------------------------------------------------------------
'以下は外側に書く
'--------------------------------------------------------------------------
TypeDef HRESULT = Long
TypeDef ULONG = DWord

TypeDef CLSID = GUID
TypeDef IID = GUID
TypeDef REFIID = GUID

Dim IID_IShellLink = [&H000214EE,&H0000,&H0000,[&HC0,&H00,&H00,&H00,&H00,&H00,&H00,&H46]] As GUID
Dim CLSID_ShellLink = [&H00021401, &H0000, &H0000, [&HC0, &H00, &H00, &H00, &H00, &H00, &H00, &H46]] As CLSID

'IShellLinkインターフェース
Interface _IShellLink
Inherits IUnknown

'*** IUnknown methods ***
Function QueryInterface(ByRef riid As REFIID, ByVal ppvOb As *LPVOID) As HRESULT
Function AddRef() As ULONG
Function Release() As ULONG

'*** IShellLink methods ***
Function GetPath(ByVal pszFile As LPSTR, ByVal cchMaxPath As INT, ByVal pfd As *WIN32_FIND_DATAA, ByVal fFlags As DWORD) As HRESULT

Function GetIDList(ByVal ppidl As *LPITEMIDLIST) As HRESULT
Function SetIDList(ByVal pidl As LPCITEMIDLIST) As HRESULT

Function GetDescription(ByVal pszName As LPSTR, ByVal cchMaxName As INT) As HRESULT
Function SetDescription(ByVal pszName As LPCSTR) As HRESULT

Function GetWorkingDirectory(ByVal pszDir As LPSTR, ByVal cchMaxPath As INT) As HRESULT
Function SetWorkingDirectory(ByVal pszDir As LPCSTR) As HRESULT

Function GetArguments(ByVal pszArgs As LPSTR, ByVal cchMaxPath As INT) As HRESULT
Function SetArguments(ByVal pszArgs As LPCSTR) As HRESULT

Function GetHotkey(ByVal pwHotkey As *Word) As HRESULT
Function SetHotkey(ByVal wHotkey As Word) As HRESULT

Function GetShowCmd(ByVal piShowCmd As *INT) As HRESULT
Function SetShowCmd(ByVal iShowCmd As INT) As HRESULT

Function GetIconLocation(ByVal pszIconPath As LPSTR, ByVal cchIconPath As INT, ByVal piIcon As *INT) As HRESULT
Function SetIconLocation(ByVal pszIconPath As LPCSTR, ByVal iIcon As INT) As HRESULT

Function SetRelativePath(ByVal pszPathRel As LPCSTR, ByVal dwReserved As DWORD) As HRESULT

Function Resolve(ByVal hwnd As HWND, ByVal fFlags As DWORD) As HRESULT

Function SetPath(ByVal pszFile As LPCSTR) As HRESULT
End Interface
'--------------------------------------------------------------------------
'ココまで
'--------------------------------------------------------------------------

'--------------------------------------------------------------------------
'ショートカットを作成する
'--------------------------------------------------------------------------
Sub CreateShortCut()

'必要な変数等
Dim hResult As HRESULT
Dim pShellLink As *_IShellLink
Dim pPersistFile As *IPersistFile

'--------------------------------------------------------------------------
'ココからCOM/OLEとインターフェースの初期化をする
'--------------------------------------------------------------------------

'COM/OLEの初期化
hResult = CoInitialize(0)
If hResult <> S_OK Then
MessageBox(hMainWnd,"COM/OLEの初期化失敗した", "CoInitialize()", MB_OK or MB_ICONHAND)
End If

'IShellLinkインターフェースの作成
hResult = CoCreateInstance(CLSID_ShellLink, 0, CLSCTX_INPROC_SERVER, IID_IShellLink, pShellLink)
If hResult <> S_OK Then
MessageBox(hMainWnd,"IShellLinkの作成に失敗した", "CoCreateInstance()", MB_OK or MB_ICONHAND)
End If

'IPersistFileインターフェースの作成
hResult = pShellLink->QueryInterface(IID_IPersistFile, VarPtr(pPersistFile))
If hResult <> S_OK Then
MessageBox(hMainWnd,"IPersistFileの作成に失敗した", "IShellLink::Instance()", MB_OK or MB_ICONHAND)
End If

'--------------------------------------------------------------------------
'ココからリンク先の設定をする
'--------------------------------------------------------------------------

'カレントディレクトリを取る
Dim currentPath[MAX_PATH + 1] As TCHAR
GetCurrentDirectory(MAX_PATH, currentPath)

'ファイル名を付け加える
lstrcat(currentPath, "\Test.exe")

'パスの確認
'MessageBox(hMainWnd, currentPath, currentPath, MB_OK or MB_ICONHAND)

'コレをリンク先として設定する
hResult = pShellLink->SetPath(currentPath)

'--------------------------------------------------------------------------
'ココからデスクトップにショートカットファイルを作成する
'--------------------------------------------------------------------------

'デスクトップのパスを取る
Dim desktopPath[MAX_PATH + 1] As TCHAR
SHGetSpecialFolderPath(NULL, desktopPath, CSIDL_DESKTOPDIRECTORY, FALSE)

'ショートカットファイル名を付け加える
lstrcat(desktopPath, "\TestLink.lnk")

'パスの確認
'MessageBox(hMainWnd, desktopPath, desktopPath, MB_OK or MB_ICONHAND)

'ユニコードに直す
Dim unicode[MAX_PATH + 1] As WCHAR
MultiByteToWideChar(CP_ACP, 0, desktopPath, -1, unicode, MAX_PATH)

'デスクトップにショートカットファイルが出来る
hResult = pPersistFile->Save(unicode, TRUE)

'--------------------------------------------------------------------------
'ココからCOM/OLEとインターフェースの始末をする
'--------------------------------------------------------------------------

'COM/OLEインターフェースの解放
pPersistFile->Release()
pShellLink->Release()

'COM/OLEのシャットダウン
CoUninitialize()

End Sub