Buen día comunidad
Antes que nada este código lo encontré en la página Mehmet Ali Gokmen y me gustaría editar el llenado del framePerson del formulario frmMain.
Para este llenado el ejemplo es tomar del mismo libro una hoja llamada BaseVentan que cuenta con 38 columnas, el framePerson me gustaría llenarlos con la columna 2, 3, 8, 10, 11, 13, 27, 28 y 29, me gustaría que se mantenga toda la visualización y ejecución del userform.
Dejo el código espero que me puedan ayudar y de ante mano muchas gracias.
'********MOUSE MOVE ICON CODES*************************************************************************************************************
#If VBA7 And Win64 Then
' // 64bit
Private Declare PtrSafe Function LoadCursorBynum Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare PtrSafe Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
#Else
' // 32bit
Private Declare Function LoadCursorBynum Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
#End If
Public WithEvents mForm As MSForms.UserForm
Public WithEvents mPage As MSForms.MultiPage
Public WithEvents mFrame As MSForms.Frame
Public WithEvents actionFrame As MSForms.Frame
Public WithEvents pageFrame As MSForms.Frame
Public WithEvents TotalPageLabel As MSForms.Label
Public WithEvents headerFrame As MSForms.Frame
Public WithEvents headerLabel As MSForms.Label
Public WithEvents tData As MSForms.Label
Public WithEvents RowBack As MSForms.Label
Public WithEvents ActionButton As MSForms.Label
Public WithEvents ActionLabel As MSForms.Label
Public WithEvents actionRowBack As MSForms.Label
Public this As New clsPerson '#########
Public thisCol As New Collection
Public detCol As New Collection
Public LabelTop As Integer
Public LabelLeft As Integer
Public actionLabelTop As Integer
Private Function MouseMoveIcon()
Dim lngRet As Long
lngRet = LoadCursorBynum(0&, 32649&)
lngRet = SetCursor(lngRet)
End Function
Sub FormResize()
On Error Resume Next
With frmMain
With mFrame
.Width = frmMain.InsideWidth - mFrameWidth - 15
.Height = frmMain.InsideHeight - .Top - 60
End With
With pageFrame
.Left = mFrame.Width - pageFrame.Width - 20
.Top = mFrame.Top + mFrame.Height + 15
End With
headerFrame.Width = mFrame.Width - 4
actionFrame.Visible = False
TotalPageLabel.Top = mFrame.Top + mFrame.Height + 10
With frmMain.btnAddPerson '#########
.Left = mFrame.Width - 100
.ZOrder 0
End With
For i = 1 To rowCount
With mFrame
.Controls("ActionButton" & i).Left = mFrame.Width - 40
.Controls("RowBack" & i).Width = mFrame.Width - 5
End With
Next
End With
End Sub
Private Sub getTableData()
Connect
SQL = "Select * from tbl_Person"
rs.Open SQL, cn, 1, 3
rowCount = rs.RecordCount
End Sub
Function GetHeaderValue() As Variant
headers = Array("ID", "First Name", "Last Name", "Email", "Phone", "Job", "City", "Gender", "Birth Date") '#########
GetHeaderValue = headers
End Function
Public Sub TableDataList(Optional params As String, Optional isHeader As Boolean = False)
Dim colWidth As Variant
Dim tDataTop As Variant
Dim k As Integer, i As Integer
Dim arr
Dim arr2 As Variant
Dim StartTime As Double
Dim EndTime As Double
Dim ElapsedTime As Double
Set mForm = frmMain
Set mPage = frmMain.MultiPage1
Set mFrame = frmMain.framePerson '##########
Set actionFrame = frmMain.actionFramePerson '##########
Set pageFrame = frmMain.framePagingPerson '##########
Set headerFrame = frmMain.frameHeaderPerson '##########
Set TotalPageLabel = frmMain.lblTotalPagePerson '##########
colWidth = Array(40, 125, 85, 140, 85, 0, 125, 85, 85, 0, 85, 85, 85, 85, 0, 0, 0, 85)
tDataTop = Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
getTableData
With rs
colCount = .Fields.Count
rowCount = .RecordCount
End With
'##########HEADERS##################################################
If isHeader = True Then
With headerFrame
.Clear
.Caption = ""
.BorderStyle = fmBorderStyleSingle
.BorderStyle = fmBorderStyleNone
.ZOrder 1
LabelLeft = 17
For i = 0 To UBound(GetHeaderValue)
Set headerLabel = .Controls.Add("Forms.Label.1", "headerLabel" & i)
With headerLabel
.Caption = GetHeaderValue(i)
.Left = LabelLeft
.Top = 8
.Width = colWidth(i)
.Font.Name = "Nunito Bold"
.Font.Size = 11
.ForeColor = HeaderColor
.WordWrap = False
.BackStyle = fmBackStyleTransparent
' .BorderStyle = fmBorderStyleSingle
' .BorderColor = RGB(212, 212, 212)
.Tag = i
LabelLeft = LabelLeft + .Width + 1
End With
Set this = New clsPerson '##########
Set this.headerLabel = headerLabel
thisCol.Add this
Set headerLabel = Nothing
Next
.Width = LabelLeft + 15
End With
End If
'##########HEADERS##################################################
With mFrame
.Clear
.Caption = ""
.Width = mPage.Width - .Left - 10
.Height = mPage.Height - .Top - 55
.BorderStyle = fmBorderStyleSingle
.BorderStyle = fmBorderStyleNone
' // The number of lines to come is adjusted according to the frame height.
ListRows = ListRowCount(mFrame)
LastRecVal = PageNumber * ListRows
If rowCount > 0 Then
arr = rs.GetRows
'// array Transpose to arr2
Dim rCount As Integer
rCount = UBound(arr, 2)
ReDim arr2(LBound(arr) To UBound(arr, 2), 0 To colCount)
X = 0: k = 0
For i = LBound(arr) To UBound(arr, 2)
'//so that it does not give an error when the parameter is empty.
If params <> Empty Then
'//We write the column order we want instead of '2' to search
'//according to the order of the headers we have added.
If InStr(1, arr(1, i), params, vbTextCompare) <> 0 Then
For Y = 0 To colCount - 1
arr2(X, Y) = arr(Y, i)
Next
X = X + 1
End If
Else
For Y = 0 To colCount - 1
arr2(X, Y) = arr(Y, i)
Next
X = X + 1
End If
Next
Erase arr
arr = arr2
Erase arr2
TotalRecVal = X
rowCount = X
LabelTop = 0
If arrIndex > -1 Then _
arr = SelectionSort(arr, arrIndex) 'when HeaderLabel click,sorting data
For i = FirstRecVal - 1 To LastRecVal - 1 'rowCount
If i <= UBound(arr) Then
If arr(i, 0) <> Empty Then
Set RowBack = .Controls.Add("Forms.Label.1", "RowBack" & i + 1)
With RowBack
.Width = mFrame.Width - 5
.Left = 1
.Height = 40
.Top = LabelTop
.BorderStyle = fmBorderStyleSingle
.BorderColor = RGB(212, 212, 212)
.BackColor = vbWhite
LabelLeft = 10
For k = 0 To UBound(GetHeaderValue)
Set tData = mFrame.Controls.Add("Forms.Label.1", GetHeaderValue(k) & i + 1)
With tData
.Width = colWidth(k)
If arr(i, k) <> Empty Then
.Caption = arr(i, k)
Else
.Caption = ""
End If
.Font.Name = "Nunito Medium"
.Font.Size = 10
.Top = LabelTop + tDataTop(k) + 12
.Height = 30
.WordWrap = True
.BackStyle = fmBackStyleTransparent
' .BorderStyle = fmBorderStyleSingle
.Left = headerFrame.Controls("headerLabel" & k).Left
.ForeColor = vbBlack 'vbGrayText
LabelLeft = LabelLeft + .Width
End With
Set this = New clsPerson '#########
Set this.tData = tData
Set this.RowBack = RowBack
Set this.mFrame = mFrame
Set this.actionFrame = actionFrame
thisCol.Add this
Next
Set ActionButton = mFrame.Controls.Add("Forms.Label.1", "ActionButton" & i + 1)
With ActionButton
.Left = mFrame.Width - 40
.Font.Name = "myicons"
.Font.Size = 18
.Caption = ChrW("&HE099")
.ForeColor = vbGrayText
.Top = LabelTop + 10
.AutoSize = True
.BackStyle = fmBackStyleTransparent
.Tag = arr(i, 0) & "-" & i + 1
End With
LabelTop = LabelTop + .Height + 3
'
End With 'RowBack End
Set this = New clsPerson '#########
Set this.ActionButton = ActionButton
Set this.RowBack = RowBack
Set this.actionFrame = actionFrame
Set this.mPage = mPage
Set this.mFrame = mFrame
Set this.mForm = mForm
thisCol.Add this
Set ActionButton = Nothing
End If
End If
Next
End If
'##########PAGING ELEMENT###############################
paging.AddPageElement mFrame, pageFrame, TotalPageLabel
'##########PAGING ELEMENT###############################
End With
FormResize
End Sub
'**************ACTION FRAME***********************************************************************************************
Private Sub ActionButton_Click()
Dim actionLabelIcon As MSForms.Label
Dim actionLabelCaption() As Variant
Dim ActionIcon As Variant
ActionIcon = Array("0033", "E0AC")
actionLabelCaption = Array("Edit", "Delete!")
With actionFrame
.Clear
.Caption = ""
.BackColor = NavFrameColor
.BorderStyle = fmBorderStyleSingle
' .BorderStyle = fmBorderStyleNone
.BorderColor = NavForeColor
.Width = 100
.Height = 100
.Top = ActionButton.Top + mFrame.Top - mFrame.ScrollTop
.Left = ActionButton.Left - .Width
.ZOrder 0
actionLabelTop = 10
For i = 1 To UBound(actionLabelCaption) + 1
Set ActionLabel = .Controls.Add("Forms.Label.1", "actionLabel" & i)
With ActionLabel
.Caption = actionLabelCaption(i - 1)
.Font.Name = "Nunito Medium"
.Font.Size = 11
.ForeColor = NavForeColor
.BackStyle = fmBackStyleTransparent
.Left = 34
.Top = actionLabelTop
.Tag = Split(ActionButton.Tag, "-")(0) & "-" & Split(ActionButton.Tag, "-")(1) & "-" & i
' .WordWrap = False
' .AutoSize = True
.Width = actionFrame.Width
Set actionLabelIcon = .Parent.Controls.Add("Forms.Label.1", "actionLabelIcon" & ActionLabel)
With actionLabelIcon
.Font.Name = "myicons"
.Font.Size = 14
.Caption = ChrW("&H" & ActionIcon(i - 1))
.Left = 10
.Top = ActionLabel.Top
.ForeColor = NavForeColor
.BackStyle = fmBackStyleTransparent
.AutoSize = True
' .BorderStyle = fmBorderStyleSingle
.ZOrder 1
End With
actionLabelTop = actionLabelTop + .Height + 14
End With
Set this = New clsPerson
Set this.ActionLabel = ActionLabel
Set this.actionFrame = actionFrame
Set this.mFrame = mFrame
detCol.Add this
Set ActionLabel = Nothing
Next
' // Action Label Row Back
Set actionRowBack = .Controls.Add("Forms.Label.1", "actionRowBack")
With actionRowBack
.Height = 28
.Visible = False
.Left = 0
.Width = actionFrame.Width - 2
.BackStyle = fmBackStyleTransparent
' .Picture = frmElement.ActionFrameRowBack.Picture
.ZOrder 1
End With
.Height = actionLabelTop
If .Top + .Height > mFrame.Top + mFrame.Height Then
.Top = ActionButton.Top + mFrame.Top - .Height - mFrame.ScrollTop + 20
End If
.Visible = True
End With
rowBackColorExit True
RowBack.BackColor = RowBackBackColor
End Sub
Private Sub ActionButton_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
MouseMoveIcon
End Sub
Private Sub actionFrame_Click()
End Sub
Private Sub actionLabel_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
MouseMoveIcon
End Sub
Function GetRowValue(colIndex As Integer, rowIndex As Integer)
head = GetHeaderValue(colIndex)
GetRowValue = mFrame.Controls(head & rowIndex)
End Function
Private Sub ActionLabel_Click()
Dim ActionOrder As Integer, ActionID As Integer
Dim recOrder As Integer
Dim accountName As String
ActionID = Split(ActionLabel.Tag, "-")(0)
recOrder = Split(ActionLabel.Tag, "-")(1)
actionFrame.Visible = False
Select Case ActionLabel.Caption
Case Is = "Edit"
Edit ActionID, recOrder
Case Is = "Delete!"
Delete ActionID
End Select
End Sub
' headers = Array("ID", "First Name", "Last Name", "Email", "Phone", "Job", "City", "Gender","Birth Date") '#########
Sub Edit(ActionID As Integer, recOrder As Integer)
With frmPerson
.txtID = ActionID
.txtFirstName = GetRowValue(1, recOrder)
.txtLastName = GetRowValue(2, recOrder)
.txtEmail = GetRowValue(3, recOrder)
.txtPhone = GetRowValue(4, recOrder)
.txtJob = GetRowValue(5, recOrder)
.txtCity = GetRowValue(6, recOrder)
.cbGender = GetRowValue(7, recOrder)
.txtBirthDate = GetRowValue(8, recOrder)
.Show
End With
End Sub
Private Sub Delete(ActionID As Integer) '#########
Dim answer As String
answer = MsgBox("Person will be delete! Are you sure?", vbYesNo, "Alert Message!")
If answer = vbYes Then
SQL = "Delete from tbl_person where ID = " & ActionID
cn.Execute SQL
MsgBox "Person Deleted!"
TableDataList frmMain.txtSearchPerson
End If
End Sub
'**************ACTION FRAME***********************************************************************************************
Private Sub headerLabel_Click()
arrIndex = headerLabel.Tag
If SortDirection = "asc" Then
SortDirection = "desc"
ElseIf SortDirection = "desc" Then
SortDirection = "asc"
Else
SortDirection = "asc"
End If
TableDataList
End Sub
Private Sub headerLabel_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
MouseMoveIcon
End Sub
Private Sub mForm_Click()
rowBackColorExit
End Sub
Private Sub mFrame_Click()
rowBackColorExit
End Sub
Private Sub mPage_Click(ByVal Index As Long)
rowBackColorExit
End Sub
Private Sub RowBack_Click()
rowBackColorExit
RowBack.BackColor = RowBackBackColor
End Sub
Private Sub tData_Click()
RowBack_Click
actionFrame.Visible = False
End Sub
Sub rowBackColorExit(Optional actionFramevisible As Boolean = False)
On Error Resume Next
If actionFramevisible = False Then
actionFrame.Visible = False
End If
For i = FirstRecVal To LastRecVal
mFrame.Controls("RowBack" & i).BackColor = vbWhite
Next
End Sub
