Mã nguồn chương trình đấu giá của Nguyễn Duy Tuân
Code trong file trên đây:
[GPECODE=vb]
'===========================================
'Tac gia: Nguyen Duy Tuan - Tel: 0904210337
'Email:
duytuan@bluesofts.net - Website:
www.bluesofts.net
'===========================================
Option Explicit
Public Const WM_SETTEXT = &HC
Public Declare Function DefWindowProc Lib "user32.dll" Alias "DefWindowProcW" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'idxRegion: 0..2
Function GetSheetNameByIndexRegion(ByVal idxRegion As Long) As String
GetSheetNameByIndexRegion = Choose(idxRegion + 1, snDATA_BAC, snDATA_TRUNG, snDATA_NAM)
End Function
Function GetRangeByIndexRegion(ByVal idxRegion As Long) As Range
Dim lEndRow As Long
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets(GetSheetNameByIndexRegion(idxRegion))
lEndRow = sh.Range("A" & sh.Columns(1).Rows.Count).End(xlUp).Row
Set GetRangeByIndexRegion = sh.Range("A" & PRICE_START_ROW & ":" & "A" & lEndRow)
Set sh = Nothing
End Function
Function GetRegionName(ByVal idxRegion As Long) As String
GetRegionName = Choose(idxRegion + 1, ThisWorkbook.Sheets(snSETTING).Cells(8, 1), _
ThisWorkbook.Sheets(snSETTING).Cells(9, 1), _
ThisWorkbook.Sheets(snSETTING).Cells(10, 1))
End Function
Function ConvertToNum(ByVal sNum As String) As Double
sNum = Replace(sNum, ".", "")
sNum = Replace(sNum, ",", "")
ConvertToNum = CDbl(sNum)
End Function
Function RegionToArray(ByVal idxRegion As Long, ByRef ArrRegion As Variant, Optional ByVal strSearch As String = vbNullString) As Long
Dim rngList As Range
Dim I As Long, aCount As Long
Dim Found As Boolean
Set rngList = GetRangeByIndexRegion(idxRegion)
RegionToArray = 0
ReDim ArrRegion(0) As String
For I = 1 To rngList.Rows.Count
If Len(rngList(I)) > 0 Then
If strSearch <> vbNullString Then
Found = LCase(rngList(I)) Like "*" & LCase(strSearch) & "*"
Else
Found = True
End If
If Found Then
RegionToArray = RegionToArray + 1
ReDim Preserve ArrRegion(RegionToArray) As String
ArrRegion(RegionToArray) = rngList(I)
End If
End If
Next I
Set rngList = Nothing
End Function
Function GotoSheet(ByVal SheetName As String) As Worksheet
On Error Resume Next
Dim sh As Worksheet
Set sh = ActiveWorkbook.Sheets(SheetName)
If (sh.Parent.Name <> ActiveWorkbook.Name) Or sh.Name <> ActiveSheet.Name Then
sh.Select
End If
Set GotoSheet = sh
Set sh = Nothing
End Function
Function ShowHideRibbon(ByVal bView As Boolean)
On Error GoTo Err_ShowHideRibbon
Dim bIsMin As Boolean, bMustPressF1 As Boolean
bIsMin = Application.CommandBars.Item("Ribbon").Height < 100
If bView = bIsMin Then
Application.SendKeys "^{F1}", True
End If
ShowHideRibbon = True
Exit Function
Err_ShowHideRibbon:
'MsgBox Err.Number & " " & Err.Description, vbCritical, "ShowHideRibbon"
ShowHideRibbon = False
End Function
Function IsWkbMain(wb As Workbook) As Boolean
If Not wkbMAIN Is Nothing Then
IsWkbMain = wkbMAIN.Name = wb.Name
End If
End Function
Sub SetUnicodeCaption(ByVal frm As UserForm, ByVal UnicodeString As String)
Dim hWnd&
hWnd = GetHwnd(frm.Caption)
DefWindowProc hWnd, WM_SETTEXT, 0, StrPtr(UnicodeString)
End Sub
Option Explicit
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private tip As BSTooltip
Private Sub chkApproval_OnClick()
On Error GoTo lbErr
Dim SHP As Shape
Set SHP = wkbMAIN.Sheets(snPRICE).Shapes("GRPSCREENINFO")
If chkApproval.Checked Then
SHP.Visible = msoTrue
Set SHP = SHP.GroupItems("SCREENINFO")
SHP.TextFrame2.TextRange.Text = Chr(13) & Chr(13) & """" & lblWinnerName & """" & Chr(13) & _
lblWinnerPrice
Frame1.Caption = UNC("Ngêi chiÕn th¾ng")
Else
SHP.Visible = msoFalse
Frame1.Caption = UNC("Ngêi tr¶ gi¸ cao nhÊt")
End If
Exit Sub
lbErr:
MsgBox Err.Number & ": " & Err.Description, vbCritical
End Sub
Private Sub cmdClear_OnClick()
If Not IsWkbMain(ActiveWorkbook) Then Exit Sub
If MsgBoxW("B¹n cã ch¾c ch¾n muèn xãa d÷ liÖu kh«ng?", vbYesNo + vbExclamation, "Xãa d÷ liÖu") = vbYes Then
Application.Range("DATA").Offset(1).ClearContents
End If
End Sub
Private Sub cmdHome_OnClick()
If Not IsWkbMain(ActiveWorkbook) Then Exit Sub
GotoSheet snMAIN
End Sub
Private Sub cmdQuit_OnClick()
DoQuit
End Sub
Private Sub edtBeginPrice_Enter()
If Not IsWkbMain(ActiveWorkbook) Then Exit Sub
edtBeginPrice.Text = Application.Range("BEGIN_PRICE")
End Sub
Private Sub edtBeginPrice_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Not IsWkbMain(ActiveWorkbook) Then Exit Sub
Application.Range("BEGIN_PRICE") = ConvertToNum(edtBeginPrice.Text)
edtBeginPrice.Text = Format(Application.Range("BEGIN_PRICE"), "#,##0")
End Sub
Private Sub edtStepPrice_Enter()
If Not IsWkbMain(ActiveWorkbook) Then Exit Sub
edtStepPrice.Text = Application.Range("STEP_PRICE")
End Sub
Private Sub edtStepPrice_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If Not IsWkbMain(ActiveWorkbook) Then Exit Sub
Application.Range("STEP_PRICE") = ConvertToNum(edtStepPrice.Text)
edtStepPrice.Text = Format(Application.Range("STEP_PRICE"), "#,##0")
End Sub
Private Sub Frame1_Click()
End Sub
Private Sub UserForm_Initialize()
Dim J As Long
'BSListView
Dim li As BSListItem
Dim lc As BSListColumn
If IsDestroying Then Exit Sub
BSListView1.hImageList = frmRes.ImageList1.hImageList
BSListView1.hSmallImageList = frmRes.ImageList1.hImageList
'Fill header to columns of listview
Dim rng As Range
Set rng = Application.Range("ANALYSIS").Offset(-1)
For J = 1 To rng.Columns.Count
BSListView1.Columns.Add(rng(1, J), IIf(J = 1, 140, 90)).Alignment = taCenter
Next J
LoadANALYSIS
Frame2.Caption = UNC("§iÒu kiÖn")
Frame1.Caption = UNC("Ngêi tr¶ gi¸ cao nhÊt")
edtBeginPrice.Text = Format(Application.Range("BEGIN_PRICE"), "#,##0")
edtStepPrice.Text = Format(Application.Range("STEP_PRICE"), "#,##0")
lblWinnerPrice.FORECOLOR = vbRed
'Tooltip
Set tip = New BSTooltip
tip.Title = UNC("Th«ng b¸o ngêi th¾ng cuéc")
tip.Prompt = UNC("Khi kh«ng cßn ai tr¶ gi¸ n÷a, chän môc nµy ®Ó th«ng b¸o ngêi th¾ng cuéc.")
tip.Icon = IconINFO
tip.ParentHandle = chkApproval.Handle
' BSTaskPaneX - Create Task pane
BSTaskPaneX1.Create Me, Application
BSTaskPaneX1.View = True
End Sub
Private Sub UserForm_Terminate()
Set tip = Nothing
BSTaskPaneX1.Remove
End Sub
Sub LoadANALYSIS()
Dim rngANALYSIS As Range
Dim li As BSListItem, I As Long, J As Long
If Not IsWkbMain(ActiveWorkbook) Then Exit Sub
Set rngANALYSIS = Application.Range("ANALYSIS")
For I = 1 To rngANALYSIS.Rows.Count 'Row
Set li = BSListView1.Items.Add(rngANALYSIS.Cells(I, 1), IIf(I = 3, 2, 1))
For J = 2 To rngANALYSIS.Columns.Count 'Column
If I <> 3 Then
li.SubItems.Add rngANALYSIS.Cells(I, J)
Else
'Amount
li.SubItems.Add Format(rngANALYSIS.Cells(I, J), "#,##0")
End If
Next J
Next I
End Sub
Sub SyncANALYSIS()
On Error Resume Next
Dim rngANALYSIS As Range
Dim li As BSListItem, I As Long, J As Long
If Not IsWkbMain(ActiveWorkbook) Then Exit Sub
Set rngANALYSIS = Application.Range("ANALYSIS")
For I = 1 To rngANALYSIS.Rows.Count 'Row
Set li = BSListView1.Items(I - 1)
If li.Text <> rngANALYSIS.Cells(I, 1) Then li.Text = rngANALYSIS.Cells(I, 1)
For J = 2 To rngANALYSIS.Columns.Count 'Column
If I <> 3 Then
If li.SubItems(J - 2) <> rngANALYSIS.Cells(I, J) Then li.SubItems(J - 2) = rngANALYSIS.Cells(I, J)
Else
'Amount
If ConvertToNum(li.SubItems(J - 2)) <> rngANALYSIS.Cells(I, J) Then
li.SubItems(J - 2) = Format(rngANALYSIS.Cells(I, J), "#,##0")
End If
End If
Next J
Next I
End Sub
Private Sub BSTaskPaneX1_OnGetTypeNameOfControl(ByVal ctrl As Variant, TypeNameOfControl As String)
'TypeNameOfControl = "OK" 'Set ctrl's BackColor as TaskPane's BackColor
TypeNameOfControl = TypeName(ctrl)
End Sub
Private Sub BSTimer1_OnTimer()
On Error GoTo lbEndSub
'BSLabel1.Text = Now
If Not IsWkbMain(ActiveWorkbook) Then Exit Sub
SyncANALYSIS
If lblWinnerName.Caption <> Application.Range("WINNER_NAME") Then
lblWinnerName.Caption = Application.Range("WINNER_NAME")
End If
If lblWinnerRegion.Caption <> Application.Range("WINNER_REGION") Then
lblWinnerRegion.Caption = Application.Range("WINNER_REGION")
End If
If lblWinnerPrice.Caption <> Application.Range("WINNER_PRICE") Then
lblWinnerPrice.Caption = Format(Application.Range("WINNER_PRICE"), "#,##0") & " VND"
End If
Exit Sub
lbEndSub:
If Err <> 0 Then
tip.Title = "ERROR"
tip.Prompt = Err.Number & ": " & Err.Description
tip.Icon = IconERROR
tip.Show
End If
End Sub
'===========================================
'Tac gia: Nguyen Duy Tuan - Tel: 0904210337
'Email:
duytuan@bluesofts.net - Website:
www.bluesofts.net
'Chuong trinh duoc xay dung cung voi Bluesofts ActiveX Controls (BSAC.ocx)
'Download BSAC.ocx tai:
http://bluesofts.net/giai-phap-phan-mem/bsac-bluesofts-activex-controls.html
'===========================================
Option Explicit
Private tip As BSTooltip
Private Sub BSListView1_OnDblClick()
cmdAddPrice_OnClick
End Sub
Private Sub BSTaskPaneX1_OnGetTypeNameOfControl(ByVal ctrl As Variant, TypeNameOfControl As String)
'TypeNameOfControl = "OK" 'Set ctrl's BackColor as TaskPane's BackColor
TypeNameOfControl = TypeName(ctrl)
End Sub
Private Sub cmdAddPrice_OnClick()
GotoSheet snPRICE
If Not IsWkbMain(ActiveWorkbook) Then Exit Sub
If BSListView1.Selected Is Nothing Then
MsgBoxW "B¹n h·y chän ngêi trong danh s¸ch.", vbCritical, "Kh«ng cã ®èi tîng"
Exit Sub
End If
If frmAddPrice Is Nothing Then
Load frmAddPrice
End If
frmAddPrice.lblNick.Caption = BSListView1.Selected.Text
frmAddPrice.Show False
End Sub
Private Sub cmdRefresh_OnClick()
LoadListNicks
End Sub
Private Sub edtSearch_OnChange()
LoadListNicks edtSearch.Text
If BSListView1.Items.Count > 0 Then
BSListView1.ItemIndex = 0
End If
End Sub
Private Sub grpRegions_OnClick(ByVal ItemIndex As Long)
LoadListNicks
End Sub
Private Sub UserForm_Initialize()
Dim I&, J&, k&
'BSListView
Dim li As BSListItem
Dim lc As BSListColumn
If IsDestroying Then Exit Sub
BSListView1.hImageList = frmRes.ImageList1.hImageList
BSListView1.hSmallImageList = frmRes.ImageList1.hImageList
BSListView1.Hint = UNC("NhÊp ®óp chuét vµo tªn ®Ó nhËp gi¸.")
Set lc = BSListView1.Columns.Add(UNC("Danh s¸ch tham dù"), BSListView1.Width - 4, 1)
lc.Alignment = taCenter
edtSearch.TextHint = UNC("T×m tªn ë ®©y")
LoadListNicks
'Tooltip
Set tip = New BSTooltip
tip.Title = UNC("Tr¶ gi¸")
tip.Prompt = UNC("Chän ngêi trong danh s¸ch råi bÊm nót nµy ®Ó tr¶ gi¸. " & _
"B¹n còng cã thÓ thùc hiÖn b»ng c¸ch nhÊp ®óp chuét vµo tªn ngêi trong danh s¸ch.")
tip.Icon = IconINFO
tip.ParentHandle = cmdAddPrice.Handle
'BSTaskPaneX
BSTaskPaneX1.Create Me, Application
BSTaskPaneX1.View = True
End Sub
Function LoadListNicks(Optional ByVal strSearch As String = vbNullString) As Long
Dim rngList As Range
Dim li As BSListItem, I As Long
Dim a() As String, aCount As Long
BSListView1.Items.Clear
aCount = RegionToArray(grpRegions.ItemIndex, a, strSearch)
For I = 1 To aCount
Set li = BSListView1.Items.Add(a(I), 1)
Next I
BSListView1.Columns(0).Text = UNC("Danh s¸ch tham dù (" & aCount & ")")
End Function
Private Sub UserForm_Resize()
On Error GoTo lbEndSub
With BSListView1
.Left = 0
.Width = Me.Width
.Height = Me.Height - 85
.Columns(0).Width = .Width + .Width \ 2 - 2
edtSearch.Left = 0
edtSearch.Width = .Width
grpRegions.Left = 0
grpRegions.Width = .Width
cmdAddPrice.Left = .Width - cmdAddPrice.Width - 1
End With
lbEndSub:
End Sub
Private Sub UserForm_Terminate()
Set tip = Nothing
BSTaskPaneX1.Remove
End Sub
Option Explicit
Const TOP_ROW = 3
Private Sub cmdCancel_OnClick()
Unload Me
End Sub
Private Sub cmdOk_OnClick()
On Error GoTo lbEndSub
Dim sh As Worksheet
Dim lEndRow As Long
GotoSheet snPRICE
Set sh = wkbMAIN.Sheets(snPRICE)
If (CDbl(edtPrice.Text) < Application.Range("WINNER_PRICE") + Application.Range("STEP_PRICE")) Then
MsgBoxW "Gi¸ ph¶i >= " & Format(Application.Range("WINNER_PRICE") + Application.Range("STEP_PRICE"), "#,##0"), vbCritical, "lçi nhËp gi¸"
Exit Sub
End If
If (CDbl(edtPrice.Text) < Application.Range("BEGIN_PRICE") + Application.Range("STEP_PRICE")) Then
MsgBoxW "Gi¸ ph¶i >= " & Format(Application.Range("BEGIN_PRICE") + Application.Range("STEP_PRICE"), "#,##0"), vbCritical, "lçi nhËp gi¸"
Exit Sub
End If
lEndRow = sh.Range("C" & sh.Columns(1).Rows.Count).End(xlUp).Row + 1
sh.Cells(lEndRow, 1) = lEndRow - TOP_ROW + 1
sh.Cells(lEndRow, 2) = CDbl(edtPrice.Text)
sh.Cells(lEndRow, 3) = lblNick.Caption
sh.Cells(lEndRow, 4) = GetRegionName(frmListNick.grpRegions.ItemIndex)
Set sh = Nothing
Exit Sub
Unload Me
lbEndSub:
If Err <> 0 Then
MsgBoxW Err.Number & ": " & Err.Description, vbCritical, "ERROR"
End If
End Sub
Private Sub edtPrice_OnKeyPress(Key As Integer)
If Key = 13 Then 'ENTER
cmdOk_OnClick
End If
End Sub
Private Sub UserForm_Initialize()
SetUnicodeCaption Me, UNC("Ph¸t gi¸")
GotoSheet snPRICE
End Sub
[/GPECODE]
