VB スタンダード

STD.bas

' ******************************************************
' 指定ディレクトリでエクスプローラを開く
' ******************************************************
Public Function lbExplorer(TargetPath)

    Call Run("Explorer /e," & TargetPath)

End Function

' ******************************************************
' フォームをデスクトップの中央に移動
' ******************************************************
Public Function lbCenterWindow(TargetForm As Form)

    With TargetForm
        .Move (Screen.Width - .Width) / 2, (Screen.Height - .Height) / 2
    End With

End Function

' ************************************************************
'  カーソルの砂時計の ON と OFF
' ************************************************************
Public Function lbWaitCursor(TargetForm As Form, bFlg As Boolean)

    If bFlg Then
        TargetForm.MousePointer = 11
    Else
        TargetForm.MousePointer = 0
    End If
    TargetForm.Refresh

End Function

' ******************************************************
' 文字列の種類をチェック
' ******************************************************
Public Function lbCheckString( _
    strTarget As String, _
    strGroup As String _
) As Boolean

    Dim i As Integer
    Dim char As String
    
    For i = 1 To Len(strTarget)
        char = Mid(strTarget, i, 1)
        If InStr(strGroup, char) = 0 Then
            lbCheckString = False
            Exit Function
        End If
    Next

    lbCheckString = True

End Function

' ******************************************************
' 指定した文字列集合に含まれるかどうかをチェック
' ******************************************************
Public Function lbCheckStringCase( _
    strTarget As String, _
    strGroup As String, _
    bFlg As Boolean _
) As Boolean

    Dim i As Integer
    Dim char
    
    char = Split(strGroup, ",")
    
    For i = 0 To UBound(char)
        If bFlg Then
            If char(i) = strTarget Then
                lbCheckStringCase = True
                Exit Function
            End If
        Else
            If UCase(char(i)) = UCase(strTarget) Then
                lbCheckStringCase = True
                Exit Function
            End If
        End If
    Next

    lbCheckStringCase = False

End Function

' ******************************************************
' テキストボックス内の文字列を選択する
' ******************************************************
Public Function lbSelectText(txtTarget As TextBox)

    txtTarget.SelStart = 0
    txtTarget.SelLength = Len(txtTarget.Text)

End Function

' ******************************************************
' MaxLength値より、Textboxを前ゼロ編集する
' ******************************************************
Public Function lbEditZeroText(txtTarget As TextBox)

    If txtTarget.MaxLength > 0 Then
        txtTarget.Text = Format(txtTarget.Text, String(txtTarget.MaxLength, "0"))
    End If

End Function

' ******************************************************
' 日付チェック
' ******************************************************
Public Function lbDateCheck(strData As String) As Long

    Dim strWork As String
    
    ' 文字数チェック(8文字必須)
    strWork = Replace(strData, "/", "")
    If Len(strWork) <> 8 Then
        lbDateCheck = 1
        Exit Function
    End If

    Dim strYYYY, strMM, strDD As String

    strYYYY = Left(strWork, 4)
    strMM = Mid(strWork, 5, 2)
    strDD = Right(strWork, 2)

    ' 月のチェック
    If Val(strMM) > 12 Or Val(strMM) < 1 Then
        lbDateCheck = 2
        Exit Function
    End If

    Dim bError As Boolean

    bError = False

    ' 日のチェック
    Select Case Val(strMM)
        Case 4
            If Val(strDD) > 30 Or Val(strDD) < 1 Then
                bError = True
            End If
        Case 6
            If Val(strDD) > 30 Or Val(strDD) < 1 Then
                bError = True
            End If
        Case 9
            If Val(strDD) > 30 Or Val(strDD) < 1 Then
                bError = True
            End If
        Case 11
            If Val(strDD) > 30 Or Val(strDD) < 1 Then
                bError = True
            End If
            
        Case 2
            If (Val(strYYYY) Mod 4) = 0 Then
                If Val(strDD) > 29 Or Val(strDD) < 1 Then
                    bError = True
                End If
            Else
                If Val(strDD) > 28 Or Val(strDD) < 1 Then
                    bError = True
                End If
            End If
            
        Case Else
            If Val(strDD) > 31 Or Val(strDD) < 1 Then
                bError = True
            End If
            
    End Select
    
    If bError Then
        lbDateCheck = 3
        Exit Function
    End If
    
    lbDateCheck = 0

End Function

' ******************************************************
' 文字列をシングルクォーテーションで挟む
' ******************************************************
Public Function Ss(strData As String) As String

    Ss = "'" & strData & "'"

End Function

' ******************************************************
' 文字列をダブルクォーテーションで挟む
' ******************************************************
Public Function Dd(strData As String) As String

    Dd = """" & strData & """"

End Function

' ******************************************************
' .Tag の n 番目の値を取得する
' ******************************************************
Public Function lbTag(TargetControl As Object, nIdx As Integer) As String

    Dim i As Integer
    Dim aTag
    
    aTag = Split(TargetControl.Tag, ",")
    
    If UBound(aTag) >= 0 Then
        If UBound(aTag) >= nIdx - 1 Then
            lbTag = aTag(nIdx - 1)
        Else
            lbTag = ""
        End If
    Else
        lbTag = ""
    End If

End Function

' ******************************************************
' フォーム上のクリア対象のコントロールをクリアする
' 対象コントロール
'     TextBox,Label,CheckBox,ComboBox
' ******************************************************
Public Function lbClear(TargetForm As Form, nIdx As Integer, TargetCD As String)

    Dim nCnt As Integer, i As Integer
    Dim strControlName As String
    
    nCnt = TargetForm.Count
    
    For i = 0 To nCnt - 1
    
        strControlName = TypeName(TargetForm(i))
    
        If Not lbCheckStringCase(strControlName, _
            "TextBox,Label,CheckBox,ComboBox", False) Then
        Else
            If lbTag(TargetForm(i), nIdx) = TargetCD Then
    
                Select Case strControlName
                    Case "TextBox"
                        TargetForm(i).Text = ""
                    Case "Label"
                        TargetForm(i).Caption = ""
                    Case "CheckBox"
                        TargetForm(i).Value = 0
                    Case "ComboBox"
                        TargetForm(i).ListIndex = -1
                End Select
            
            End If
    
        End If
    Next

End Function

' ******************************************************
' MaxLength値より、Textboxの入力バイト数オーバをチェック
' ******************************************************
Public Function lbCheckTextMax(txtTarget As TextBox) As Boolean

    If txtTarget.MaxLength > 0 Then
        If LenB(StrConv(txtTarget.Text, vbFromUnicode)) > txtTarget.MaxLength Then
            lbCheckTextMax = False
            Exit Function
        End If
    End If
            
    lbCheckTextMax = True

End Function

' ******************************************************
' フォーム上のオブジェクトの連想配列を作る
' ******************************************************
Public Function lbAllObject(curForm As Form, myDic As Object)

    Set myDic = CreateObject("Scripting.Dictionary")
    
    Dim nCnt As Integer, i As Integer
    
    nCnt = curForm.Count
    
    For i = 0 To nCnt - 1
    
        myDic.Add curForm(i).Name, curForm(i)
    
    Next

End Function

' ******************************************************
' 連想配列のキーを格納した配列を取得
' ******************************************************
Public Function lbGetKeyArray(myDic As Object)

    lbGetKeyArray = myDic.Keys

End Function

' ******************************************************
' 連想配列の値を格納した配列を取得
' ******************************************************
Public Function lbGetValueArray(myDic As Object)

    lbGetValueArray = myDic.Items

End Function

連想配列のサンプル

Dim User As String
Dim Password As String
Dim objAll As Object

' ************************************************************************
'
' ************************************************************************
Private Sub Form_Load()

    Call WshGetNetworkDrives(Grid)

    ' パスワードをレジストリより取得
    User = GetSetting("Connect", "lightbox", "User")
    Password = GetSetting("Connect", "lightbox", "password")

    ' 全てのコントロールを連想配列化
    Call lbAllObject(Me, objAll)
    
    Dim KeyValue
    
    ' Key 部分の配列を取得
    KeyValue = lbGetKeyArray(objAll)
    
    Dim i
    Dim strWork
    Dim strWork2
    Dim strDrive
    
    For i = 0 To objAll.Count - 1
        
        ' xxxx_xxxx接続 --> \\xxxx\xxxx 接続
        strWork = Replace(objAll(KeyValue(i)).Name, "_", "\")
        strWork = Replace(strWork, "接続", " 接続")
        strWork = Replace(strWork, "切断", " 切断")
        
        ' コントロール名に "切断" と含まれているものを Disable にする
        If InStr(KeyValue(i), "切断") <> 0 Then
            objAll(KeyValue(i)).Enabled = False
            strDrive = ConExist(Grid, "\\" & Replace(strWork, " 切断", ""))
            
            ' 既に接続されている場合の処理
            If strDrive <> "" Then
                objAll(KeyValue(i)).Enabled = True
                
                ' 接続ボタンのコントロール名
                strWork2 = Replace(objAll(KeyValue(i)).Name, "切断", "接続")
                objAll(strWork2).Enabled = False
                objAll(strWork2).Tag = strDrive
            End If
        End If
        
        ' ボタンのキャプションをコントロール名より作成
        If TypeName(objAll(KeyValue(i))) = "CommandButton" Then
            objAll(KeyValue(i)).Caption = "\\" & strWork
        End If
        
    Next

End Sub

' ************************************************************************
'
' ************************************************************************
Public Function ConExist(objGrid As MSHFlexGrid, Target As String)

    Dim i
    
    For i = 1 To objGrid.Rows - 1
        If objGrid.TextMatrix(i, 2) = Target Then
            ConExist = objGrid.TextMatrix(i, 1)
            Exit Function
        End If
    Next

    ConExist = ""

End Function

' ************************************************************************
'
' ************************************************************************
Public Function Connect(objControl As Object)

    Dim ControlName As String
    Dim UNC As String

    ControlName = objControl.Name
    UNC = Replace(ControlName, "接続", "")
    UNC = Replace(UNC, "_", "\")
    UNC = "\\" & UNC

    objControl.Tag = FS.FsGetFreeDrive(1)
    Call WSH.WshMapNetworkDrive(objControl.Tag, UNC, User, Password)

    objControl.Enabled = False
    ControlName = Replace(ControlName, "接続", "切断")
    objAll(ControlName).Enabled = True

End Function

' ************************************************************************
'
' ************************************************************************
Public Function DisConnect(objControl As Object)

    Dim ControlName As String
    Dim UNC As String
    
    ControlName = objControl.Name
    ControlName = Replace(ControlName, "切断", "接続")
    UNC = Replace(ControlName, "接続", "")
    UNC = Replace(UNC, "_", "\")
    UNC = "\\" & UNC
    
    If objAll(ControlName).Tag <> "" Then
        If vbYes = MsgBox(UNC & " を切断してもよろしいですか?", vbYesNo) Then
            Call WSH.WshRemoveNetworkDrive(objAll(ControlName).Tag)
            objControl.Enabled = False
            objAll(ControlName).Enabled = True
        End If
    End If

End Function

Private Sub sv20_public切断_Click()

    Call DisConnect(Me.ActiveControl)

End Sub

Private Sub sv20_public接続_Click()

    Call Connect(Me.ActiveControl)

End Sub