admin menu ≫  image  writes  admin
スポンサーサイト 
--.--.--.-- 
上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。
「らんちゃ?擬き」から「XLらんちゃ?」になりました(^^ 
2009.06.30.Tue 
エクセルで作った「XLらんちゃ?」です。やっとやっと「擬き」を卒業できたような(^^v・・・ダイアログボックスでファイルを検索してファイルの拡張子に関連づけられたプログラムをシ?トに登録します。関連付けられてないプログラムもダイアログボックスから検索して無理矢理シ?トに登録してしまえば起動可能になります(^^;・・・登録後は一般のランチャ?のようにマウスクリックでプログラムを一発起動できるようになり、またダイアログボックスからファイルを選択してファイルをオ?プンすることも出来るようになります。エクセルのハイパ?リンクとはちょっと違った使い方になります(^^・・・一部画像を含みますが取りあえず全部公開してみます。ファイル容量は約62KB程度になってます。
「XLらんちゃ?」のシート
20090630-ed.jpg

「Sheet1」のモジュ?ル
※ダブルクリックでプログラムを起動する「らんちゃ?機能」
XL-Launcher-Sheet1

「ThisWorkbook」のオ?プンとクロ?ズのモジュ?ル
XL-Launcher-ThisWorkbook

標準モジュ?ルModule0(うぃんAPI関数)
※偶然見つけた関数です.テキストで書けないので画像で(^^;
XL-Launcher-Module0

プロシ?ジャ「strCmdLine$(うぃんAPI関数呼び出し)」
※これも画像で(^^;
XL-Launcher-strCmdLine

その他のプロシ?ジャは以下のようになってます。

Option Explicit
Function Cmd_Start() As Boolean
Dim CmdSetflg As Boolean
Dim preActWbName, CmdLine$, FileName$
Dim ExeFilePath$, ExeFileName$
Dim strFileName$, strFilePath$
Dim strLen%, i%
preActWbName = ActiveWorkbook.Name 'アクティブブック名を取得
CmdSetflg = False 'コマンドラインの設定フラグ
ThisWorkbook.Activate
FileName = GetFileName '選択ファイル名
If FileName <> "FALSE" Then
'登録したプログラムでコマンドラインを設定する.
If InStr(Cells(IndexNo, 1).Value, "関連") = 0 Then
CmdLine = Cells(IndexNo, 1).Value
strLen = Len(CmdLine)
For i = 1 To strLen
If Left(Right(CmdLine, i), 1) = "\" Then Exit For
Next i
'フォルダパスを検索しプログラムの有無を確認
ExeFileName = Right(CmdLine, i - 1)
ExeFilePath = Left(CmdLine, Len(CmdLine) - Len(ExeFileName))
CmdSetflg = File_Search(ExeFilePath, ExeFileName)
'コマンドラインの設定
If CmdSetflg = True Then
CmdLine = CmdLine & " " & Chr(34) & FileName & Chr(34)
End If
End If
'拡張子に関連づけられたプログラムでコマンドラインを設定する.
If CmdSetflg = False Then
strLen = Len(FileName)
For i = 1 To strLen
If Left(Right(FileName, i), 1) = "\" Then Exit For
Next i
strFileName = Right(FileName, i - 1)
strFilePath = Left(FileName, Len(FileName) - Len(strFileName))
'コマンドラインの設定
CmdLine = strCmdLine(strFileName, strFilePath)
If CmdLine <> "FALSE" Then
Call Cmd_Set(CmdLine, FileName)
If InStr(FileName, "exe") = 0 Then
CmdLine = CmdLine & " " & Chr(34) & FileName & Chr(34)
End If
CmdSetflg = True
End If
End If
End If
Windows(preActWbName).Activate '処理開始前のブックをアクティブ表示する
If CmdSetflg = True Then
Shell CmdLine, 1 'コマンドラインの実行
End If
'Open_flg=Trueの場合Shellコマンドを実行してからブックをクローズする
If Open_flg = True Then
ThisWorkbook.Saved = True
ThisWorkbook.Close
End If

End Function
Function GetFileName$()
'ダイアログボックスを開きファイルを選択する.
Dim fd As FileDialog, OpenPath, FilterName, FilterExt, vrtSelItem
Dim Row%
Set fd = Application.FileDialog(msoFileDialogOpen)
Row = 1
With fd
.Title = "ファイルを開く"
.Filters.Clear
Do
If Cells(Row, 3).Value = "" Then Exit Do
FilterName = Cells(Row, 2).Value
FilterExt = Cells(Row, 3).Value
.Filters.Add FilterName, FilterExt
Row = Row + 1
Loop
.FilterIndex = IndexNo
.AllowMultiSelect = False
If .Show = -1 Then
For Each vrtSelItem In .SelectedItems
GetFileName = vrtSelItem
Next vrtSelItem
IndexNo = .FilterIndex
Else
GetFileName = "FALSE" 'ファイルの選択がキャンセルされた
End If
End With
Set fd = Nothing
End Function
Function File_Search(FilePath$, FileName$) As Boolean
'指定されたフォルダ内を検索し、ファイルの有無を確認して値を返す.
Dim fs, Fn$, i%
Set fs = Application.FileSearch
File_Search = False
With fs
.LookIn = FilePath
.FileName = FileName
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Fn = Mid(.FoundFiles(i), Len(FilePath) + 1)
If Fn = FileName Then
File_Search = True 'ファイルが見つかった
Exit Function
End If
Next i
End If
End With
Set fs = Nothing
End Function
Function Cmd_Set(CmdLine$, FileName$) As Boolean
'コマンドラインとフィルタをシートの最終行に書き込む.
Dim i%, strLen%, EndRow&
On Error Resume Next
'カラムCの空白行を削除
With Range("C1:C" & Range("C65536").End(xlUp).Row)
.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
EndRow = Cells(Rows.Count, 1).End(xlUp).Row + 1 '最終行の取得
Cells(EndRow, 1).Value = CmdLine
If InStr(Right(FileName, 4), "exe") <> 0 Then
Cells(EndRow, 3).Value = "*.*"
Else
Cells(EndRow, 3).Value = "*" & Right(FileName, 4)
End If
strLen = Len(CmdLine)
For i = 1 To strLen
If Left(Right(CmdLine, i), 1) = "\" Then Exit For
Next i
Cells(EndRow, 2).Value = Left(Right(CmdLine, i - 1), _
Len(Right(CmdLine, i - 1)) - 4) & "用ファイル"
End Function
Function DbClickflg_Set() As Boolean
'ダブルクリックの設定(ランチャ機能のオンオフ切り替え)
Dim DbCflg$
If DbClickflg = False Then
DbCflg = "ON"
DbClickflg = True
Else
DbCflg = "OFF"
DbClickflg = False
End If
ActiveSheet.Shapes("ボタン 2").Select
Selection.Characters.Text = "プログラムランチャ機能" & Chr(10) & DbCflg
ActiveSheet.Cells(10, 5).Select
End Function
Function MsgExcl(msg$) As Boolean
MsgBox msg, vbOKOnly + vbExclamation, "警告"
End Function
 
関連記事
スポンサーサイト
* スポンサーサイト「らんちゃ?擬き」から「XLらんちゃ?」になりました(^^へのコメント *
   

台風画報


ナショジオニュース

降水短時間予報

RSSフィード

月別アーカイブ

ブログ内の検索

プロフィール


  • Designed by Il mio diario
  • Powered by FC2BLOG
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。