option Explicit

'-------------------------------------------------------------------------------
' Function CreateShortcut
'-------------------------------------------------------------------------------
Sub CreateShortcut(lunascape)

	' アクティブなタブでJavaScriptを実行します。
	Dim nActiveIndex
	nActiveIndex = lunascape.ActiveIndex
	Dim idDocument
	idDocument = lunascape.GetDocumentID(nActiveIndex)
	' BODYタグの内側先頭に必要な情報（ページタイトル）をElementで持たせたDIVタグを埋め込みます
	lunascape.ExecuteJavaScript idDocument, "var element = document.createElement('div'); element.setAttribute('id','LunascapeDmyDiv'); var objBody = document.getElementsByTagName('body').item(0); objBody.appendChild(element);element.setAttribute('dmytitle', document.title);"


	Dim PageURL, PageTitle
	PageURL = lunascape.URL
	' 埋め込んだダミーのDivタグから情報を抜きます
	PageTitle = lunascape.GetDOMElementAttribute(idDocument, "LunascapeDmyDiv","dmytitle")
		
	' BODYタグのに埋め込んだダミータグを削除します(最後のvoid(null);はGecko特有のページが切り替わる問題臨時対応)
	lunascape.ExecuteJavaScript idDocument, "var element = document.getElementById('LunascapeDmyDiv');var parent = element.parentNode;var len = parent.childNodes.length;for(var i = len-1; i >= 0; i--){ if(parent.childNodes[i].id == 'LunascapeDmyDiv'){parent.removeChild(parent.childNodes[i]);}}void(null);"

	' ファイル名として利用できない文字を"_"で置換します
	Dim reg
	Set reg = New RegExp
	reg.Pattern = "[\\/:\*\?""<>\r\n\t]"
	reg.Global  = true
	PageTitle = reg.Replace(PageTitle, "_")
	
	' ショートカットファイルを作成します
	Dim objWshShell, objShortcut, objEnv
	Dim strDesktopPath
	Set objWshShell = CreateObject("WScript.Shell")
	strDesktopPath = objWshShell.SpecialFolders("Desktop")
	
	Set objShortcut = objWshShell.CreateShortcut(strDesktopPath & "/" & PageTitle & ".url")
	Set objEnv = objWshShell.Environment("process")

	objShortcut.TargetPath = PageURL
	objShortcut.Save

	lunascape.MessageBox("添加到桌面的快捷方式。")

End Sub

'-------------------------------------------------------------------------------
' Sub main
'-------------------------------------------------------------------------------
Sub main()
	Dim lunascape
	Set lunascape = CreateObject("Lunascape2.LunascapeAPI")
	CreateShortcut(lunascape)
End Sub

'-------------------------------------------------------------------------------
' Function OnClick
'-------------------------------------------------------------------------------
Function OnClick()
	OnClick = True
	CreateShortcut(lunascape)
End Function

main()
