Option Explicit
Private Declare PtrSafe Function FindWindowA& Lib "User32" _
(ByVal lpClassName$, ByVal lpWindowName$)
Private Declare PtrSafe Function EnableWindow& Lib "User32" _
(ByVal hWnd&, ByVal bEnable&)
Private Declare PtrSafe Function GetWindowLongA& Lib "User32" _
(ByVal hWnd&, ByVal nIndex&)
Private Declare PtrSafe Function SetWindowLongA& Lib "User32" _
(ByVal hWnd&, ByVal nIndex&, ByVal dwNewLong&)
Dim NArt As Variant, CArt As Variant, Cat As Variant, Csk As Variant, _
CatSk As Variant, Ask As Variant, Ncm As Variant
Dim Prix#, Tva#, Frais#, Montant#, Total#, Prc@, Tva2&, Num&, LNom, LPrenom
Private Sub UserForm_Initialize()
Dim i%, k%
Me.Caption = "CONTRÔLES STOCK - LES MILLES MERVEILLES"
Call Init_Feuilles
tbl = WsProd.Range("A2:N" & WsProd.Range("d65536").End(xlUp).Row)
Num = WsBons.Range("z1").Value
Set d = New Dictionary
For i = 1 To UBound(tbl)
d(tbl(i, 5)) = tbl(i, 5) 'fournisseur
Next i
CmbFrn.List = d.ItemS
Set d = New Dictionary
For i = 1 To UBound(tbl)
d(tbl(i, 4)) = tbl(i, 4) 'catégorie
Next i
CmbCat.List = d.ItemS
ListBox1.ColumnCount = 2
ListBox1.ColumnWidths = "65;140"
Dim x As Long, Fichier As String
Fichier = ThisWorkbook.Path & "\tresor.ico"
x = Len(Dir(Fichier))
If x = 0 Then Exit Sub
x = ExtractIconA(0, Fichier, 0)
SendMessageA FindWindow(vbNullString, Me.Caption), &H80, False, x
Dim hWnd As Long
hWnd = FindWindowA(vbNullString, Me.Caption)
SetWindowLongA hWnd, -16, GetWindowLongA(hWnd, -16) Or &H20000
End Sub
Private Sub UserForm_Activate()
ListBox1.Clear
CmbCat = ""
CmbFrn = ""
TxtAchat = ""
TxtVente = ""
Label1.Caption = "Code article"
Label2.Visible = True
TxTResp = WsRep.Range("b3")
TxtDate = Format(Date, "dd.mm.yyyy")
Dim hWnd As Long
hWnd = FindWindowA("XLMAIN", Application.Caption)
EnableWindow hWnd, 1
End Sub
Private Sub CmbCat_Change()
Dim i As Long
If Me.CmbCat <> "" Then
Me.ListBox1.Clear
For i = LBound(Lignes) To UBound(Lignes)
If tbl(Lignes(i), 5) = Me.CmbFrn And tbl(Lignes(i), 4) = Me.CmbCat Then
Me.ListBox1.AddItem
Me.ListBox1.List(Me.ListBox1.ListCount - 1, 0) = tbl(Lignes(i), 2)
Me.ListBox1.List(Me.ListBox1.ListCount - 1, 1) = tbl(Lignes(i), 3)
End If
Next
End If
End Sub
Private Sub CmbFrn_Change()
Dim i As Long, d As New Dictionary, Ctrl As Control
If Me.CmbFrn <> "" Then
Me.CmbCat = ""
Me.ListBox1.Clear
For Each Ctrl In Me.Controls
If TypeOf Ctrl Is MSForms.TextBox Then Ctrl = ""
Next
ListeFournCat Me.CmbFrn 'module1
For i = LBound(Lignes) To UBound(Lignes)
If tbl(Lignes(i), 5) = Me.CmbFrn Then d(tbl(Lignes(i), 4)) = tbl(Lignes(i), 4)
Next
Me.CmbCat.List = d.ItemS
End If
End Sub
Private Sub ListBox1_Click()
Dim rw&, k&, j&, nb&, i As Long
If CmbFrn <> "" And CmbCat <> "" Then
For i = LBound(Lignes) To UBound(Lignes)
If tbl(Lignes(i), 2) = ListBox1.List(ListBox1.ListIndex, 0) Then
rw = Lignes(i) + 1: Exit For
End If
Next
Me.TxtEntree = WsStock.Cells(rw, 13)
Me.TxtSortie = WsStock.Cells(rw, 9)
For j = 2 To 12
Controls("TextBox" & j) = WsStock.Cells(rw, j)
Next j
End If
If Me.TxtEntree.Value = 0 Then Me.TxtEntree = ""
If Me.TxtSortie.Value = 0 Then Me.TxtSortie = ""
TxtAchat = Format(tbl(Lignes(i), 6), "0.00")
TxtVente = Format(tbl(Lignes(i), 7), "0.00")
End Sub
Private Sub CmdNouveau_Click()
Dim lig%, i As Byte
If CmbCat <> "" Then
With WsStock
lig = .Range("b65536").End(xlUp).Row + 1
.Cells(lig, 1) = lg - 1
For i = 2 To 13
.Cells(lig, i) = Controls("TextBox" & i)
Next i
End With
Else
Exit Sub
End If
If CmbFrn <> "" Then
With WsStock
lig = .Range("b65536").End(xlUp).Row + 1
.Cells(lig, 1) = lig - 1
For i = 2 To 13
.Cells(lig, i) = Controls("TextBox" & i)
Next i
End With
Else
Exit Sub
End If
For i = 2 To 13
Controls("TextBox" & i) = ""
Next i
TxtEntrees = ""
TxtSorties = ""
TxtAchat = ""
TxtVente = ""
End Sub
Private Sub CmdModifier_Click()
Dim i As Byte
With WsStock
Ask = Application.Match(TextBox3, .Columns(3), 0)
For i = 2 To 13
.Cells(Ask, i) = Controls("TextBox" & i)
If IsNumeric(Controls("TextBox" & i)) Then .Cells(Ask, i) = Format(Controls("TextBox" & i), "0")
Next i
End With
CmbCat = ""
CmbFrn = ""
For i = 2 To 13
Controls("TextBox" & i) = ""
Next i
TxtEntrees = ""
TxtSorties = ""
TxtAchat = ""
TxtVente = ""
End Sub
Private Sub CmdSupprimer_Click()
With WsStock
Ask = Application.Match(TextBox3, .Columns(3), 0)
.Rows(Ask).EntireRow.Delete
End With
End Sub
Private Sub CmdSupTous_Click()
Dim derlig&, lig&, k&, x&
With WsStock
derlig = .Cells(65536, 4).End(xlUp).Row
For x = derlig To 2 Step -1
If .Cells(x, 4) = CmbCat.Value Then .Cells(x, 4).Delete shift:=xlUp
Next x
lig = .Range("a65536").End(xlUp).Row
For k = 2 To lig
If .Cells(k, 2) <> "" Then .Cells(k, 1) = k - 1
Next k
End With
End Sub
Private Sub CmdAchats_Click()
Dim cel As Range, rw&, x%, premaddress, NomRes
Dim lig%, rech&, i As Byte, Nt&, Rpt$
Total = TxtAchat * TextBox13
Num = WsBons.Range("z1").Value
With WsFn
LPrenom = .Cells(Frs, 18)
LNom = .Cells(Frs, 19)
End With
With WsAchats
lig = .Range("a65536").End(xlUp).Row + 1
.Cells(lig, 1) = lig - 1
.Cells(lig, 2) = "BC - " & LPrenom & LNom & " " & Num
.Cells(lig, 3) = CmbFrn
.Cells(lig, 4) = TextBox2
.Cells(lig, 5) = TextBox3
.Cells(lig, 6) = TextBox4
.Cells(lig, 7) = Format(TextBox13, "0")
.Cells(lig, 8) = Format(TxtAchat, "0.00")
.Cells(lig, 9) = Format(Total, "0.00")
End With
On Error Resume Next
With WsBons
Set cel = WsAchats.Range("c2:c65536").Find(CmbFrn, , xlValues)
x = 17
If Not cel Is Nothing Then
premaddress = cel.Address
Do
x = x + 1
.Range("b" & x).Value = cel.Offset(0, 1).Value 'Code Article
.Range("c" & x).Value = cel.Offset(0, 2).Value 'Designation
.Range("d" & x).Value = cel.Offset(0, 4).Value 'Quantité
.Range("e" & x).Value = Format(cel.Offset(0, 5).Value, "0.00") 'Prix
.Range("f" & x) = Format(cel.Offset(0, 6).Value, "0.00")
Set cel = WsAchats.Range("c2:c65536").FindNext(cel)
Loop While Not cel Is Nothing And cel.Address <> premaddress
End If
.Range("f2") = "BC - " & LPrenom & LNom & " " & Num
.Range("f4") = Format(TxtDate, "dd.mm.yyyy")
.Range("f6") = CmbFrn
.Range("f7") = WsFn.Cells(Frs, 3) & " " & WsFn.Cells(Frs, 4)
.Range("f8") = WsFn.Cells(Frs, 6)
.Range("f9") = WsFn.Cells(Frs, 7) & " " & WsFn.Cells(Frs, 8)
Rpt = Application.Match(TxTResp, WsRep.Columns(2), 0)
NomRes = WsRep.Cells(Rpt, 5)
Nt = WsFn.Cells(Frs, 15)
Prix = WorksheetFunction.Sum(WsBons.Range("f18:f40"))
Prc = Val(Nt) / 100
Tva = Round(Prix * Prc, 1)
Frais = WsFn.Cells(Frs, 16)
Montant = Prix + Tva + Frais
.Range("b10") = WsC.Range("x1").Value & " " & WsRep.Cells(Rpt, 9)
.Range("b11") = WsC.Range("y1").Value & " " & WsRep.Cells(Rpt, 11)
.Range("f11") = TxTResp
.Range("f12") = NomRes
.Range("f45") = Prix
.Range("e46") = "Tva " & Nt & "%"
.Range("f46") = Tva
.Range("f47") = Frais
.Range("f49") = Montant
End With
Ask = Application.Match(TextBox3, WsStock.Columns(3), 0)
WsStock.Cells(Ask, 13) = Format(TextBox13, "0")
WsBons.Range("f18:f40") = Format(WsBons.Range("f18:f40"), "0.00.-")
WsBons.Range("f45") = Format(Prix, "0.00.-")
WsBons.Range("f46") = Format(Tva, "0.00.-")
WsBons.Range("f47") = Format(Frais, "0.00.-")
WsBons.Range("f49") = Format(Montant, "0.00.-")
For i = 2 To 13
Controls("TextBox" & i) = ""
Next i
TxtAchat = ""
TxtVente = ""
TxtEntrees = ""
TxtSorties = ""
End Sub
Private Sub TextBox3_Change()
If Me.TextBox3 <> "" Then
NArt = Application.Match(TextBox3, WsProd.Columns(3), 0)
Me.Label23 = NArt
End If
End Sub
Private Sub LblES_Click()
Unload Me
UsfVisualise.Show
End Sub
Private Sub LbBC_Click()
Num = WsBons.Range("z1").Value
Num = Num + 1
WsBons.Range("z1") = Num
Unload Me
Application.WindowState = xlNormal
'WsBC.PageSetup.PrintArea = "$A$1:$H49"
WsBons.Visible = True
WsBons.PrintPreview
Application.WindowState = xlMinimized
UsfStock.Show
TxtAchat = ""
TxtVente = ""
End Sub
Private Sub CmdQuitter_Click()
Unload Me
UsfAccueil.Show
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub