素人のVisualBasic
関数や、ソフト参考文などを掲示します。
 
VBマニア さん

Win-API さん



 
僕が、自作したプログラム郡を公開します。 ただし、個々のPCでは設定、OSの問題ですんなりとは動作しません。

とりあえず、CHIMEを作りました。
学校のチャイムをイメージしました。
ただ、チャイムがなるだけですが、設定時間に制限はありません。
曜日ごとに設定可能です。

ここでは、作り方をサンプルを表示しながら説明します。

 
 メインのページ (Form1)に記述する内容

 Option Explicit
1行目は変数の宣言を義務化します。 
変数の宣言。

Dim mystr
Dim mon, tue, wed, thrus, fri, sat, sun As String


Foam中のCommand1のボタンを
押したとき(クリック)の動作です。
この場合、アンロード ミイ はFoamを閉じる。
この場合プログラムを閉じることを意味します。

Private Sub Command1_Click()
Unload Me
End Sub


Private Sub Command2_Click()

With Me.CommonDialog1
 音楽ファイルを選択します。
Windows規定の選択画面(ダイアログ)が
表示され”WAV”ファイルを選択できます。

そのファイル名を、別の工程で取り込んだ
情報とともに"hour.ini"ファイルに書き込みます。

ファイルを開き

書き込み

ファイルを閉じます。

    .FileName = ""
    '.FileTitle = "Waveファイルを選択してください"
    .Filter = "*.wav|*.wav|*.*|*.*"
    .ShowOpen
    If .FileName = "" Then Exit Sub
    Me.Label2.Caption = .FileName
    m_n = .FileName
End With
    Open ("hour.ini") For Output As #1
            Print #1, Join(H_tmp, ",")
            Print #1, Join(H_str, ",")
            Print #1, m_n
         
        Close #1
End Sub


Private Sub del_Click()
 選択されたリストボックス(実行タイム)内の
データを削除します。
と、同時に ”clock.ini” の内容を書き換えます。
(同期処理)

スタートボタンの文字を "スタート" に戻します。
実行中の場合は、自動処理をストップし
待機状態にします。



    ct = on_List.ListIndex
    on_List.RemoveItem ct

    Open "clock.ini" For Output As #2
       
        For cutA = 0 To on_List.ListCount

            Print #2, on_List.List(cutA)
        Next
      
    Close #2
   
      tmpD = 1
 str.Caption = "スタート"
   
End Sub


 On Error〜はエラートラップです。エラーがあるときの
動作指示を指定します。

Private Sub Form_Load()
    On Error Resume Next
    on_List.Clear
   tmpD = 0
    mon = "": tue = "": wed = "": thrus = "": fri = "": sat = "": sun = ""
   
    nou_t.Caption = Time
この工程は、プログラムが、実行されたとき 
(起動したとき)Foamがロードされるタイミングで
実行されます。


各変数の初期化
リストボックスのクリヤー
ファイルを開き
ファイル内データを行単位で取り込みます。
”、”で区切り配列に格納します。





音楽ファイルをテキストボックスに表示。

ファイルを閉じます。


各コンボボックスに各設定値を入力します。









時間設定の記録ファイルを開きます。





リストボックスに追加します。
ファイルが、終端になるまで繰り返し。
ただし、空欄の行でエスケープします。
ファイルを閉じます。



        mystr = Format(Date, "aaa")
    H_tmp = CurDir
    If Not Dir("hour.ini") = "" Then
        Open ("hour.ini") For Input As #1
            Line Input #1, L_txt
            H_tmp = Split(L_txt, ",")
            Line Input #1, L_txt
            H_str = Split(L_txt, ",")
            L_txt = ""
            Line Input #1, L_txt
            m_n = L_txt
            Me.Label2.Caption = m_n
        Close #1
        For cut = 0 To UBound(H_tmp)
            Combo1.AddItem H_tmp(cut)
        Next
        For cut = 0 To UBound(H_str)
            on_time.AddItem H_str(cut)
        Next
       
    End If
   
    Open ("clock.ini") For Input As #3
        Do Until EOF(3)
            Line Input #3, L_txt
            If L_txt = "" Then Exit Do
            on_List.AddItem L_txt
        Loop
    Close #3
   
End Sub


Private Sub save_Click()

If on_time.Text = "" And Combo1.Text = "" Then
    Msg = "未入力の項目があります。"
    message
    Exit Sub
Else
    weekche
    path_A = Combo1.Text & ":" & on_time.Text & "," & path_B
End If

 cutA = 0
If Dir("clock.ini") = "" Then GoTo skip1
    Open "clock.ini" For Input As #2
  
    Do Until EOF(2)
        Line Input #2, L_txt
        If L_txt = "" Then GoTo skip1
       
        If L_txt = path_A Then
            path_A = ""
            Close #2
            Exit Sub    'on_List.AddItem L_txt
        End If
    Loop
   
skip1:
   Close #2
    If Not path_A = "" Then on_List.AddItem path_A
   
    Open "clock.ini" For Output As #2
        For cutA = 0 To (on_List.ListCount - 1)
            Print #2, on_List.List(cutA)
        Next
    Close #2
  
     path_B = " "
     path_A = " "
   tmpD = 1
 str.Caption = "スタート"
End Sub


 

Private Sub weekche()

    mon = "": tue = "": wed = "": thrus = "": fri = "": sat = "": sun = ""

    If Check7.Value = 1 Then sat = "土"
    If Check6.Value = 1 Then fri = "金"
    If Check5.Value = 1 Then thrus = "木"
    If Check4.Value = 1 Then wed = "水"
    If Check3.Value = 1 Then tue = "火"
    If Check2.Value = 1 Then mon = "月"
    If Check1.Value = 1 Then sun = "日"
   
    path_B = sun & "," & mon & "," & tue & "," & wed & "," & thrus & "," & fri & "," & sat
   
    If Option1.Value = True Then path_B = path_B & ",毎"
    If Option2.Value = True Then path_B = path_B & ",単"
 
End Sub

Private Sub str_Click()
cut = 0
    ReDim chime_t((on_List.ListCount - 1), 9)
    If m_n = "" Then
        Msg = "音楽ファイル未設定。"
        message
        Exit Sub
    End If
   
    For cut = 0 To (on_List.ListCount - 1)
        H_fot = Split(on_List.List(cut), ",")
        For cha = 0 To UBound(H_fot)
            chime_t(cut, cha) = H_fot(cha)
        Next
   
    Next
 tmpD = 99
 str.Caption = "実行中"
 
End Sub


Private Sub Timer1_Timer()

    nou_t.Caption = Time
    OGi = OGi + 1
    jikan = Split(nou_t.Caption, ":")
    OGi = jikan(2)
   
    If OGi = 0 And tmpD = 99 Then
        jikan = Split(nou_t.Caption, ":")
       
        jikan_A = jikan(0) & ":" & jikan(1)
        For cut = 0 To UBound(chime_t, 1)
            If jikan_A = chime_t(cut, 0) Then
                YOUB = Format(Date, "aaa")
                If chime_t(cut, 8) = "単" Then
                    Select Case YOUB
                           Case "日"
                                If chime_t(cut, 1) = "日" Then
                                    on_m
                                    chime_t(cut, 1) = ""
                                End If
                           Case "月"


                                If chime_t(cut, 2) = "月" Then
                                    on_m
                                    chime_t(cut, 2) = ""
                                End If
                           Case "火"
                                If chime_t(cut, 3) = "火" Then
                                    on_m
                                    chime_t(cut, 3) = ""
                                End If
                           Case "水"
                                If chime_t(cut, 4) = "水" Then
                                    on_m
                                    chime_t(cut, 4) = ""
                                End If
                           Case "木"
                                If chime_t(cut, 5) = "木" Then
                                    on_m
                                    chime_t(cut, 5) = ""
                                End If
                           Case "金"
                                If chime_t(cut, 6) = "金" Then
                                    on_m
                                    chime_t(cut, 6) = ""
                                End If
                           Case "土"
                                If chime_t(cut, 7) = "土" Then
                                    on_m
                                    chime_t(cut, 7) = ""
                                End If
                     End Select
                    
                     Debug_pc
                    
                     on_List.Clear
                    
                     Open ("clock.ini") For Input As #3
                        Do Until EOF(3)
                            Line Input #3, L_txt
                            If L_txt = "" Then Exit Do
                                on_List.AddItem L_txt
                        Loop
                    Close #3
                   
                ElseIf chime_t(cut, 8) = "毎" Then
                    Select Case YOUB
                           Case "日"
                                If chime_t(cut, 1) = "日" Then
                                    on_m
                                End If
                           Case "月"
                                If chime_t(cut, 2) = "月" Then
                                    on_m
                                End If
                           Case "火"
                                If chime_t(cut, 3) = "火" Then
                                    on_m
                                End If
                           Case "水"
                                If chime_t(cut, 4) = "水" Then
                                    on_m
                                End If
                           Case "木"
                                If chime_t(cut, 5) = "木" Then
                                    on_m
                                End If
                           Case "金"
                                If chime_t(cut, 6) = "金" Then
                                    on_m
                                End If
                           Case "土"
                                If chime_t(cut, 7) = "土" Then
                                    on_m
                                End If
                    End Select
                End If
            End If
        Next
     
    End If
   
End Sub


 

Public Sub on_m()


    'Waveファイルを再生する
    Call PlaySound(m_n, 0, 1)


End Sub
Public Sub Debug_pc()
Dim code
Dim aaa, aa, ABC As Integer
If IsArray(chime_t) = True Then


ReDim csv_out(UBound(chime_t, 1))

Open "clock.ini" For Output As #2
For aaa = 0 To UBound(chime_t, 1)
        ReDim code(UBound(chime_t, 2))
        ABC = 0

        For aa = 0 To UBound(chime_t, 2)
            If chime_t(aaa, aa) = "" Then ABC = ABC + 1
            code(aa) = chime_t(aaa, aa)
        Next
        csv_out(aaa) = Join(code, ",")
        If ABC <= 7 Then Print #2, csv_out(aaa)
       
Next
Close #2
End If
End Sub

 Module1に記述する内容

 Option Explicit
Declare Sub FloodFill Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long)    '改行無しで入れること
Declare Function Chord Lib "gdi32" ( _
    ByVal hDC As Long, _
    ByVal Left As Long, _
    ByVal Top As Long, _
    ByVal Right As Long, _
    ByVal Bottom As Long, _
    ByVal XRadial1 As Long, _
    ByVal YRadial1 As Long, _
    ByVal XRadial2 As Long, _
    ByVal YRadial2 As Long) As Long
Declare Function GetWindowsDirectory Lib "kernel32.dll" Alias "GetWindowsDirectoryA" _
    (ByVal lpBuffer As String, ByVal uSize As Long) As Long

Public Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" _
    (ByVal pszSound As String, ByVal hmod As Long, ByVal fdwSound As Long) As Long
Public Const SND_APPLICATION = &H80             'アプリケーション定義のサウンドを再生
Public Const SND_ALIAS = &H10000                'pszSoundは、システムイベント名
                                                '(SND_FILENAME、または
                                                'SND_RESOUCEと組み合わせない)
Public Const SND_ALIAS_ID = &H110000            '定義済みサウンドID
Public Const SND_ASYNC = &H1                    '非同期で再生
Public Const SND_FILENAME = &H20000             'pszSoundはファイル名
Public Const SND_LOOP = &H8                     '繰り返し再生
                                                '(中断する場合はファイル名に
                                                'vbNullStringを指定)
Public Const SND_MEMORY = &H4                   'サウンドデータをメモリ中にロード
                                                '(pszSoundはメモリ領域のアドレス)
Public Const SND_NODEFAULT = &H2                '指定のファイルがなくても
                                                'デフォルトを実行
Public Const SND_NOSTOP = &H10                  'ほかに再生中の場合は何もしない
Public Const SND_NOWAIT = &H2000                'サウンドドライバを使用中のとき、演奏し
                                                'ないですぐ戻る
Public Const SND_PURGE = &H40                   '再生を中止する
                                                'pszSoundがvbNullStringでないとき、
                                                '指定のサウンドのすべてのインスタンスを
                                                '中止する
Public Const SND_RESOURCE = &H40004             'pszSoundはりソースid
                                                '(hmodはインスタンスハンドルを設定)
Public Const SND_SYNC = &H0                     '演奏終了まで戻らない


Public Decision, jikan, csv_out As Variant
Public H_tmp, chime_t, H_str, H_fot As Variant

Public ctt, fcut, cheA, ct, str As Integer
Public cutA, cutB As Integer
Public cut, dt As Integer
Public tmpA, tmpB, tmpC, tmpD, OGi As Integer
Public che, cha As Integer

Public L_txt, YOUB, jikan_A As String
Public L_c, strCurFolder, m_n As String
Public path_A, path_B, Style, Title As String                      '移動元、移動先のパスを格納
Public Msg, Help, Ctxt, Response, MyString


 

 

 

Public Sub message()


'Msg = "続行しますか。"                  ' メッセージを定義します。
Style = vbOKOnly                             ' ボタンを定義します。
Title = "確認!"
Response = MsgBox(Msg, Style, Title)
End Sub


 

 

Public Sub message2()


'Msg = "続行しますか。"                  ' メッセージを定義します。
Style = vbOKCancel                             ' ボタンを定義します。

Response = MsgBox(Msg, Style, Title)
If Response = vbOK Then               ' [はい] がクリックされた場合、
   MyString = "Yes"                  ' 所定の動作を実行します。
Else   ' [いいえ] がクリックされた場合、
   MyString = "No"                  ' 所定の動作を実行します。
End If

End Sub