Private Sub Execute_WordMacro(MacName As String)
'/////  Wordマクロの実行

    Dim wrd As Object
    Dim I As Integer

    If MacName = "" Then Exit Sub
On Error GoTo GetWordObject_Error
    Set wrd = GetObject(, "Word.Application")
    wrd.run MacName
    Set wrd = Nothing
    Exit Sub

GetWordObject_Error:
    I = I + 1
    If I = 5000 Then Exit Sub
    Resume

End Sub

2つの指定した日付の時間間隔を表すバリアント型 (内部処理形式 Date の Variant) 
  の値を指定します。


DateDiff(interval,date1,date2 [,firstdayofweek [,firstweekofyear ]])


（例）

差を日付で求める

Dim aaa as String
aaa = "1998/06/24"   <-- 必ずスラッシュ(/)を入れる

Ret =DateDiff("d", aaa, Date)

過去の日をdate1に入れる。そうしないとマイナス( - )で表示されてしまいます。

Visual BasicからDOSアプリケーションを利用する場合、Shell関数を用いるのが一般的です。
何よりも手軽で、リダイレクトで結果を取り出せますからね。
でも、問題もありました。
Shell関数でDOSアプリケーションを起動すると、MS-DOSプロンプトというWindowsが表示されるのですが、
このWindowsはDOSアプリケーション終了後もクローズしてくらないのです。
MS-DOSプロンプトが表示されているということ自体が問題だったので、
 非表示、あるいは最小化して誤魔化すのも一般的でした。
でも、この場合も結局のところクローズしないので残ったので、ここでは、こういった問題を一気に解決する方法を掲示します。

その方法は

Shell("command.com /c program.exe")

です。
これで非表示で起動、つまり
        
Shell("command.com /c program.exe",vbHide)

と記述してやれば、ユーザーにDOSアプリケーションの起動を気付かれないことも夢ではないでしょう。

Private Sub Form_Load()

    Dim msg
    
    If App.PrevInstance = -1 Then
        msg = MsgBox("既に起動されています")
        End
    End If

End Sub

FileDateTime 関数

指定したファイルの作成日時または最後に変更した日時を示す日付と時刻
(VarType 7) を返します。

構文

FileDateTime(pathname)

引数 pathname には、ファイル名を示す文字列式を指定します。ディレクトリ名およびド
ライブ名を含めて指定できます。

FileDateTime 関数の例
次のプログラムでは、FileDateTime 関数を使ってファイルが作成または最後に
変更された日付と時刻を求めます。表示される日付と時刻の形式は国別情報の
設定によって異なります。

' TESTFILE が最後に更新された日付は 1993 年 2 月 12 日
' 午後 4 時 35 分 47 秒であるとします。
' 国別情報の設定は "日本/日本語" であるとします。

MyStamp = FileDateTime("TESTFILE")      ' "93/2/12 4:35:47 PM" を返します。

	レジストリを読み込む
	
GetSetting 関数

Microsoft Windows のレジストリにあるアプリケーションの項目から、キー設定値を返します。

構文

GetSetting(appname, section, key[, default])

GetSetting 関数の構文は、次の名前付き引数から構成されます。


指定項目	内容
-------------------------------------------------------------------------------
appname		必ず指定します。キー設定を取得するアプリケーション名または
		プロジェクト名を含む文字列式を指定します。
section		必ず指定します。対象となるキー設定があるセクション名を
		含む文字列式を指定します。
key		必ず指定します。取得するキー設定名を含む文字列式を指定します。
default		省略可能です。キー設定に値が設定されていない場合に返す値を
		含む式を指定します。省略すると、長さ 0 の文字列 ("") と
		みなされます。

（例）

' GetSetting 関数によって返される二次元配列を格納するためにバリアント型変数を
  宣言します。
 
txtSave.Text = GetSetting("Word2Text変換", "w2text", "SaveDir", txtSave.Text)

	Helpファイルの起動
	
Declare Function WinHelp Lib "user32" Alias "WinHelpA" _
(ByVal hwnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long

定数

Public Const HELP_CONTEXT = &H1	   'トピックを選んでヘルプを開く
Public Const HELP_FINDER = &HB&	   'トピックの検索ウインドウを開く

 'トピックの検索ウインドウを開く時の構文。
Run = WinHelp(hwnd, App.Path & "\w2text.hlp", HELP_FINDER, ByVal 0&)

 'トピックを選んでヘルプを開く時の構文。
Run = WinHelp(hwnd, App.Path & "\w2text.hlp", HELP_CONTEXT, ByVal 3000&)

 ByVal 3000& の 3000 の部分にコンテキストIDを記入します。コンテキストIDはHHファイルを参照して下さい。

	「閉じるボタン」の無効化
	
Public Declare Function GetSystemMenu Lib "user32" Alias "GetSystemMenu" _
(ByVal hwnd As Long, ByVal bRevert As Long) As Long
Public Declare Function DeleteMenu Lib "user32" Alias "DeleteMenu" _
(ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long

Public Const MF_BYCOMMAND = &H0&
Public Const SC_CLOSE = &HF060


Private Sub Form_Load()

	Dim Ret as Long
	Dim Result as Long
	
	Ret = GetSystemMenu(Me.hWnd, False)
	Result = DeleteMenu(Ret, SC_CLOSE, MF_BYCOMMAND)
	
	or
	
	Call DeleteMenu(GetSystemMemu(Form1.hWnd, False), 6, 1024)
	
End Sub

' ＡＰＩ定義
Public Type NETRESOURCE
    UScope As Long
    UType As Long
    UDType As Long
    UUsage As Long
    UDrive As String
    URmt As String
    UCmt As String
    UPro As String
End Type

Public PBU_RCODE_LNG As Long

Declare Function WNetAddConnection2 Lib "mpr.dll" Alias "WNetAddConnection2A" _
    (lpNetResource As NETRESOURCE, ByVal lpPassword As String, _
    ByVal lpUserName As String, ByVal dwFlags As Long) As Long
Declare Function WNetCancelConnection2 Lib "mpr.dll" Alias "WNetCancelConnection2A" _
    (ByVal lpName As String, ByVal dwFlags As Long, ByVal fForce As Long) As Long

' 接続
Private Sub Mount()
    Dim PBU_WNET_TYPE As NETRESOURCE
    Dim PBU_WNET_PASS As String
    Dim PBU_WNET_USER As String
    Dim PBU_WNET_FLG As Long
    
    PBU_WNET_TYPE.UScope = &H2
    PBU_WNET_TYPE.UType = &H1
    PBU_WNET_TYPE.UDType = &H3
    PBU_WNET_TYPE.UUsage = &H1
    PBU_WNET_TYPE.UPro = ""
    PBU_WNET_TYPE.UCmt = ""
    PBU_WNET_FLG = &H0
    
    PBU_WNET_TYPE.UDrive = "Drive"  'ドライブ名称   H:
    PBU_WNET_TYPE.URmt = "Path"     'パス名称       \\ｺﾝﾋﾟｭｰﾀ名\共有名
    PBU_WNET_USER = "UserName"      'ユーザ名称     WinNT3.51では必須
    PBU_WNET_PASS = "PassWord"      'パスワード
    
    PBU_RCODE_LNG = WNetAddConnection2(PBU_WNET_TYPE, PBU_WNET_PASS, PBU_WNET_USER, PBU_WNET_FLG)
    Select Case PBU_RCODE_LNG
    Case 0&
        MsgBox "正常終了"
    Case 53&
        MsgBox "サーバ（コンピュータ名）が見つかりません。"
    Case 67&
        MsgBox "ＰＡＴＨが見つかりません（共有になっていません）。"
    Case 85&
        MsgBox "既に接続済みです。"
    Case Else
        MsgBox PBU_RCODE_LNG
    End Select

End Sub

' 切断
Private Sub UnMount()
    Dim PBU_WNETC_UDrive As String
    Dim PBU_WNETC_UFlg1 As Long
    Dim PBU_WNETC_UFlg2 As Long
    
    PBU_WNETC_UFlg1 = &H0
    PBU_WNETC_UFlg2 = 0&
    PBU_WNETC_UDrive = "Drive"      'ドライブ名称   H:
    
    PBU_RCODE_LNG = WNetCancelConnection2(PBU_WNETC_UDrive, PBU_WNETC_UFlg1, PBU_WNETC_UFlg2)
    Select Case PBU_RCODE_LNG
    Case 0&
        MsgBox "正常終了"
    Case 2250&
        MsgBox "既に切断済みです。"
    Case Else
        MsgBox PBU_RCODE_LNG
    End Select

End Sub

	レジストリに書き込む
	

SaveSetting ステートメント

Microsoft Windows のレジストリに、アプリケーションの項目を保存または作成します。
構文

SaveSetting appname, section, key, setting

SaveSetting ステートメントの構文は、次の名前付き引数から構成されます。

指定項目	内容
-------------------------------------------------------------------------------
appname		必ず指定します。設定を適用するアプリケーション名または
		プロジェクト名を含む文字列式を指定します。
section		必ず指定します。キー設定を保存するセクション名を含む文字列式を
		指定します。
key		必ず指定します。保存するキー名を含む文字列式を指定します。
setting		必ず指定します。名前付き引数 key に設定する値を含む式を
		指定します。
		
（例）
' レジストリに設定を書き込みます。
SaveSetting appname := "MyApp", section := "Startup", _
            key := "Top", setting := 75 

SaveSetting "MyApp","Startup", "Left", 50 

******** ショートカットを作成するには？ ********


Public Declare Function fCreateShellLink Lib "STKIT432.DLL" _
        (ByVal lpstrFolderName As String, _
        ByVal lpstrLinkName As String, _
        ByVal lpstrLinkPath As String, _
        ByVal lpstrLinkArguments As String) As Long

 lpstrFolderName： \Windows\ｽﾀｰﾄﾒﾆｭｰ\ﾌﾟﾛｸﾞﾗﾑを基準としてショートカットの作成先
 lpstrLinkName：   ショートカットの名前
 lpstrLinkPath：   リンクするファイル
 lpstrLinkArguments： コマンドオプション

 (例) C:\Windowsの下にあるcalc.exeをスタートアップメニューに追加する。
 
 Ret = fCreateShellLink("ｽﾀｰﾄｱｯﾌﾟ", 電卓, "c:\windows\calc.exe", "")

	「タイトルバー」を消す

プロパティウィンドウによって設定可能

・タイトルバーを消したいフォームを選択

 Form1.icon=""  (なし）
 Form1.caption="" (NULL)
 Form1.ControlBox=False
 Form1.MaxButton=False
 Form1.MinButton=False
 Form1.BorderStyle=vbFixedDialog  (3 - 固定ﾀﾞｲｱﾛｸﾞ)

	プログラム終了をチェックする

Public Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Public Declare Function GetExitCodeProcess Lib "kernel32" _
	(ByVal hProcess As Long, lpExitCode As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" _
        (ByVal hObject As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'定数
Public Const PROCESS_QUERY_INFORMATION = &H400&
Public Const STILL_ACTIVE = &H103&

    Dim IDProcess As Long
    Dim hProcess As Long
    Dim ExitCode As Long
    Dim ret As Long

    IDProcess = Shell("Program.exe", vbNormalFocus)

    'プログラムが終了するまで待機する
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, 1, IDProcess)
    Sleep (3000)
    Do
        ret = GetExitCodeProcess(hProcess, ExitCode)
        DoEvents
    Loop While (ExitCode = STILL_ACTIVE)
    
    ret = CloseHandle(hProcess)

		週の最初の日（月曜日）を求める



w=Weekday(Date)             '月曜日は 2

wday=DateSerial(Year(Date),Month(Date),Day(Date)-(Weekday(Date)-2))

'日曜日には処理をしないようにし、Formatはyyyymmddとする

If Weekday(Date) >= 2 Then
	wday=Format(DateSerial(Year(Date),Month(Date),Day(Date)-_
		Weekday(Date)-2)), "yyyymmdd")
End If

	レジストリの削除

Microsoft Windows のレジストリにあるアプリケーションの項目から、
セクションまたはキー設定を削除します。

構文

DeleteSetting appname, section[, key]

DeleteSetting ステートメントの構文は、次の名前付き引数から構成されます。


指定項目	内容
appname		必ず指定します。セクションか、キー設定を適用するアプリケーショ
		ン名またはプロジェクトの名前を含む文字列式を指定します。
section		必ず指定します。キー設定を削除するセクション名を含む文字列式を
		指定します。名前付き引数 appname および名前付き引数 section 
		だけを指定した場合、指定されたセクションは関連付けられたすべて
		のキー設定と共に削除されます。
key		省略可能です。削除するキー名を含む文字列式を指定します。


（例）
' セクションと、セクションのすべての設定をレジストリから削除します。
DeleteSetting "MyApp", "Startup" 

	ディレクトリごと削除
	
'DelPath以下を削除します。
Public Function DelFileUnderPath(ByVal DelPath As String) As Boolean
Static DelName As String, DelUnder As String, Msg As String
    'DelPath  内のﾃﾞｨﾚｸﾄﾘの名前を表示します
    DelFileUnderPath = True
    DelName = Dir(DelPath, vbDirectory)   ' 最初のﾃﾞｨﾚｸﾄﾘ名を返します
    Do While DelName <> ""   'ﾙｰﾌﾟを開始します
        '現在のﾃﾞｨﾚｸﾄﾘと親ﾃﾞｨﾚｸﾄﾘは無視します
        If DelName <> "." And DelName <> ".." Then
            'ﾋﾞｯﾄ単位の比較を行い、DelName がﾃﾞｨﾚｸﾄﾘかどうかを調べます
            If (GetAttr(DelPath & DelName) And vbDirectory) = vbDirectory Then
                'ﾃﾞｨﾚｸﾄﾘであればその下位のﾃﾞｨﾚｸﾄﾘを検査します
                '再帰呼出
                If Not DelFileUnderPath(DelPath & DelName & "\") Then
                    DelFileUnderPath = False
                    On Error GoTo 0
                    Exit Function
                End If
                DelName = Dir(DelPath, vbDirectory)
            Else
                On Error GoTo FileAttr
                'ﾌｧｲﾙなら消去します
                Kill (DelPath & DelName)
                DelName = Dir
            End If
        Else
            DelName = Dir
        End If
    Loop
    'ﾃﾞｨﾚｸﾄﾘ中のﾌｧｲﾙを消去したのでﾃﾞｨﾚｸﾄﾘを消去します
    'Debug.Print DelPath; CurDir
    'If CurDir = DelPath Then ChDir ".."
    On Error GoTo DirAttr
    RmDir DelPath ', lstrlen(DelPath) - 1)
    On Error GoTo 0
    Exit Function
FileAttr:
    On Error GoTo TrapErr
    SetAttr (DelPath & DelName), vbNormal
    Resume
DirAttr:
    On Error GoTo TrapErr
    SetAttr DelPath, vbNormal
    Resume
TrapErr:
    If Err.Number <> 0 Then
        Msg = "Error No." & Str(Err.Number) & "rises." & vbCrLf
        Msg = Msg & "(This mean '" & Err.Description & "' )" & vbCrLf
        Msg = Msg & "Stop purging." & vbCrLf
        Msg = Msg & "Check the file '" & DelPath & DelName & "' ,and purge 
agein."
        MsgBox Msg, vbCritical, "PURGE ERROR"
    End If
    On Error GoTo 0
    DelFileUnderPath = False
    Exit Function
End Function

		ログインユーザ名の取得
		
Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _
        (ByVal lpBuffer As String, nSize As Long) As Long

Public Function GetNameUser() As String
    Dim UserName As String * 30
    Dim UserNameSize As Long
    UserNameSize = Len(UserName)
    
    If GetUserName(UserName, UserNameSize) > 0 Then
        GetNameUser = UserName
    Else
        GetNameUser = "default"
    End If
End Function


    filename = GetNameUser
    'Windowsからユーザ名を取得する。
    '30バイトの器を用意していて、実際に埋められた文字が6文字なら
    'それ以外の場所には文字コード 0 が入る
    
    For i = 1 To 30
        If filename = "default" Then
            Exit For
        ElseIf Asc(Mid(filename, i, 1)) = 0 Then
            i = i - 1
            Exit For
        End If
    next i
    
    長さがわかったので、後は変数filenameから必要な長さの文字列を切り出せばユーザ名を取得することができる。

	多角形の塗りつぶし
	
Private Declare Sub FloodFill Lib "GDI32"  Alias "FloodFill" _
 (ByVal hDC As Long, ByVal X As Long, ByVal Y As _
  Long, ByVal crColor As Long) As Long


' フォームに以下のコードを記述します。
Private Sub Form_Click ()
	Dim Ret as Long
	
	ScaleMode = vbPixels	     ' Windows はピクセル単位で描画を行います。
	ForeColor = vbBlack	     ' 線の色を黒に設定します。
	Line (100, 50)-(300, 50)     ' 三角形を描画します。
	Line -(200, 200)
	Line -(100, 50)
	FillStyle = vbFSSolid        ' FillStyle プロパティを塗りつぶしに
				     ' 設定します。
	FillColor = RGB(128, 128, 255)  ' FillColor プロパティを設定します。
	
	' Windows API を呼び出して塗りつぶします。
	Ret = FloodFill( Form1.hDC, 200, 100, vbBlack) 
End Sub

	CommonDialogコンポーネントを利用せず[ﾌｧｲﾙを開く]を実現する
	

------------------------------------------------------------------
    'フィルタ文字列を一時的に格納する
    Dim strFilter As String
    
    strFilter = "Wordﾄﾞｷｭﾒﾝﾄ(*.doc)" & vbNullChar & "*.doc" & vbNullChar
    
    '[ﾌｧｲﾙを開く]ﾀﾞｲｱﾛｸﾞの表示とﾌｧｲﾙ名の取得
    txtWord.Text = ShowOpenFileDlg(Me.hWnd, strFilter, CurDir)
------------------------------------------------------------------


Option Explicit
'[ﾌｧｲﾙを開く]と[ﾌｧｲﾙを保存]ﾀﾞｲｱﾛｸﾞﾎﾞｯｸｽの為の構造体宣言
Private Type OPENFILENAME
        lStructSize As Long     '構造体のｻｲｽﾞ
        hwndOwner As Long       'ﾀﾞｲｱﾛｸﾞﾎﾞｯｸｽを所有するｳｨﾝﾄﾞｳのﾊﾝﾄﾞﾙ
        hInstance As Long       'ｱﾌﾟﾘｹｰｼｮﾝ ｲﾝｽﾀﾝｽ
        lpstrFilter As String   'ﾌｨﾙﾀｰ
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long    'ﾃﾞﾌｫﾙﾄのﾌｨﾙﾀ
        lpstrFile As String     '選択されたﾌｧｲﾙ名
        nMaxFile As Long        'ﾌｧｲﾙ名の最大長
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long           'ｵﾌﾟｼｮﾝ
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type

'[ﾌｧｲﾙを開く]ﾀﾞｲｱﾛｸﾞﾎﾞｯｸｽを呼び出すAPI
Private Declare Function GetOpenFileName _
        Lib "comdlg32.dll" Alias "GetOpenFileNameA" _
        (pOpenfilename As OPENFILENAME) As Long

'OPENFILENAME構造体のflagsで指定する定数
Public Const OFN_READONLY = &H1         '[読み取り専用]ﾁｪｯｸﾎﾞｯｸｽをﾁｪｯｸ
Public Const OFN_OVERWRITEPROMPT = &H2  'ﾌｧｲﾙが存在していた場合、上書きを問い合わせる
Public Const OFN_HIDEREADONLY = &H4     '[読み取り専用]ﾁｪｯｸﾎﾞｯｸｽを非表示
Public Const OFN_SHOWHELP = &H10        '[ﾍﾙﾌﾟ]ﾎﾞﾀﾝの表示
Public Const OFN_ALLOWMULTISELECT = &H200 '複数のﾌｧｲﾙを選択可能に
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_PATHMUSTEXIST = &H800  '存在しないﾊﾟｽ名を入力不可に
Public Const OFN_FILEMUSTEXIST = &H1000 '存在しないﾌｧｲﾙ名を入力不可に
Public Const OFN_CREATEPROMPT = &H2000  'ﾌｧｲﾙが存在しなかった場合、新規作成するかどうか表示
Public Const OFN_EXPLORER = &H80000


'--------------------------------------------------------
'   関数名  : ShowOpenFileDlg
'   用途    : [ﾌｧｲﾙを開く]ﾀﾞｲｱﾛｸﾞを表示してﾌｧｲﾙ名を取得する
'   引数    : lngHWnd   ﾀﾞｲｱﾛｸﾞの親ｳｨﾝﾄﾞｳのﾊﾝﾄﾞﾙ
'             strFilter ﾌｧｲﾙを選別するのﾌｨﾙﾀ
'               "ﾃｷｽﾄﾌｧｲﾙ(*.TXT)" & vbNullChar & "*.txt"
'               のように、ﾌｧｲﾙの種類とﾌｨﾙﾀをNull文字で区切って渡す
'             strDefDir ﾀﾞｲｱﾛｸﾞのﾃﾞﾌｫﾙﾄﾃﾞｨﾚｸﾄﾘ
'   戻り値  : 選択されたﾌｧｲﾙ名。ｷｬﾝｾﾙされた場合は何も戻らない
'   備考    : なし
'--------------------------------------------------------
Public Function ShowOpenFileDlg(lngHWnd As Long, strFilter As String, strDefDir As String) As String

    Dim strRePathName As String
    
    Dim typOpenFileName As OPENFILENAME
    
    With typOpenFileName
        'ｻｲｽﾞの設定
        .lStructSize = Len(typOpenFileName)
        '親Windowの指定
        .hwndOwner = lngHWnd
        'ｱﾌﾟﾘｹｰｼｮﾝのｲﾝｽﾀﾝｽを指定
        .hInstance = App.hInstance
        'ﾌｨﾙﾀの種類を設定
        .lpstrFilter = strFilter
        'ｱｸﾃｨﾌﾞなﾌｨﾙﾀの番号を設定
        .nFilterIndex = 1
        '[ﾌｧｲﾙ名]ﾎﾞｯｸｽの内容を初期化
        .lpstrFile = String(256, Chr(0))
        '最大ﾌｧｲﾙ長の設定
        .nMaxFile = 256
        'ﾌｧｲﾙのﾀｲﾄﾙを受け取るﾎﾟｲﾝﾀ
        .lpstrFileTitle = String(256, Chr(0))
        '最大ﾌｧｲﾙ長の設定
        .nMaxFileTitle = 256
        'ﾃﾞﾌｫﾙﾄﾃﾞｨﾚｸﾄﾘの設定
        .lpstrInitialDir = strDefDir
        'ﾀﾞｲｱﾛｸﾞのﾀｲﾄﾙを設定
        '.lpstrTitle = "ﾌｧｲﾙを開く"
        'ｵﾌﾟｼｮﾝの設定
        .flags = OFN_EXPLORER Or OFN_PATHMUSTEXIST _
            Or OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY

    End With
    
    '[ﾌｧｲﾙを開く]ﾀﾞｲｱﾛｸﾞの表示
    If GetOpenFileName(typOpenFileName) = 0 Then
        'ｷｬﾝｾﾙされた場合
        ShowOpenFileDlg = ""
    Else
        'OKﾎﾞﾀﾝを押された場合、ﾌｧｲﾙ名の表示
        'Null文字の除去
        ShowOpenFileDlg = Left(typOpenFileName.lpstrFile, _
                InStr(typOpenFileName.lpstrFile, vbNullChar) - 1)
    End If

End Function

	コモンダイアログでのフォルダ選択

Option Explicit

'SHBrowseForFolderqで使用する構造体
Public Type BROWSEINFO
   hwndOwner As Long    '親Windowのハンドル
   pidlRoot As Long     'ルートフォルダ
   pszDisplayName As String
   lpszTitle As String  'ダイアログに表示するメッセージ
   ulFlags As Long      'オプション
   lpfn As Long
   lParam As Long
   iImage As Long
End Type

'ルートフォルダ定数
Public Const CSIDL_DESKTOP = &H0           'デスクトップ
Public Const CSIDL_PROGRAMS = &H2          'プログラム
Public Const CSIDL_CONTROLS = &H3          'コントロールパネル
Public Const CSIDL_PRINTERS = &H4          'プリンター
Public Const CSIDL_PERSONAL = &H5          'パーソナル
Public Const CSIDL_FAVORITES = &H6         'ブックマーク
Public Const CSIDL_STARTUP = &H7           'スタートアップ
Public Const CSIDL_RECENT = &H8            '[最近使ったファイル]
Public Const CSIDL_SENDTO = &H9            '[送る]
Public Const CSIDL_BITBUCKET = &HA
Public Const CSIDL_STARTMENU = &HB         '[スタート]メニュー
Public Const CSIDL_DESKTOPDIRECTORY = &H10 'デスクトップ
Public Const CSIDL_DRIVES = &H11
Public Const CSIDL_NETWORK = &H12
Public Const CSIDL_NETHOO = &H13           'Network Neighborhood
Public Const CSIDL_FONTS = &H14            'フォント
Public Const CSIDL_TEMPLATES = &H15        'Shell New

'特殊フォルダ(マイコンピュータ、コントロールパネル等)を選択させない
Public Const BIF_BROWSEFORCOMPUTER = 1

'[フォルダの参照]ダイアログを呼び出すAPI
Public Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBROWSEINFO As BROWSEINFO) As Long

'SHBrowseForFolderで得られた値からフォルダのパスを取得するAPI
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Private Sub Command1_Click()

    Dim typBROWSEINFO As BROWSEINFO
    Dim lngFoldPointer As Long
    Dim strPathName As String



    '[フォルダの参照]ダイアログを呼び出す
    lngFoldPointer = SHBrowseForFolder(typBROWSEINFO)

    '予めNull文字をセット
    strPathName = String$(128, vbNullChar)
    'SHBrowseForFolderで得られた値からフォルダのパスを取得
    SHGetPathFromIDList lngFoldPointer, strPathName

    '結果表示
    Label1.Caption = strPathName
    
End Sub

			ファイルの存在を確認する

'--------------------------------------------------------
'   関数名  : GetFileExistence
'   用途    : ファイルが存在するかどうか調べる
'   引数    : strPathName ファイル・ディレトクリ(パス)名
'   戻り値  : True ファイルは存在する
'             False ファイルは存在しない
'--------------------------------------------------------
Public Function GetFileExistence(strPathName As String) As Boolean
    
    '引数のサイズを格納/ファイル番号を格納
    Dim lngPNameSize As Long

    'エラーを無効にしておく
    On Error Resume Next

    If strPathName = "" Then
        '引数のファイル名・パス名がセットされていない
        'Nullをセットして
        GetFileExistence = ""
        '関数を抜ける
        Exit Function
    End If

    'パス名の最後にディレクトリ記号がある場合は削除
    If Right(strPathName, 1) = "\" Then
        
        'パスのサイズ-1を格納
        lngPNameSize = Len(strPathName) - 1
        '最後の一文字を取り除く
        strPathName = Left(strPathName, lngPNameSize)
    
    End If
    
    'ファイルを開いて、エラーかどうか確かめる
    '現在使用可能なファイル番号を割り振る
    lngPNameSize = FreeFile
    
    'では、開く
    Open strPathName For Input As lngPNameSize
    
    'エラー番号を調べる。0は「ファイルがあった」
    If Err = 0 Then
        '「ファイルがありました」をセット
        GetFileExistence = True
    Else
        '「ファイルは、なかったよ」をセット
        GetFileExistence = False
    End If
    
    Close lngPNameSize
    
    'エラー値を初期化
    Err = 0

End Function
 

   ディレクトリごとのコピー
   
'SourcePath から CopyPath へディレクトリごとのコピーです。
Public Function CopyFileUnderPath(ByVal SourcePath As String, ByVal CopyPath As String) As Boolean

Dim CopName As String, Msg As String
    'ｺﾋﾟｰ先のﾃﾞｨﾚｸﾄﾘを作成します
    'SourcePath 内のﾃﾞｨﾚｸﾄﾘの名前を取得します
    CopyFileUnderPath = True
    CopName = Dir(SourcePath, vbDirectory)   ' 最初のﾃﾞｨﾚｸﾄﾘ(ﾌｧｲﾙ)名を返します
    Do While CopName <> ""   'ﾙｰﾌﾟを開始します
        'Debug.Print CopName
        '現在のﾃﾞｨﾚｸﾄﾘと親ﾃﾞｨﾚｸﾄﾘは無視します
        If CopName <> "." And CopName <> ".." Then
            'ﾋﾞｯﾄ単位の比較を行い、DelName がﾃﾞｨﾚｸﾄﾘかどうかを調べます
            If (GetAttr(SourcePath & CopName) And vbDirectory) = vbDirectory 
Then
                'ﾃﾞｨﾚｸﾄﾘならｺﾋﾟｰします
                On Error Resume Next
                If Not (GetAttr(CopyPath & CopName) And vbDirectory) = 
vbDirectory Then
                    MkDir (CopyPath & CopName)
                    Call CopyFileUnderPath(SourcePath & CopName & "\", CopyPath & CopName & "\")
                    CopName = Dir(SourcePath, vbDirectory)
                End If
                On Error GoTo 0
                CopName = Dir
            Else
                On Error GoTo TrapErr
                FileCopy SourcePath & CopName, CopyPath & CopName
                CopName = Dir
                On Error GoTo 0
            End If
        Else
            CopName = Dir
        End If
    Loop
    Exit Function
TrapErr:
    If Err.Number <> 0 Then
        Msg = "Error No." & Str(Err.Number) & "rises." & vbCrLf
        Msg = Msg & "(This mean '" & Err.Description & "' )" & vbCrLf
        Msg = Msg & "Stop purging." & vbCrLf
        Msg = Msg & "Check the file '" & SourcePath & CopName & "' ,and purge 
agein." & vbCrLf
        Msg = Msg & "Check the file '" & CopyPath & CopName & "' ,and purge 
agein."
        MsgBox Msg, vbCritical, "PURGE ERROR"
    End If
    On Error GoTo 0
    CopyFileUnderPath = False
    Exit Function
End Function

バブルソート

サブルーチンとして用意。

Sub BubbleSort(ArraySort() as Double, StartIndex as Long, EndIndex as Long)

	Dim i As Long, j As Long
	Dim TempDouble As Double

	For i = StartIndex To EndIndex - 1
		For j = i + 1 to EndIndex
			If ArraySort(i) > ArraySort(j) Then
				TempDouble = ArraySort(i)
				ArraySort(i) = ArraySort(j)
				ArraySort(j) = TempDouble
			End If
		Next j
	Next i
End Sub

クイックソート

サブルーチンとして用意。

Sub QuickSort(ArraySort() As Double, StartIndex As Long, EndIndex As Long)
	
	Dim Forward As Long, Backward As Long
	Dim Ref As Double, TempDouble As Double

	If StartIndex < EndIndex Then
		Ref = ArraySort(StartIndex)
		Forward = StartIndex
		Backward = EndIndex + 1
	
		Do While 1
			Do While Forward <= EndIndex
				Forward = Forward + 1
				If ArraySort(Forward) >= Ref Then Exit Do
			Loop
			Do While Backward >= StartIndex
				Backward = Backward - 1
				If ArraySort(Backward) < = Ref Then Exit Do
			Loop
			If Forward >= Backward Then Exit Do

			TempDouble = ArraySort(Forward)
			ArraySort(Forward) = ArraySort(Backward)
			ArraySort(Backward) = TempDouble
		Loop
		ArraySort(StartIndex) = ArraySort(Backward)
		ArraySort(Backward) = Ref

		QuickSort ArraySort(), StartIndex, Backward - 1
		QuickSort ArraySort(), Backward + 1, EndIndex
	End If
End Sub