【 ＶＢＡサンプルプログラム 】
コピー先のリスト内でのデータ移動が容易にできるＶＢＡプログラム。（最新版）
Dim Mx As Integer, Lx As Integer, Dp As Integer, Ip As Integer
Dim ClpId As Integer, RpFg As Integer, Sbsz As Integer, MdFg As Integer
Dim Temp As String
Private Sub UserForm_Initialize()
ListBox1.List = _
Array("Excel", "Access", "word", "Outlook", "PowerPoint", "FrontPage", "VisualWebDeveloper", "VisualBasic", "SQL Server")
Mx = 0: Lx = 0: ClpId = 0: RpFg = 1: Sbsz = 18: MdFg = 0
End Sub
Private Sub ListBox1_AfterUpdate()
ClpId = ListBox1.ListIndex
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim Fg As Integer
ClpId = ListBox1.ListIndex
If RpFg = 1 Then
Call Rp_Check(ClpId, Fg)
End If
If Fg = 0 Then
ListBox2.SetFocus
ListBox2.AddItem ListBox1.List(ClpId)
Mx = ListBox2.ListCount
Y0 = Mx - 1: Lx = Y0
ListBox2.ListIndex = Y0
End If
End Sub
Private Sub ListBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
MdFg = 1
End Sub
Private Sub ListBox1_MouseMove(ByVal Button As _
Integer, ByVal Shift As Integer, ByVal X As _
Single, ByVal Y As Single)
Dim MyDataObject1 As DataObject
Dim Effect As Integer
If Button = 1 And ListBox1.Value > 0 Then
Lx = -1
Set MyDataObject1 = New DataObject
MyDataObject1.SetText ListBox1.Value
Effect = MyDataObject1.StartDrag
End If
End Sub
Private Sub ListBox2_BeforeDragOver(ByVal Cancel As _
MSForms.ReturnBoolean, ByVal Data As _
MSForms.DataObject, ByVal X As Single, _
ByVal Y As Single, ByVal DragState As Long, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
Cancel = True
Effect = 1
Y0 = (Y * 1000 / 975) \ 10
If Y0 <> Lx Then
If Y0 >= 0 And Y0 < Mx Then
ListBox2.ListIndex = Y0: Lx = Y0
Else
If Y0 >= Mx Then Y0 = Mx - 1
ListBox2.ListIndex = Y0: Lx = Y0
End If
End If
End Sub
Private Sub ListBox2_BeforeDropOrPaste(ByVal _
Cancel As MSForms.ReturnBoolean, _
ByVal Action As Long, ByVal Data As _
MSForms.DataObject, ByVal X As Single, _
ByVal Y As Single, ByVal Effect As _
MSForms.ReturnEffect, ByVal Shift As Integer)
Cancel = True
Effect = 1
Dim Fg As Integer
If RpFg = 1 Then
Call Rp_Check(ClpId, Fg)
End If
If Fg = 0 Then
ListBox2.AddItem Data.GetText
If ListBox2.ListCount > 1 Then
Call Lst2_Ins(ClpId)
Else
ListBox2.ListIndex = ListBox2.ListCount - 1
End If
End If
Mx = ListBox2.ListCount
End Sub
Private Sub ListBox2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
MdFg = 1
End Sub
Private Sub ListBox2_MouseMove(ByVal Button As _
Integer, ByVal Shift As Integer, ByVal X As _
Single, ByVal Y As Single)
If Button = 1 Then
If X >= 0 And X < (ListBox2.Width - Sbsz) And Y >= 0 And Y < ListBox2.Height Then
If MdFg = 1 Then
Dp = ListBox2.ListIndex
MdFg = 2
End If
End If
End If
End Sub
Private Sub ListBox2_MouseUp(ByVal Button As _
Integer, ByVal Shift As Integer, ByVal X As _
Single, ByVal Y As Single)
If Dp >= 0 Then
Temp = ListBox2.List(Dp)
End If
If MdFg = 2 Then
If X >= 0 And X < (ListBox2.Width - Sbsz) And Y >= 0 And Y < ListBox2.Height Then
If Button = 1 And Dp >= 0 Then
Ip = ListBox2.ListIndex
If Ip <> Dp Then
Call Lst2_Del(Dp)
Call Lst2_Ins0(Ip, Temp)
End If
End If
End If
End If
MdFg = 0
End Sub
Sub Rp_Check(ChkId As Integer, Ch As Integer)
Dim P As Integer
For P = 0 To ListBox2.ListCount - 1
If ListBox2.List(P) = ListBox1.List(ChkId) Then Ch = 1
Next
End Sub
Sub Lst2_Ins(InsId As Integer)
Dim P As Integer
If ListBox2.ListIndex < 0 Then ListBox2.ListIndex = ListBox2.ListCount - 1
For P = ListBox2.ListCount - 2 To ListBox2.ListIndex Step -1
ListBox2.List(P + 1) = ListBox2.List(P)
Next
ListBox2.List(ListBox2.ListIndex) = ListBox1.List(InsId)
End Sub
Sub Lst2_Del(DelId As Integer)
Dim P As Integer
For P = DelId To ListBox2.ListCount - 2
ListBox2.List(P) = ListBox2.List(P + 1)
Next
End Sub
Sub Lst2_Ins0(InsId As Integer, Tmp As String)
Dim P As Integer
For P = ListBox2.ListCount - 2 To InsId Step -1
ListBox2.List(P + 1) = ListBox2.List(P)
Next
ListBox2.List(InsId) = Tmp
End Sub
© Rakuten Group, Inc.
