Hi..
I have created a complete the project with few userforms as my stock inventory.
And the project running without any error.
I need ur advice wether i did the codings in the right way or not. And need some advice for error handling.
Below are the coding and pictures of my userform and excel sheet. And also explanation how my project works.
Part details (sheet1)
http://i67.tinypic.com/24c6q1f.jpg
frmMain(page1)
http://i66.tinypic.com/2ezpcw4.jpg
All the information in sheet 1 will auto populate in all the textboxes in userform and aso in the textboxes in multipage(page 1) once keyin the part no.
Stock Update (sheet4)
http://i64.tinypic.com/14al755.jpg
Dynamic name range (Stock incoming)
http://i68.tinypic.com/mj381u.jpg
Dynamic name range (Stock info)
http://i65.tinypic.com/286wmk8.jpg
frmMain (page2)
http://i63.tinypic.com/whe9oi.jpg
frmStockUpdate
http://i68.tinypic.com/vemzqd.jpg
The function of this page is same as multipage (page 1). The textboxes must auto populate with information in excel sheet. The above pictures are to get the information for "total received" textbox and aso for "parts recieved details" listbox. Both details are from Stock Update (sheet4). Once we update the stock in stock update form, all the details will be stored in sheet4 ,Dynamic name range (Stock incoming) and the quantity will be updated to the table column D (stock) on sheet4. And the value in column D will auto populate in "total received" textbox.
And to get the information for "parts recieved details" listbox i have created another Dynamic name range (Stock info) in sheet 4 where once the we type the part no in cell M2, all the stock recieved information of that part will be sorted out from Dynamic name range (Stock incoming) to Dynamic name range (Stock info). I've created a macro for sorting. And the information in Dynamic name range (Stock info) will show up in "parts recieved details".
Shipment History (sheet3)
http://i67.tinypic.com/lfcdh.jpg
frmMain(page3)
http://i65.tinypic.com/280pdld.jpg
frmShipmentUpdate
http://i67.tinypic.com/30jl54g.jpg
This is for update the shipments. once we click update after fill in the information. this information will be stored in Shipment History (sheet3) Dynamic name range (shipment details) and this information will show up in listbox in frmShipmentUpdate.
Rejection Update (sheet2)
http://i65.tinypic.com/24v07s3.jpg
frmRejectionUpdate
http://i64.tinypic.com/2u8uoox.jpg
ThisWorkbook
frmlogin
frmMain
frmRejectionUpdate
frmShipmentUpdate
frmStockUpdate
module1
Module2
Module 3
Please advice is there is any mistake.
Thanks.
I have created a complete the project with few userforms as my stock inventory.
And the project running without any error.
I need ur advice wether i did the codings in the right way or not. And need some advice for error handling.
Below are the coding and pictures of my userform and excel sheet. And also explanation how my project works.
Part details (sheet1)
http://i67.tinypic.com/24c6q1f.jpg
frmMain(page1)
http://i66.tinypic.com/2ezpcw4.jpg
All the information in sheet 1 will auto populate in all the textboxes in userform and aso in the textboxes in multipage(page 1) once keyin the part no.
Stock Update (sheet4)
http://i64.tinypic.com/14al755.jpg
Dynamic name range (Stock incoming)
http://i68.tinypic.com/mj381u.jpg
Dynamic name range (Stock info)
http://i65.tinypic.com/286wmk8.jpg
frmMain (page2)
http://i63.tinypic.com/whe9oi.jpg
frmStockUpdate
http://i68.tinypic.com/vemzqd.jpg
The function of this page is same as multipage (page 1). The textboxes must auto populate with information in excel sheet. The above pictures are to get the information for "total received" textbox and aso for "parts recieved details" listbox. Both details are from Stock Update (sheet4). Once we update the stock in stock update form, all the details will be stored in sheet4 ,Dynamic name range (Stock incoming) and the quantity will be updated to the table column D (stock) on sheet4. And the value in column D will auto populate in "total received" textbox.
And to get the information for "parts recieved details" listbox i have created another Dynamic name range (Stock info) in sheet 4 where once the we type the part no in cell M2, all the stock recieved information of that part will be sorted out from Dynamic name range (Stock incoming) to Dynamic name range (Stock info). I've created a macro for sorting. And the information in Dynamic name range (Stock info) will show up in "parts recieved details".
Shipment History (sheet3)
http://i67.tinypic.com/lfcdh.jpg
frmMain(page3)
http://i65.tinypic.com/280pdld.jpg
frmShipmentUpdate
http://i67.tinypic.com/30jl54g.jpg
This is for update the shipments. once we click update after fill in the information. this information will be stored in Shipment History (sheet3) Dynamic name range (shipment details) and this information will show up in listbox in frmShipmentUpdate.
Rejection Update (sheet2)
http://i65.tinypic.com/24v07s3.jpg
frmRejectionUpdate
http://i64.tinypic.com/2u8uoox.jpg
ThisWorkbook
Code:
Option Explicit
Sub workbook_open()
Application.Visible = False
frmMain.Show
End Subfrmlogin
Code:
Option Explicit
Private Sub closeButton_Click()
Unload Me
End Sub[INDENT]Private Sub loginButton_Click()[/INDENT]
[INDENT] On Error GoTo loginButton_Click_Error[/INDENT]
[INDENT] 'login form to excel database[/INDENT]
[INDENT] Dim username As String[/INDENT]
[INDENT] Dim password As String[/INDENT]
[INDENT] username = userTextbox.Value[/INDENT]
[INDENT] password = passwordTextbox.Value[/INDENT]
[INDENT]
[/INDENT]
[INDENT] '1st logic check[/INDENT]
[INDENT] If username = "" Or password = "" Then[/INDENT]
[INDENT] MsgBox "Please fill in all fields."[/INDENT]
[INDENT]
[/INDENT]
[INDENT] End If[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT] If username = "admin" Then[/INDENT]
[INDENT] If password = "123" Then[/INDENT]
[INDENT] Application.Visible = True[/INDENT]
[INDENT] Unload Me[/INDENT]
[INDENT] frmMain.Hide[/INDENT]
[INDENT]
[/INDENT]
[INDENT] Else[/INDENT]
[INDENT] 'error msg for wrong password[/INDENT]
[INDENT] MsgBox "Your username or password is incorrect"[/INDENT]
[INDENT] Unload Me[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] End If[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]Exit Sub[/INDENT]
[INDENT]loginButton_Click_Error:[/INDENT]
[INDENT]MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure loginButton_Click of Form frmLogin"[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]frmMain
Code:
Option Explicit[INDENT]Private Sub cmdClear_Click()[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo cmdClear_Click_Error[/INDENT]
[INDENT] 'to clear the textboxs1[/INDENT]
[INDENT] TextBoxs1 = ""[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]Exit Sub[/INDENT]
[INDENT]cmdClear_Click_Error:[/INDENT]
[INDENT]MsgBox "Error " & Err.Number & " (" & Err.Description & ")in procedure cmdClear_Click of Form frmMain"[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]Private Sub cmdClose_Click()[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo cmdClose_Click_Error[/INDENT]
[INDENT] 'to close the main form and workbook[/INDENT]
[INDENT] Unload frmMain[/INDENT]
[INDENT] Workbooks("MB Inventory.xlsm").Close SaveChanges:=True[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]Exit Sub[/INDENT]
[INDENT]cmdClose_Click_Error:[/INDENT]
[INDENT]MsgBox "Error " & Err.Number & " (" & Err.Description & ")in procedure cmdClose_Click of Form frmMain"[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]Private Sub cmdRefresh_Click()[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo cmdRefresh_Click_Error[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Dim wsData1 As Worksheet[/INDENT]
[INDENT]Dim wsData2 As Worksheet[/INDENT]
[INDENT]Dim sID As String[/INDENT]
[INDENT]Dim rFound As Range[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'to refresh the updated data thru userform[/INDENT]
[INDENT]Set wsData1 = Sheet4[/INDENT]
[INDENT] With wsData1[/INDENT]
[INDENT] ' Get the item number in sID[/INDENT]
[INDENT] sID = Me.TextBoxs1.Value[/INDENT]
[INDENT] ' check column A of the datasheet for the entry[/INDENT]
[INDENT] Set rFound = .Columns("A").Find(what:=sID, _[/INDENT]
[INDENT] after:=.Cells(1, 1))[/INDENT]
[INDENT] ' if found, process. else quit[/INDENT]
[INDENT] If Not rFound Is Nothing Then ' This checks that rFound is set to an object _[/INDENT]
[INDENT] and not 'nothing'[/INDENT]
[INDENT] ' Load the details in the text boxes[/INDENT]
[INDENT] TextBoxs12.Value = rFound.Offset(0, 3).Value[/INDENT]
[INDENT] TextBoxs13.Value = Worksheets("Shipment History").Range("g3").Value * TextBoxs11.Value[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] End With[/INDENT]
[INDENT] Set wsData2 = Sheet2[/INDENT]
[INDENT] With wsData2[/INDENT]
[INDENT] ' Get the item number in sID[/INDENT]
[INDENT] sID = Me.TextBoxs1.Value[/INDENT]
[INDENT] ' check column A of the datasheet for the entry[/INDENT]
[INDENT] Set rFound = .Columns("A").Find(what:=sID, _[/INDENT]
[INDENT] after:=.Cells(1, 1))[/INDENT]
[INDENT] ' if found, process. else quit[/INDENT]
[INDENT] If Not rFound Is Nothing Then ' This checks that rFound is set to an object _[/INDENT]
[INDENT] and not 'nothing'[/INDENT]
[INDENT] ' Load the details in the text boxes[/INDENT]
[INDENT] TextBoxs14.Value = rFound.Offset(0, 2).Value[/INDENT]
[INDENT] TextBoxs15.Value = CDbl(TextBoxs12.Text) - CDbl(TextBoxs13.Text) - CDbl(TextBoxs14.Value)[/INDENT]
[INDENT] TextBoxs16.Value = TextBoxs15.Value / TextBoxs11.Value[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] End With[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Sheet4.Range("M2") = TextBoxs1.Value[/INDENT]
[INDENT]SortIncoming[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]Exit Sub[/INDENT]
[INDENT]cmdRefresh_Click_Error:[/INDENT]
[INDENT]MsgBox "Error " & Err.Number & " (" & Err.Description & ")in procedure cmdRefresh_Click of Form frmMain"[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]Private Sub cmdShowLogin_Click()[/INDENT]
[INDENT]
[/INDENT]
[INDENT]frmLogin.Show[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]Private Sub CommandButton5_Click()[/INDENT]
[INDENT]
[/INDENT]
[INDENT]frmShipmentUpdate.Show[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]Private Sub CommandButton6_Click()[/INDENT]
[INDENT]
[/INDENT]
[INDENT]frmRejectionUpdate.Show[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]Private Sub CommandButton7_Click()[/INDENT]
[INDENT]
[/INDENT]
[INDENT]frmStockUpdate.Show[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Private Sub TextBoxs1_Change()[/INDENT]
[INDENT]' -----------------------------------[/INDENT]
[INDENT]' Then check _[/INDENT]
[INDENT] database form matching item[/INDENT]
[INDENT]' -----------------------------------[/INDENT]
[INDENT] On Error GoTo TextBoxs1_Change_Error[/INDENT]
[INDENT] TextBoxs1 = UCase(TextBoxs1)[/INDENT]
[INDENT] If Len(TextBoxs1.Value) Then[/INDENT]
[INDENT] GetData[/INDENT]
[INDENT] Else[/INDENT]
[INDENT] ClearForm bAll:=True ' keep text in textbox1[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] Sheet4.Range("M2") = TextBoxs1.Value[/INDENT]
[INDENT] SortIncoming[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]Exit Sub[/INDENT]
[INDENT]TextBoxs1_Change_Error:[/INDENT]
[INDENT]MsgBox "Error " & Err.Number & " (" & Err.Description & ")in procedure TextBoxs1_Change of Form frmMain"[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Private Sub UserForm_Activate()[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo UserForm_Activate_Error[/INDENT]
[INDENT]AddToForm MIN_BOX[/INDENT]
[INDENT]MultiPage1.Value = 0[/INDENT]
[INDENT] ' There will be four columns in the list box[/INDENT]
[INDENT] ListBox2.ColumnCount = 4[/INDENT]
[INDENT]
[/INDENT]
[INDENT] ' The list box will be populated by range "A2:D100"[/INDENT]
[INDENT] ListBox2.RowSource = "shipmentdetails"[/INDENT]
[INDENT]
[/INDENT]
[INDENT] Me.Label25.Caption = Sheet3.Range("g3").Value[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]Exit Sub[/INDENT]
[INDENT]UserForm_Activate_Error:[/INDENT]
[INDENT]MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure UserForm_Activate of Form frmMain"[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Private Sub UserForm_Initialize()[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo UserForm_Initialize_Error[/INDENT]
[INDENT]
[/INDENT]
[INDENT]TextBoxs1.SetFocus[/INDENT]
[INDENT]' There will be 5 columns in the list box[/INDENT]
[INDENT] ListBox1.ColumnCount = 5[/INDENT]
[INDENT] ' The list box will be populated by range "N2:R100"[/INDENT]
[INDENT] ListBox1.RowSource = ("StockInfo")[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]Exit Sub[/INDENT]
[INDENT]UserForm_Initialize_Error:[/INDENT]
[INDENT]MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure UserForm_Initialize of Form frmMain"[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Sub GetData()[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'--------------------------------------[/INDENT]
[INDENT]' Check database for entry in Textbox1 _[/INDENT]
[INDENT] and if in DB then populate other TB _[/INDENT]
[INDENT] and image[/INDENT]
[INDENT]'--------------------------------------[/INDENT]
[INDENT] Dim j As Integer[/INDENT]
[INDENT] Dim rFound As Range[/INDENT]
[INDENT] Dim wsData As Worksheet[/INDENT]
[INDENT] Dim shImage As Shape[/INDENT]
[INDENT] Dim sID As String[/INDENT]
[INDENT] Dim wsData1 As Worksheet[/INDENT]
[INDENT] Dim wsData2 As Worksheet[/INDENT]
[INDENT] 'On Error GoTo GetData_Error[/INDENT]
[INDENT]On Error Resume Next[/INDENT]
[INDENT] Set wsData = Sheet1[/INDENT]
[INDENT] With wsData[/INDENT]
[INDENT] ' Get the item number in sID[/INDENT]
[INDENT] sID = Me.TextBoxs1.Value[/INDENT]
[INDENT] ' check column A of the datasheet for the entry[/INDENT]
[INDENT] Set rFound = .Columns("A").Find(what:=sID, _[/INDENT]
[INDENT] after:=.Cells(1, 1))[/INDENT]
[INDENT] ' if found, process. else quit[/INDENT]
[INDENT] If Not rFound Is Nothing Then ' This checks that rFound is set to an object _[/INDENT]
[INDENT] and not 'nothing'[/INDENT]
[INDENT] ' Load the details in the text boxes[/INDENT]
[INDENT] For j = 2 To 11[/INDENT]
[INDENT] Me.Controls("TextBoxs" & j).Value = rFound.Offset(0, j - 1).Value[/INDENT]
[INDENT] Next j[/INDENT]
[INDENT] ' load the image into the image holder[/INDENT]
[INDENT] ' rFound.Row is the row where we need to look for the data[/INDENT]
[INDENT] Set shImage = GetImage(rFound.Row)[/INDENT]
[INDENT] If Not shImage Is Nothing Then[/INDENT]
[INDENT] ' valid image found[/INDENT]
[INDENT] shImage.Copy[/INDENT]
[INDENT] Set Image1.Picture = PastePicture(xlPicture)[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] Else[/INDENT]
[INDENT] ClearForm bAll:=False ' keep text in textbox1[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] End With[/INDENT]
[INDENT]
[/INDENT]
[INDENT] Set wsData1 = Sheet4[/INDENT]
[INDENT] With wsData1[/INDENT]
[INDENT] ' Get the item number in sID[/INDENT]
[INDENT] sID = Me.TextBoxs1.Value[/INDENT]
[INDENT] ' check column A of the datasheet for the entry[/INDENT]
[INDENT] Set rFound = .Columns("A").Find(what:=sID, _[/INDENT]
[INDENT] after:=.Cells(1, 1))[/INDENT]
[INDENT] ' if found, process. else quit[/INDENT]
[INDENT] If Not rFound Is Nothing Then ' This checks that rFound is set to an object _[/INDENT]
[INDENT] and not 'nothing'[/INDENT]
[INDENT] ' Load the details in the text boxes[/INDENT]
[INDENT] TextBoxs12.Value = rFound.Offset(0, 3).Value[/INDENT]
[INDENT] TextBoxs13.Value = Worksheets("Shipment History").Range("g3").Value * TextBoxs11.Value[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] End With[/INDENT]
[INDENT] Set wsData2 = Sheet2[/INDENT]
[INDENT] With wsData2[/INDENT]
[INDENT] ' Get the item number in sID[/INDENT]
[INDENT] sID = Me.TextBoxs1.Value[/INDENT]
[INDENT] ' check column A of the datasheet for the entry[/INDENT]
[INDENT] Set rFound = .Columns("A").Find(what:=sID, _[/INDENT]
[INDENT] after:=.Cells(1, 1))[/INDENT]
[INDENT] ' if found, process. else quit[/INDENT]
[INDENT] If Not rFound Is Nothing Then ' This checks that rFound is set to an object _[/INDENT]
[INDENT] and not 'nothing'[/INDENT]
[INDENT] ' Load the details in the text boxes[/INDENT]
[INDENT] TextBoxs14.Value = rFound.Offset(0, 2).Value[/INDENT]
[INDENT] TextBoxs15.Value = CDbl(TextBoxs12.Text) - CDbl(TextBoxs13.Text) - CDbl(TextBoxs14.Value)[/INDENT]
[INDENT] TextBoxs16.Value = TextBoxs15.Value / TextBoxs11.Value[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] End With[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]'Exit Sub[/INDENT]
[INDENT]'GetData_Error:[/INDENT]
[INDENT]'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetData of Form frmMain"[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]Sub ClearForm(bAll As Boolean)[/INDENT]
[INDENT]'----------------------------------------------[/INDENT]
[INDENT]' Clears textboxes in userform.[/INDENT]
[INDENT]' If bAll is false then TextBox1 is not cleared[/INDENT]
[INDENT]'----------------------------------------------[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo ClearForm_Error[/INDENT]
[INDENT] Const sTB_NAME As String = "TextBoxs1"[/INDENT]
[INDENT] Dim ctrlTB As MSForms.Control[/INDENT]
[INDENT] For Each ctrlTB In Me.Controls ' Me stands for the Userform in which this code is used[/INDENT]
[INDENT] If TypeOf ctrlTB Is MSForms.TextBox Then[/INDENT]
[INDENT] With ctrlTB[/INDENT]
[INDENT] If bAll = False Then[/INDENT]
[INDENT] If .Name <> sTB_NAME Then[/INDENT]
[INDENT] .Value = ""[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] Else[/INDENT]
[INDENT] .Value = ""[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] End With[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] Next ctrlTB[/INDENT]
[INDENT] Me.Image1.Picture = LoadPicture("")[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]Exit Sub[/INDENT]
[INDENT]ClearForm_Error:[/INDENT]
[INDENT]MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure ClearForm of Form frmMain"[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]frmRejectionUpdate
Code:
Option Explicit[INDENT]Private Sub cmdClear_Click()[/INDENT]
[INDENT]On Error GoTo cmdClear_Click_Error[/INDENT]
[INDENT]
[/INDENT]
[INDENT] 'To clear the textboxs[/INDENT]
[INDENT] Dim ctl[/INDENT]
[INDENT] For Each ctl In Me.Controls[/INDENT]
[INDENT] If TypeOf ctl Is MSForms.TextBox Then[/INDENT]
[INDENT] ctl.Text = ""[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] Next ctl[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]Exit Sub[/INDENT]
[INDENT]cmdClear_Click_Error:[/INDENT]
[INDENT]MsgBox "Error " & Err.Number & " (" & Err.Description & ")in procedure cmdClear_Click of Form frmRejectionUpdate"[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Private Sub cmdClose_Click()[/INDENT]
[INDENT] Unload Me[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Private Sub cmdUpdate_Click()[/INDENT]
[INDENT] Dim rFound As Range[/INDENT]
[INDENT] Dim wsData As Worksheet[/INDENT]
[INDENT] Dim sID As String[/INDENT]
[INDENT] Dim x As Integer[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo cmdUpdate_Click_Error[/INDENT]
[INDENT]
[/INDENT]
[INDENT] Set wsData = Sheet2[/INDENT]
[INDENT] With wsData[/INDENT]
[INDENT] 'To check empty textboxs[/INDENT]
[INDENT] For x = 1 To 3[/INDENT]
[INDENT] If Me.Controls("TextBox" & x).Value = "" Then[/INDENT]
[INDENT] MsgBox "Missing data", vbExclamation[/INDENT]
[INDENT] Exit Sub[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] Next[/INDENT]
[INDENT]
[/INDENT]
[INDENT] ' Get the item number in sID[/INDENT]
[INDENT] sID = Me.TextBox1.Value[/INDENT]
[INDENT] ' check column A of the datasheet for the entry[/INDENT]
[INDENT] Set rFound = .Columns("A").Find(what:=sID, _[/INDENT]
[INDENT] after:=.Cells(1, 1))[/INDENT]
[INDENT] ' if found, process. else quit[/INDENT]
[INDENT] If Not rFound Is Nothing Then ' This checks that rFound is set to an object _[/INDENT]
[INDENT] and not 'nothing'[/INDENT]
[INDENT] ' Load the details in the text boxes[/INDENT]
[INDENT] rFound.Offset(0, 2).Value = TextBox3.Value + rFound.Offset(0, 2).Value[/INDENT]
[INDENT] TextBox4.Value = rFound.Offset(0, 2).Value[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] 'To clear the textbox3 value after updating[/INDENT]
[INDENT] Me.Controls("TextBox3").Value = ""[/INDENT]
[INDENT] End With[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]Exit Sub[/INDENT]
[INDENT]cmdUpdate_Click_Error:[/INDENT]
[INDENT]MsgBox "Error " & Err.Number & " (" & Err.Description & ")in procedure cmdUpdate_Click of Form frmRejectionUpdate"[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Private Sub TextBox1_Change()[/INDENT]
[INDENT]'--------------------------------------[/INDENT]
[INDENT]' Check database for entry in Textbox1 _[/INDENT]
[INDENT] and if in DB then populate other TB _[/INDENT]
[INDENT] and image[/INDENT]
[INDENT]'--------------------------------------[/INDENT]
[INDENT] Dim rFound As Range[/INDENT]
[INDENT] Dim wsData As Worksheet[/INDENT]
[INDENT] Dim sID As String[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo TextBox1_Change_Error[/INDENT]
[INDENT]
[/INDENT]
[INDENT] TextBox1 = UCase(TextBox1)[/INDENT]
[INDENT] Set wsData = Sheet2 ' Enter the name of your data sheet here[/INDENT]
[INDENT] With wsData[/INDENT]
[INDENT] ' Get the item number in sID[/INDENT]
[INDENT] sID = Me.TextBox1.Value[/INDENT]
[INDENT] ' check column A of the datasheet for the entry[/INDENT]
[INDENT] Set rFound = .Columns("A").Find(what:=sID, _[/INDENT]
[INDENT] after:=.Cells(1, 1))[/INDENT]
[INDENT] ' if found, process. else quit[/INDENT]
[INDENT] If Not rFound Is Nothing Then ' This checks that rFound is set to an object _[/INDENT]
[INDENT] and not 'nothing'[/INDENT]
[INDENT] ' Load the details in the text boxes[/INDENT]
[INDENT] TextBox2.Value = rFound.Offset(0, 1).Value[/INDENT]
[INDENT] TextBox4.Value = rFound.Offset(0, 2).Value[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] End With[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]Exit Sub[/INDENT]
[INDENT]TextBox1_Change_Error:[/INDENT]
[INDENT]MsgBox "Error " & Err.Number & " (" & Err.Description & ")in procedure TextBox1_Change of Form frmRejectionUpdate"[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Private Sub UserForm_Initialize()[/INDENT]
[INDENT] TextBox1.SetFocus[/INDENT]
End SubfrmShipmentUpdate
Code:
Option Explicit[INDENT]Private Sub cmdClose_Click()[/INDENT]
[INDENT] Unload Me[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Private Sub cmdUpdate_Click()[/INDENT]
[INDENT] Dim x As Integer[/INDENT]
[INDENT] Dim nextrow As Range[/INDENT]
[INDENT] Dim wsData As Worksheet[/INDENT]
[INDENT]On Error GoTo cmdUpdate_Click_Error[/INDENT]
[INDENT]
[/INDENT]
[INDENT] Set wsData = Sheet3[/INDENT]
[INDENT] With wsData[/INDENT]
[INDENT] 'to check emplty textboxs[/INDENT]
[INDENT] Set nextrow = Sheet3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)[/INDENT]
[INDENT] For x = 1 To 4[/INDENT]
[INDENT] If Me.Controls("shipment" & x).Value = "" Then[/INDENT]
[INDENT] MsgBox "Missing data"[/INDENT]
[INDENT] Exit Sub[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] Next[/INDENT]
[INDENT]
[/INDENT]
[INDENT] 'add values if previous criteria matches[/INDENT]
[INDENT] For x = 1 To 4[/INDENT]
[INDENT] nextrow = Me.Controls("shipment" & x).Value[/INDENT]
[INDENT] Set nextrow = nextrow.Offset(0, 1)[/INDENT]
[INDENT] Next[/INDENT]
[INDENT] 'to show the total shipment after updating[/INDENT]
[INDENT] shipment5.Text = Worksheets("Shipment History").Range("g3").Value '>>>>>> change the range value accordingly[/INDENT]
[INDENT]
[/INDENT]
[INDENT] 'clear[/INDENT]
[INDENT] For x = 1 To 4[/INDENT]
[INDENT] Me.Controls("shipment" & x).Value = ""[/INDENT]
[INDENT] Next[/INDENT]
[INDENT] ' There will be four columns in the list box[/INDENT]
[INDENT] ListBox1.ColumnCount = 4[/INDENT]
[INDENT]
[/INDENT]
[INDENT] ' The list box will be populated by range "A2:D100"[/INDENT]
[INDENT] ListBox1.RowSource = "shipmentdetails"[/INDENT]
[INDENT]
[/INDENT]
[INDENT] End With[/INDENT]
[INDENT] Exit Sub[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]Exit Sub[/INDENT]
[INDENT]cmdUpdate_Click_Error:[/INDENT]
[INDENT]MsgBox "Error " & Err.Number & " (" & Err.Description & ")in procedure cmdUpdate_Click of Form frmShipmentUpdate"[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Private Sub shipment3_Change()[/INDENT]
[INDENT]shipment3 = UCase(shipment3)[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Private Sub shipment4_Change()[/INDENT]
[INDENT]shipment4 = UCase(shipment4)[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Private Sub UserForm_Initialize()[/INDENT]
[INDENT]On Error GoTo UserForm_Initialize_Error[/INDENT]
[INDENT]
[/INDENT]
[INDENT] ' There will be four columns in the list box[/INDENT]
[INDENT] ListBox1.ColumnCount = 4[/INDENT]
[INDENT]
[/INDENT]
[INDENT] ' The list box will be populated by range "A2:D100"[/INDENT]
[INDENT] ListBox1.RowSource = "shipmentdetails"[/INDENT]
[INDENT] ' To show the total shipment before updating[/INDENT]
[INDENT] shipment5.Text = Sheet3.Range("g3").Value '>>>>>> change the range value accordingly[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]Exit Sub[/INDENT]
[INDENT]UserForm_Initialize_Error:[/INDENT]
[INDENT]MsgBox "Error " & Err.Number & " (" & Err.Description & ")in procedure UserForm_Initialize of Form frmShipmentUpdate"[/INDENT]
[INDENT]End Sub[/INDENT]frmStockUpdate
Code:
Option Explicit[INDENT]Private Sub cmdClose_Click()[/INDENT]
[INDENT]Unload Me[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Private Sub cmdUpdate_Click()[/INDENT]
[INDENT] Dim x As Integer[/INDENT]
[INDENT] Dim nextrow As Range[/INDENT]
[INDENT] Dim rFound As Range[/INDENT]
[INDENT] Dim wsData1 As Worksheet[/INDENT]
[INDENT] Dim sID As String[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo cmdUpdate_Click_Error[/INDENT]
[INDENT]
[/INDENT]
[INDENT] Set wsData1 = Sheet4[/INDENT]
[INDENT] With wsData1[/INDENT]
[INDENT] 'to check emplty textboxs[/INDENT]
[INDENT] Set nextrow = Sheet4.Cells(Rows.Count, 6).End(xlUp).Offset(1, 0)[/INDENT]
[INDENT] For x = 1 To 5[/INDENT]
[INDENT] If Me.Controls("stock" & x).Value = "" Then[/INDENT]
[INDENT] MsgBox "Missing data"[/INDENT]
[INDENT] Exit Sub[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] Next[/INDENT]
[INDENT]
[/INDENT]
[INDENT] 'add values if previous criteria matches[/INDENT]
[INDENT] For x = 1 To 5[/INDENT]
[INDENT] nextrow = Me.Controls("stock" & x).Value[/INDENT]
[INDENT] Set nextrow = nextrow.Offset(0, 1)[/INDENT]
[INDENT] Next[/INDENT]
[INDENT] ' Get the item number in sID[/INDENT]
[INDENT] sID = Me.Stock1.Value[/INDENT]
[INDENT] ' check column A of the datasheet for the entry[/INDENT]
[INDENT] Set rFound = .Columns("A").Find(what:=sID, _[/INDENT]
[INDENT] after:=.Cells(1, 1))[/INDENT]
[INDENT] ' if found, process. else quit[/INDENT]
[INDENT] If Not rFound Is Nothing Then ' This checks that rFound is set to an object and not 'nothing'[/INDENT]
[INDENT] 'MsgBox "part not found!"[/INDENT]
[INDENT] ' Load the details in the text boxes[/INDENT]
[INDENT] rFound.Offset(0, 3).Value = Stock5.Value + rFound.Offset(0, 3).Value[/INDENT]
[INDENT] 'TextBox4.Value = rFound.Offset(0, 2).Value[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] End With[/INDENT]
[INDENT] 'clear[/INDENT]
[INDENT] For x = 1 To 5[/INDENT]
[INDENT] Me.Controls("stock" & x).Value = ""[/INDENT]
[INDENT] Next[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]Exit Sub[/INDENT]
[INDENT]cmdUpdate_Click_Error:[/INDENT]
[INDENT]MsgBox "Error " & Err.Number & " (" & Err.Description & ")in procedure cmdUpdate_Click of Form frmStockUpdate"[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]Private Sub Stock1_Change()[/INDENT]
[INDENT]'--------------------------------------[/INDENT]
[INDENT]' Check database for entry in Textbox1 _[/INDENT]
[INDENT] and if in DB then populate other TB _[/INDENT]
[INDENT] and image[/INDENT]
[INDENT]'--------------------------------------[/INDENT]
[INDENT] Dim rFound As Range[/INDENT]
[INDENT] Dim wsData As Worksheet[/INDENT]
[INDENT] Dim sID As String[/INDENT]
[INDENT] Dim j As Integer[/INDENT]
[INDENT]On Error GoTo Stock1_Change_Error[/INDENT]
[INDENT]
[/INDENT]
[INDENT] Stock1 = UCase(Stock1)[/INDENT]
[INDENT] Set wsData = Sheet4 ' Enter the name of your data sheet here[/INDENT]
[INDENT] With wsData[/INDENT]
[INDENT] ' Get the item number in sID[/INDENT]
[INDENT] sID = Me.Stock1.Value[/INDENT]
[INDENT] ' check column A of the datasheet for the entry[/INDENT]
[INDENT] Set rFound = .Columns("A").Find(what:=sID, _[/INDENT]
[INDENT] after:=.Cells(1, 1))[/INDENT]
[INDENT] ' if found, process. else quit[/INDENT]
[INDENT] If Not rFound Is Nothing Then ' This checks that rFound is set to an object _[/INDENT]
[INDENT] and not 'nothing'[/INDENT]
[INDENT] ' Load the details in the text boxes[/INDENT]
[INDENT] For j = 2 To 3[/INDENT]
[INDENT] Me.Controls("stock" & j).Value = rFound.Offset(0, j - 1).Value[/INDENT]
[INDENT] Next j[/INDENT]
[INDENT] Else[/INDENT]
[INDENT] ClearForm bAll:=False ' keep text in textbox1[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] End With[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]Exit Sub[/INDENT]
[INDENT]Stock1_Change_Error:[/INDENT]
[INDENT]MsgBox "Error " & Err.Number & " (" & Err.Description & ")in procedure Stock1_Change of Form frmStockUpdate"[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]Private Sub UserForm_Initialize()[/INDENT]
[INDENT] Stock1.SetFocus[/INDENT]
[INDENT]End Sub[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Sub ClearForm(bAll As Boolean)[/INDENT]
[INDENT]'----------------------------------------------[/INDENT]
[INDENT]' Clears textboxes in userform.[/INDENT]
[INDENT]' If bAll is false then TextBox1 is not cleared[/INDENT]
[INDENT]'----------------------------------------------[/INDENT]
[INDENT]On Error GoTo ClearForm_Error[/INDENT]
[INDENT]
[/INDENT]
[INDENT] Const sTB_NAME As String = "stock1"[/INDENT]
[INDENT] Dim ctrlTB As MSForms.Control[/INDENT]
[INDENT] For Each ctrlTB In Me.Controls ' Me stands for the Userform in which this code is used[/INDENT]
[INDENT] If TypeOf ctrlTB Is MSForms.TextBox Then[/INDENT]
[INDENT] With ctrlTB[/INDENT]
[INDENT] If bAll = False Then[/INDENT]
[INDENT] If .Name <> sTB_NAME Then[/INDENT]
[INDENT] .Value = ""[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] Else[/INDENT]
[INDENT] .Value = ""[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] End With[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] Next[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT]Exit Sub[/INDENT]
[INDENT]ClearForm_Error:[/INDENT]
[INDENT]MsgBox "Error " & Err.Number & " (" & Err.Description & ")in procedure ClearForm of Form frmStockUpdate"[/INDENT]
End Submodule1
Code:
Option Explicit[INDENT]Function GetImage(lRow As Long) As Shape[/INDENT]
[INDENT]' ========================================================[/INDENT]
[INDENT]' This function returns the image that has its top in _[/INDENT]
[INDENT] the row passed as a parameter.[/INDENT]
[INDENT]' ========================================================[/INDENT]
[INDENT] Dim shImage As Shape[/INDENT]
[INDENT] Dim lRowTop As Long, lNextRowTop As Long[/INDENT]
[INDENT] Dim wsData As Worksheet[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo GetImage_Error[/INDENT]
[INDENT]
[/INDENT]
[INDENT] Set wsData = Sheets("Part Details") '[/INDENT]
[INDENT] ' get the top of the row and the top of the next row[/INDENT]
[INDENT] lRowTop = wsData.Cells(lRow, 1).Top[/INDENT]
[INDENT] lNextRowTop = wsData.Cells(lRow + 1, 1).Top[/INDENT]
[INDENT] ' check for each image if its top is inbetween required _[/INDENT]
[INDENT] row and row below it.[/INDENT]
[INDENT] For Each shImage In wsData.Shapes[/INDENT]
[INDENT] If shImage.Top >= lRowTop And shImage.Top < lNextRowTop Then[/INDENT]
[INDENT] ' found the image. return it and quit the function[/INDENT]
[INDENT] Set GetImage = shImage[/INDENT]
[INDENT] Exit Function[/INDENT]
[INDENT] End If[/INDENT]
[INDENT] Next shImage[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT] Exit Function[/INDENT]
[INDENT]GetImage_Error:[/INDENT]
[INDENT]
[/INDENT]
[INDENT] MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure GetImage of Module Module1"[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Function[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Sub SortIncoming()[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo SortIncoming_Error[/INDENT]
[INDENT]'[/INDENT]
[INDENT]' SortIncoming Macro[/INDENT]
[INDENT]'[/INDENT]
[INDENT]' Keyboard Shortcut: Ctrl+Shift+A[/INDENT]
[INDENT]'[/INDENT]
[INDENT] Sheet4.Range("StockIncoming").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheet4.Range( _[/INDENT]
[INDENT] "M1:M2"), CopyToRange:=Sheet4.Range("N1:R1"), Unique:=False[/INDENT]
[INDENT]
[/INDENT]
[INDENT]On Error GoTo 0[/INDENT]
[INDENT] Exit Sub[/INDENT]
[INDENT]SortIncoming_Error:[/INDENT]
[INDENT]
[/INDENT]
[INDENT] MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure SortIncoming of Module Module1"[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]Module2
Code:
[INDENT]'***************************************************************************[/INDENT]
[INDENT]'*[/INDENT]
[INDENT]'* MODULE NAME: Paste Picture[/INDENT]
[INDENT]'* AUTHOR & DATE: STEPHEN BULLEN, Office Automation Ltd[/INDENT]
[INDENT]'* 15 November 1998[/INDENT]
[INDENT]'*[/INDENT]
[INDENT]'* CONTACT: Stephen@oaltd.co.uk[/INDENT]
[INDENT]'* WEB SITE: http://www.oaltd.co.uk[/INDENT]
[INDENT]'*[/INDENT]
[INDENT]'* DESCRIPTION: Creates a standard Picture object from whatever is on the clipboard.[/INDENT]
[INDENT]'* This object can then be assigned to (for example) and Image control[/INDENT]
[INDENT]'* on a userform. The PastePicture function takes an optional argument of[/INDENT]
[INDENT]'* the picture type - xlBitmap or xlPicture.[/INDENT]
[INDENT]'*[/INDENT]
[INDENT]'* The code requires a reference to the "OLE Automation" type library[/INDENT]
[INDENT]'*[/INDENT]
[INDENT]'* The code in this module has been derived from a number of sources[/INDENT]
[INDENT]'* discovered on MSDN.[/INDENT]
[INDENT]'*[/INDENT]
[INDENT]'* To use it, just copy this module into your project, then you can use:[/INDENT]
[INDENT]'* Set Image1.Picture = PastePicture(xlPicture)[/INDENT]
[INDENT]'* to paste a picture of whatever is on the clipboard into a standard image control.[/INDENT]
[INDENT]'*[/INDENT]
[INDENT]'* PROCEDURES:[/INDENT]
[INDENT]'* PastePicture The entry point for the routine[/INDENT]
[INDENT]'* CreatePicture Private function to convert a bitmap or metafile handle to an OLE reference[/INDENT]
[INDENT]'* fnOLEError Get the error text for an OLE error code[/INDENT]
[INDENT]'***************************************************************************[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Option Explicit[/INDENT]
[INDENT]Option Compare Text[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]''' User-Defined Types for API Calls[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'Declare a UDT to store a GUID for the IPicture OLE Interface[/INDENT]
[INDENT]Private Type GUID[/INDENT]
[INDENT] Data1 As Long[/INDENT]
[INDENT] Data2 As Integer[/INDENT]
[INDENT] Data3 As Integer[/INDENT]
[INDENT] Data4(0 To 7) As Byte[/INDENT]
[INDENT]End Type[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'Declare a UDT to store the bitmap information[/INDENT]
[INDENT]Private Type uPicDesc[/INDENT]
[INDENT] Size As Long[/INDENT]
[INDENT] Type As Long[/INDENT]
[INDENT] hPic As Long[/INDENT]
[INDENT] hPal As Long[/INDENT]
[INDENT]End Type[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'''Windows API Function Declarations[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'Does the clipboard contain a bitmap/metafile?[/INDENT]
[INDENT]Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'Open the clipboard to read[/INDENT]
[INDENT]Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'Get a pointer to the bitmap/metafile[/INDENT]
[INDENT]Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'Close the clipboard[/INDENT]
[INDENT]Private Declare Function CloseClipboard Lib "user32" () As Long[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'Convert the handle into an OLE IPicture interface.[/INDENT]
[INDENT]Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'Create our own copy of the metafile, so it doesn't get wiped out by subsequent clipboard updates.[/INDENT]
[INDENT]Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'Create our own copy of the bitmap, so it doesn't get wiped out by subsequent clipboard updates.[/INDENT]
[INDENT]Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'The API format types we're interested in[/INDENT]
[INDENT]Const CF_BITMAP = 2[/INDENT]
[INDENT]Const CF_PALETTE = 9[/INDENT]
[INDENT]Const CF_ENHMETAFILE = 14[/INDENT]
[INDENT]Const IMAGE_BITMAP = 0[/INDENT]
[INDENT]Const LR_COPYRETURNORG = &H4[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''[/INDENT]
[INDENT]''' Subroutine: PastePicture[/INDENT]
[INDENT]'''[/INDENT]
[INDENT]''' Purpose: Get a Picture object showing whatever's on the clipboard.[/INDENT]
[INDENT]'''[/INDENT]
[INDENT]''' Arguments: lXlPicType - The type of picture to create. Can be one of:[/INDENT]
[INDENT]''' xlPicture to create a metafile (default)[/INDENT]
[INDENT]''' xlBitmap to create a bitmap[/INDENT]
[INDENT]'''[/INDENT]
[INDENT]''' Date Developer Action[/INDENT]
[INDENT]''' --------------------------------------------------------------------------[/INDENT]
[INDENT]''' 30 Oct 98 Stephen Bullen Created[/INDENT]
[INDENT]''' 15 Nov 98 Stephen Bullen Updated to create our own copies of the clipboard images[/INDENT]
[INDENT]'''[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'Some pointers[/INDENT]
[INDENT]Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'Convert the type of picture requested from the xl constant to the API constant[/INDENT]
[INDENT]lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'Check if the clipboard contains the required format[/INDENT]
[INDENT]hPicAvail = IsClipboardFormatAvailable(lPicType)[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]If hPicAvail <> 0 Then[/INDENT]
[INDENT] 'Get access to the clipboard[/INDENT]
[INDENT] h = OpenClipboard(0&)[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT] If h > 0 Then[/INDENT]
[INDENT] 'Get a handle to the image data[/INDENT]
[INDENT] hPtr = GetClipboardData(lPicType)[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT] 'Create our own copy of the image on the clipboard, in the appropriate format.[/INDENT]
[INDENT] If lPicType = CF_BITMAP Then[/INDENT]
[INDENT] hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)[/INDENT]
[INDENT] Else[/INDENT]
[INDENT] hCopy = CopyEnhMetaFile(hPtr, vbNullString)[/INDENT]
[INDENT] End If[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT] 'Release the clipboard to other programs[/INDENT]
[INDENT] h = CloseClipboard[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT] 'If we got a handle to the image, convert it into a Picture object and return it[/INDENT]
[INDENT] If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)[/INDENT]
[INDENT] End If[/INDENT]
[INDENT]End If[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Function[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''[/INDENT]
[INDENT]''' Subroutine: CreatePicture[/INDENT]
[INDENT]'''[/INDENT]
[INDENT]''' Purpose: Converts a image (and palette) handle into a Picture object.[/INDENT]
[INDENT]'''[/INDENT]
[INDENT]''' Requires a reference to the "OLE Automation" type library[/INDENT]
[INDENT]'''[/INDENT]
[INDENT]''' Arguments: None[/INDENT]
[INDENT]'''[/INDENT]
[INDENT]''' Date Developer Action[/INDENT]
[INDENT]''' --------------------------------------------------------------------------[/INDENT]
[INDENT]''' 30 Oct 98 Stephen Bullen Created[/INDENT]
[INDENT]'''[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]' IPicture requires a reference to "OLE Automation"[/INDENT]
[INDENT]Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'OLE Picture types[/INDENT]
[INDENT]Const PICTYPE_BITMAP = 1[/INDENT]
[INDENT]Const PICTYPE_ENHMETAFILE = 4[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]' Create the Interface GUID (for the IPicture interface)[/INDENT]
[INDENT]With IID_IDispatch[/INDENT]
[INDENT] .Data1 = &H7BF80980[/INDENT]
[INDENT] .Data2 = &HBF32[/INDENT]
[INDENT] .Data3 = &H101A[/INDENT]
[INDENT] .Data4(0) = &H8B[/INDENT]
[INDENT] .Data4(1) = &HBB[/INDENT]
[INDENT] .Data4(2) = &H0[/INDENT]
[INDENT] .Data4(3) = &HAA[/INDENT]
[INDENT] .Data4(4) = &H0[/INDENT]
[INDENT] .Data4(5) = &H30[/INDENT]
[INDENT] .Data4(6) = &HC[/INDENT]
[INDENT] .Data4(7) = &HAB[/INDENT]
[INDENT]End With[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]' Fill uPicInfo with necessary parts.[/INDENT]
[INDENT]With uPicInfo[/INDENT]
[INDENT] .Size = Len(uPicInfo) ' Length of structure.[/INDENT]
[INDENT] .Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE) ' Type of Picture[/INDENT]
[INDENT] .hPic = hPic ' Handle to image.[/INDENT]
[INDENT] .hPal = IIf(lPicType = CF_BITMAP, hPal, 0) ' Handle to palette (if bitmap).[/INDENT]
[INDENT]End With[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]' Create the Picture object.[/INDENT]
[INDENT]r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]' If an error occured, show the description[/INDENT]
[INDENT]If r <> 0 Then Debug.Print "Create Picture: " & fnOLEError(r)[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]' Return the new Picture object.[/INDENT]
[INDENT]Set CreatePicture = IPic[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Function[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''[/INDENT]
[INDENT]''' Subroutine: fnOLEError[/INDENT]
[INDENT]'''[/INDENT]
[INDENT]''' Purpose: Gets the message text for standard OLE errors[/INDENT]
[INDENT]'''[/INDENT]
[INDENT]''' Arguments: None[/INDENT]
[INDENT]'''[/INDENT]
[INDENT]''' Date Developer Action[/INDENT]
[INDENT]''' --------------------------------------------------------------------------[/INDENT]
[INDENT]''' 30 Oct 98 Stephen Bullen Created[/INDENT]
[INDENT]'''[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Private Function fnOLEError(lErrNum As Long) As String[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'OLECreatePictureIndirect return values[/INDENT]
[INDENT]Const E_ABORT = &H80004004[/INDENT]
[INDENT]Const E_ACCESSDENIED = &H80070005[/INDENT]
[INDENT]Const E_FAIL = &H80004005[/INDENT]
[INDENT]Const E_HANDLE = &H80070006[/INDENT]
[INDENT]Const E_INVALIDARG = &H80070057[/INDENT]
[INDENT]Const E_NOINTERFACE = &H80004002[/INDENT]
[INDENT]Const E_NOTIMPL = &H80004001[/INDENT]
[INDENT]Const E_OUTOFMEMORY = &H8007000E[/INDENT]
[INDENT]Const E_POINTER = &H80004003[/INDENT]
[INDENT]Const E_UNEXPECTED = &H8000FFFF[/INDENT]
[INDENT]Const S_OK = &H0[/INDENT]
[INDENT]
[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Select Case lErrNum[/INDENT]
[INDENT]Case E_ABORT[/INDENT]
[INDENT] fnOLEError = " Aborted"[/INDENT]
[INDENT]Case E_ACCESSDENIED[/INDENT]
[INDENT] fnOLEError = " Access Denied"[/INDENT]
[INDENT]Case E_FAIL[/INDENT]
[INDENT] fnOLEError = " General Failure"[/INDENT]
[INDENT]Case E_HANDLE[/INDENT]
[INDENT] fnOLEError = " Bad/Missing Handle"[/INDENT]
[INDENT]Case E_INVALIDARG[/INDENT]
[INDENT] fnOLEError = " Invalid Argument"[/INDENT]
[INDENT]Case E_NOINTERFACE[/INDENT]
[INDENT] fnOLEError = " No Interface"[/INDENT]
[INDENT]Case E_NOTIMPL[/INDENT]
[INDENT] fnOLEError = " Not Implemented"[/INDENT]
[INDENT]Case E_OUTOFMEMORY[/INDENT]
[INDENT] fnOLEError = " Out of Memory"[/INDENT]
[INDENT]Case E_POINTER[/INDENT]
[INDENT] fnOLEError = " Invalid Pointer"[/INDENT]
[INDENT]Case E_UNEXPECTED[/INDENT]
[INDENT] fnOLEError = " Unknown Error"[/INDENT]
[INDENT]Case S_OK[/INDENT]
[INDENT] fnOLEError = " Success!"[/INDENT]
[INDENT]End Select[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Function[/INDENT]Module 3
Code:
Option Explicit[INDENT]'Written: October 07, 2007[/INDENT]
[INDENT]'Author: Leith Ross[/INDENT]
[INDENT]'Summary: Add Minimize, and Maximize/Restore buttons to a VBA UserForm[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Private Const GWL_STYLE As Long = -16[/INDENT]
[INDENT]Public Const MIN_BOX As Long = &H20000[/INDENT]
[INDENT]Public Const MAX_BOX As Long = &H10000[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Const SC_CLOSE As Long = &HF060[/INDENT]
[INDENT]Const SC_MAXIMIZE As Long = &HF030[/INDENT]
[INDENT]Const SC_MINIMIZE As Long = &HF020[/INDENT]
[INDENT]Const SC_RESTORE As Long = &HF120[/INDENT]
[INDENT]
[/INDENT]
[INDENT] Private Declare Function GetWindowLong _[/INDENT]
[INDENT] Lib "user32.dll" _[/INDENT]
[INDENT] Alias "GetWindowLongA" _[/INDENT]
[INDENT] (ByVal hwnd As Long, _[/INDENT]
[INDENT] ByVal nIndex As Long) As Long[/INDENT]
[INDENT] Private Declare Function SetWindowLong _[/INDENT]
[INDENT] Lib "user32.dll" _[/INDENT]
[INDENT] Alias "SetWindowLongA" _[/INDENT]
[INDENT] (ByVal hwnd As Long, _[/INDENT]
[INDENT] ByVal nIndex As Long, _[/INDENT]
[INDENT] ByVal dwNewLong As Long) As Long[/INDENT]
[INDENT]'Redraw the Icons on the Window's Title Bar[/INDENT]
[INDENT] Private Declare Function DrawMenuBar _[/INDENT]
[INDENT] Lib "user32.dll" _[/INDENT]
[INDENT] (ByVal hwnd As Long) As Long[/INDENT]
[INDENT]
[/INDENT]
[INDENT]'Returns the Window Handle of the Window accepting input[/INDENT]
[INDENT] Private Declare Function GetForegroundWindow _[/INDENT]
[INDENT] Lib "user32.dll" () As Long[/INDENT]
[INDENT]
[/INDENT]
[INDENT]Public Sub AddToForm(ByVal Box_Type As Long)[/INDENT]
[INDENT]
[/INDENT]
[INDENT] Dim BitMask As Long[/INDENT]
[INDENT] Dim Window_Handle As Long[/INDENT]
[INDENT] Dim WindowStyle As Long[/INDENT]
[INDENT] Dim Ret As Long[/INDENT]
[INDENT]
[/INDENT]
[INDENT] If Box_Type = MIN_BOX Or Box_Type = MAX_BOX Then[/INDENT]
[INDENT] Window_Handle = GetForegroundWindow()[/INDENT]
[INDENT] WindowStyle = GetWindowLong(Window_Handle, GWL_STYLE)[/INDENT]
[INDENT] BitMask = WindowStyle Or Box_Type[/INDENT]
[INDENT] Ret = SetWindowLong(Window_Handle, GWL_STYLE, BitMask)[/INDENT]
[INDENT] Ret = DrawMenuBar(Window_Handle)[/INDENT]
[INDENT] End If[/INDENT]
[INDENT]
[/INDENT]
[INDENT]End Sub[/INDENT]Please advice is there is any mistake.
Thanks.
