2008年3月3日月曜日

VBA ~お気に入りにあるURLの一覧を作成(IEのみ)~

お気に入りにあるURLの一覧を作成(IEのみ)


お気に入りがあるパスを指定して、お気に入りにあるサイトの名前とURLをエクセルに一覧にして作成します。
A2から下のセル→お気に入りにあるサイトの名前
B2から下のセル→お気に入りにあるURL
C2→お気に入りが入っているフォルダのパス
※お気に入りのパスはInternet Explorerのお気に入りを開き、お気に入りに登録されているサイト名を右クリックでプロパティを開いてください。
そして、タブの全般を選び、その中にある「場所:」がお気に入りのパスになります。

---------------------------------------------------------------------------------------
'urlファイルを読み込むメソッド
Private Declare Function GetPrivateProfileString Lib "kernel32" _
  Alias "GetPrivateProfileStringA" _
   (ByVal lpApplicationName As String, _
  ByVal lpKeyName As Any, ByVal lpDefault As String, _
  ByVal lpReturnedString As String, ByVal nSize As Long, _
  ByVal lpFileName As String) As Long


Private Sub CommandButton1_Click()
  Dim path As String
  Dim File As String

  'お気に入りのパス
   path = Trim(Cells(2, 3))

  '表示するファイル名を取得
   File = Dir(path & "\*", vbNormal)

   Dim i As Integer
   i = 2

   'ファイル名一覧を作成
   Do While File <> ""
     'A2から下に一覧を表示
     Cells(i, 1).Value = File
     i = i + 1
     File = Dir()
   Loop

   'ファイル名からURLを取得
   Dim buf As String * 256

   i = 2
   Do While Cells(i, 1) <> ""
     'セクション: InternetShortcut
     'キー: URL
     '既定値: ""
     'INIファイル名: path & "\" & Cells(i, 1)
     rc = GetPrivateProfileString _
       ("InternetShortcut", "URL", "", buf, Len(buf), path & "\" & Cells(i, 1))
    Cells(i, 2).Value = Left$(buf, InStr(buf, vbNullChar) - 1)
     'urlという拡張子の文字列を消去
    Cells(i, 1) = Replace(Cells(i, 1), ".url", "")
     'ハイパーリンクにする
     ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 2), Address:=Cells(i, 2)

     i = i + 1
   Loop

   '終了
   MsgBox ("作成完了!!")

End Sub

---------------------------------------------------------------------------------------