Form Picker (Access VBA)

Option Compare Database

Private m_bOk As Boolean
Private m_frmParent As Form
Private Sub cmdCancel_Click()
DoCmd.Close acForm, Me.Name
End Sub

Private Sub cmdOk_Click()
Dim strSourceControlName As String
Dim strDestinationControlName As String
Dim lngFindPos As Long

'lngFindPos = InStr(1, Nz(Me.OpenArgs), "-")
'If lngFindPos Then
'    strSourceControlName = Mid(Me.OpenArgs, 1, lngFindPos - 1)
'    strDestinationControlName = Mid(Me.OpenArgs, lngFindPos + 1)
'Else
'    strDestinationControlName = Nz(Me.OpenArgs)
'End If

strSourceControlName = Nz(Me.OpenArgs)
m_bOk = True
'Unload Me

'With Forms(m_frmParent.Name).Controls(strSourceControlName)
 '   .RowSource = vbNullString
 '   .RowSource = Me.TargetList()
'End With
Call setLVRowSourceProperty(Forms(m_frmParent.Name).Controls(strSourceControlName), _
    Me.TargetList())
DoCmd.Close acForm, Me.Name
End Sub

Private Sub cmdToDestination_Click()

If Not (Me.lbSource.ListIndex = -1) Then
    'Me.lbSource.AddItem strNewEntry, Me.lbSource.ListIndex + 1
    Me.lbDestination.AddItem lbSource.Value
    Me.lbSource.RemoveItem Me.lbSource.ListIndex
End If
End Sub

Private Sub cmdToSource_Click()
If Not (Me.lbDestination.ListIndex = -1) Then
    'Me.lbSource.AddItem strNewEntry, Me.lbSource.ListIndex + 1
    Me.lbSource.AddItem lbDestination.Value
    Me.lbDestination.RemoveItem Me.lbDestination.ListIndex
End If
End Sub

Public Property Let TargetList(ByVal strValue As String)
If Len(strValue) Then
    Me.lbDestination.RowSource = strValue
End If
End Property

Public Property Get TargetList() As String
    TargetList = Me.lbDestination.RowSource
End Property

Public Property Get bOK() As Boolean
bOK = m_bOk
End Property

Private Sub Command8_Click()
Dim i As Integer
With Me.lbSource
    .RowSourceType = "Value List"
    .RowSource = vbNullString
    .ColumnCount = 1
    .BoundColumn = 1
   ' .AddItem "Yankees;East;AL"
   ' .AddItem "Boston RedSox;East;AL"
   ' .AddItem "Floriday Marlins;East;AL"
    '.AddItem "Seattle Mariners;West;AL"
   ' .AddItem "NY Mets;East;NL"
    For i = 1 To 12
        .AddItem MonthName(i)
    Next
End With
End Sub

Private Sub Form_Load()
Const ssource As String = "Form_Load"
On Error GoTo ErrorHandler
DoCmd.Hourglass True
Dim strSQL As String, strTable As String
Dim rs As ADODB.Recordset
Dim objConn As ADODB.Connection
Dim i As Integer
Dim varItem As Variant
Dim strCriteria, aCriteria() As String
Dim strValue As String

Dim strControlName As String
Dim strSourceControlName As String
Dim strDestinationControlName As String
Dim lngFindPos As Long
Dim lbSource As Control 'ListBox

Set m_frmParent = Screen.ActiveForm
'lngFindPos = InStr(1, Nz(Me.OpenArgs), "-")
'If lngFindPos Then
'    strSourceControlName = Mid(Me.OpenArgs, 1, lngFindPos - 1)
'    strDestinationControlName = Mid(Me.OpenArgs, lngFindPos + 1)
'Else
'    strDestinationControlName = Nz(Me.OpenArgs)
'End If

strSourceControlName = Nz(Me.OpenArgs)
With Me
    .lbDestination.RowSourceType = "Value List"
    .lbDestination.ColumnCount = 1
    .lbSource.RowSourceType = "Value List"
    .lbSource.ColumnCount = 1
   
    'build lb's
    'Call Command8_Click
    'do not include user's selections
    '.lbDestination.RowSource = Forms(m_frmParent.Name).Controls(strSourceControlName).RowSource
    .lbDestination.RowSource = getLVRowSourceProperty(Forms(m_frmParent.Name).Controls(strSourceControlName))
End With

Set lbSource = Forms(m_frmParent.Name).Controls(strSourceControlName)
With Me.lbSource
   
    .RowSource = ""
    .RowSourceType = "Value List"
    .ColumnHeads = False
    .ColumnCount = 1
    .ColumnWidths = "2 in"
  
   
    'For Each varItem In lb.ItemsSelected
    '    strValue = strValue & lb.Column(1, varItem) & ","
    'Next
   
    '11/29 took out
    'strValue = lbSource.RowSource
    strValue = Me.lbDestination.RowSource
   
    aCriteria() = Split(strValue, ";")
    For i = LBound(aCriteria) To UBound(aCriteria)
        strCriteria = strCriteria & " " & " Note LIKE " & "'%" & aCriteria(i) & "%' OR"
    Next
    'avoid duplicating user's selections
    If Len(strCriteria) Then
        'remove trailing OR
        strCriteria = Left(strCriteria, Len(strCriteria) - 3)
        strSQL = "SELECT Note FROM tblLanguage WHERE " & _
        " NOT (" & strCriteria & " )" & _
        " ORDER BY Note "
    Else
        strSQL = "SELECT Note" & _
            " FROM tblLanguage " & _
            " ORDER BY Note"
    End If
   
    'Debug.Print strSQL
   
    Set rs = New ADODB.Recordset
    With rs
        .LockType = adLockOptimistic
        .CursorType = adOpenDynamic
    End With
   
    Set objConn = New ADODB.Connection
    Set objConn = CurrentProject.Connection
   
    rs.Open strSQL, objConn, Options:=adCmdText
    If Not (rs.EOF() And rs.BOF) Then
        strSQL = ""
        Do While Not rs.EOF
            For i = 0 To rs.Fields.Count - 1
                strSQL = strSQL & Nz(rs.Fields(i)) & ";"
            Next
            strSQL = Mid(strSQL, 1, Len(strSQL) - 1)
            .AddItem strSQL
            strSQL = ""
            rs.MoveNext
        Loop
    End If
  
End With

ExitProc:
    On Error Resume Next
    Set objConn = Nothing
    Set rs = Nothing
    DoCmd.Hourglass False
    Exit Sub

ErrorHandler:
   
    If bCentralErrorHandler("frmPicker", ssource) Then
        Stop
        Resume
    Else
        Resume ExitProc
    End If

End Sub

Private Sub Form_Open(Cancel As Integer)
If IsNull(Me.OpenArgs) Then
    Cancel = True
    Exit Sub
End If

End Sub

Private Sub lbDestination_DblClick(Cancel As Integer)
Call cmdToSource_Click
End Sub


Private Sub lbSource_DblClick(Cancel As Integer)
Call cmdToDestination_Click
End Sub