dat form o vi tri cho truoc

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long As Lon

Trang 1

1 Private Enum FormPosition

2 FrmTopLeft = 0

3 FrmTopRight = 1

4 FrmCenter = 2

5 FrmBottomLeft = 3

6 FrmBottomRight = 4

7 End Enum

8

9 Private Type RECT

10 Left As Long

11 Top As Long

12 Right As Long

13 Bottom As Long

14 End Type

15

16 Private Declare Function SystemParametersInfo Lib

"user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long

17 Private Const SPI_GETWORKAREA As Long = 48

18

19 Private Function MoveForm(Frm As Form, Optional sType

As FormPosition = 2) As Long

20 Dim Area As RECT

21 If SystemParametersInfo(SPI_GETWORKAREA, 0, Area, 0) <> 0 Then

22 Select Case sType

23 Case 0

24 Frm.Move 0, 0

25 Case 1

26 Frm.Move Frm.ScaleX(Area.Right,

vbPixels, vbTwips) - Frm.Width, 0

27 Case 2

28 Frm.Move (Frm.ScaleX(Area.Right, vbPixels, vbTwips) - Frm.Width) \ 2,

(Frm.ScaleY(Area.Bottom, vbPixels, vbTwips) - Frm.Height) \ 2

29 Case 3

30 Frm.Move 0, Frm.ScaleY(Area.Bottom, vbPixels, vbTwips) - Frm.Height

31 Case 4

vbPixels, vbTwips) - Frm.Width, Frm.ScaleY(Area.Bottom, vbPixels, vbTwips) - Frm.Height

33 End Select

34 End If

35 End Function

36

37 Private Sub Form_Load()

38 'MoveForm Me, FrmBottomLeft

39 'MoveForm Me, FrmBottomRight

40 MoveForm Me, FrmCenter

41 'MoveForm Me, FrmTopLeft

42 'MoveForm Me, FrmTopRight

43 End Sub

 Top

Trang 2

2- Doc textbox theo tung dong

1

2 Function TachDong(mStr As String) As Collection

3 Dim cLt As New Collection

4 Dim pos As Integer

5 Dim mLine As String

6 mStr = mStr + vbNewLine

7 pos = InStr(mStr, Chr(13))

8 Do While pos <> 0

9 mLine = Left(mStr, pos - 1)

10 cLt.Add mLine

11 mStr = Right(mStr, Len(mStr) - pos - 1)

12 pos = InStr(mStr, Chr(13))

14 Set TachDong = cLt

15 End Function

16

Hàm tách dòng trả về 1 đối tượng kiểu Collection (cách sử dụng đối tượng này giống y như listbox)

Cách dùng:

Code: Chọn tất cả

1

2 Private Sub Command1_Click()

3 Dim cL As New Collection 'Tạo một đối tượng Collection

4 Set cL = TachDong(Text1.Text) 'Gán đối tượng này bằng đối tượng trả về của TachDong

5

6 Dim I As Integer

7 Dim nmLine

8

9 For I = 1 To cL.Count 'Duyệt tất cả các item của cL

10 nmLine = CStr(cL.Item(I))

11 List1.AddItem nmLine 'add mỗi dòng trong cL vào listBox

13 End Sub

14

3- Đọc và Ghi trên Excel (xls) với TextBox chuẩn

ta da quen với việc muốn đọc và ghi trên file Excel (xls) buộc phải chèn thư viện Excel

Bài viết kèm Project sau rình bày kỹ thuật Đọc và Ghi trên Excel (xls) với TextBox chuẩn

(Thực ra là do DDE [Dynamic Data Exchange] thực hiện, mà TextBox chuẩn được MS thiết kế có kèm hoạt động của DDE)

* Code hoạt động trên XP SP2, cần Text1 và vài command như trong code Giao tiếp với file XLS (2003)

1 Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal

lpOperation As String, ByVal lpFile As String, ByVal

Trang 3

lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

2 Const SW_SHOWNORMAL = 1

3

4 Private Sub Command1_Click() ' Ðoc Sheet1

5 OpenExcel

6 Text1.LinkMode = 0

7 Text1.LinkTopic = "Excel|Book1.xls"

8 Text1.LinkItem = "R1C1:R6C2"

11 CloseExcel

12 End Sub

13

14 'truongphu

15 Private Sub Command2_Click() ' Ðoc Sheet2

16 OpenExcel

18 Text1.LinkTopic = "Excel|Sheet2"

22 CloseExcel

23 End Sub

24

25 Private Sub Command3_Click() ' Ghi Sheet1

26 OpenExcel

31 Text1 = "Ho" & vbTab & "Tên" & vbTab & "Tuôi" & vbCrLf & "Bùi" & vbTab & "Toàn" & vbTab & 22

32 Text1.LinkPoke

34 'CloseExcel

35 End Sub

36

37 Private Sub Command4_Click() ' Font Cell

38 OpenExcel

42 Text1.LinkExecute ("[SELECT(""R2C5"")]")

43 Text1.LinkExecute ("[FONT.PROPERTIES(""Times New Roman"",""Bold"",10)]")

45 'CloseExcel

46 End Sub

Trang 4

48 Sub CloseExcel() ' not save

49 Set aaa = GetObject("winmgmts:\root\cimv2").ExecQuery _

50 ("Select * from Win32_Process Where Name =

'Excel.exe'")

51 For Each a In aaa

52 a.Terminate

53 Next

54 End Sub

55

56 Sub OpenExcel()

57 If IsFileOpen(App.Path & "\qqq.xls") = False Then

58 ShellExecute Me.hwnd, vbNullString, App.Path &

"\Book1.xls", _

59 vbNullString, vbNullString, SW_SHOWNORMAL

60 End If

61 End Sub

62

63 Function IsFileOpen(FileName As String) As Boolean

64 Dim filenum As Integer 'truongphu

65 filenum = FreeFile()

66 On Error Resume Next

67 Open FileName For Input Lock Read As #filenum

68 Close filenum

69 Select Case Err

70 Case 0

71 IsFileOpen = False

72 Case 70

73 IsFileOpen = True

74 Case Else

75 End Select

76 End Function

77

4-Đóng ứng dụng rất phong cách

2 Form1.Height = 6400

3 Form1.Width = 10000

4 End Sub

5 Private Sub Form_MouseUp(Button As Integer, Shift As

Integer, X As Single, Y As Single)

6 If Button = vbRightButton Then

7 coolCloseForm Me, 20

8 Else

9 Dim a As New Form1

10 a.Height = a.Height / 2

11 a.Width = a.Width / 2

12 a.Show

Trang 5

13 End If

14 End Sub

15

16 Public Function coolCloseForm(closeForm As Form, speed

As Integer) 17

18 If speed = 0 Then

19 MsgBox "Speed cannot zero"

20 Exit Function

21 End If

22

23 On Error Resume Next

24 closeForm.ScaleMode = 1

25 closeForm.WindowState = 0

26 Do Until closeForm.Height <= 405

27 DoEvents

28 closeForm.Height = closeForm.Height - speed * 10

29 closeForm.Top = closeForm.Top + speed

* 5

30 Loop

31 Do Until closeForm.Width <= 1680

32 DoEvents

33 closeForm.Width = closeForm.Width

- speed * 10

34 closeForm.Left = closeForm.Left + speed * 5

35 Loop

36 Unload closeForm

37 End Function

5-Đặt form tại những vị trí cho trước

1 Private Enum FormPosition

2 FrmTopLeft = 0

3 FrmTopRight = 1

4 FrmCenter = 2

5 FrmBottomLeft = 3

6 FrmBottomRight = 4

7 End Enum

8

9 Private Type RECT

10 Left As Long

11 Top As Long

12 Right As Long

13 Bottom As Long

14 End Type

15

16 Private Declare Function SystemParametersInfo Lib

"user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long

17 Private Const SPI_GETWORKAREA As Long = 48

18

Trang 6

19 Private Function MoveForm(Frm As Form, Optional sType

As FormPosition = 2) As Long

20 Dim Area As RECT

21 If SystemParametersInfo(SPI_GETWORKAREA, 0, Area, 0) <> 0 Then

22 Select Case sType

23 Case 0

24 Frm.Move 0, 0

25 Case 1

vbPixels, vbTwips) - Frm.Width, 0

27 Case 2

28 Frm.Move (Frm.ScaleX(Area.Right, vbPixels, vbTwips) - Frm.Width) \ 2,

(Frm.ScaleY(Area.Bottom, vbPixels, vbTwips) - Frm.Height) \ 2

29 Case 3

30 Frm.Move 0, Frm.ScaleY(Area.Bottom, vbPixels, vbTwips) - Frm.Height

31 Case 4

vbPixels, vbTwips) - Frm.Width, Frm.ScaleY(Area.Bottom, vbPixels, vbTwips) - Frm.Height

33 End Select

34 End If

35 End Function

36

38 'MoveForm Me, FrmBottomLeft

39 'MoveForm Me, FrmBottomRight

40 MoveForm Me, FrmCenter

41 'MoveForm Me, FrmTopLeft

42 'MoveForm Me, FrmTopRight

43 End Sub

 Top

VẼ BIỂU ĐỒ QUẢN LÝ VẬT TƯ TỒN KHO TRONG VISUAL BISIC

Lý do: Tại giao điểm Y1 = Y2 thì X = 400

Thế vào Y = P * R + Y1 + Y2 thì Y hơn 80000, vượt khỏi xa picture1!

1 Private Sub Command4_Click()

2 Picture1.Cls

3 Picture1.ForeColor = vbBlack

4 ' Ve truc toa do vo'i y là log10

5 Dim td As Double

6 td = Log(10)

7 Dim YY As Single, k As Long, j As Double, ii As Double

8

9 Picture1.Scale (0, 6)-(1000, -1) ''scale to 0 to 1000 in

X, set the Y scale from 4 to -2 tu'` 4 trên xuô'ng 0

10 'nêu tu'` -2 xuô'ng 4 thì viêt Picture1.Scale (0, -2)-(3, 4)

12 For k = 5 To 0 Step -1 ' Ðao lôn lai

13 j = 10 ^ k

14 For ii = 10 * j To j Step -j ' Ðao lôn lai

15 YY = Log(ii) / td

16

17 Picture1.Line (0, YY)-(Picture1.ScaleWidth, YY)

18 If ii = j Then

Trang 7

19 Picture1.CurrentY = Picture1.CurrentY - Picture1.TextHeight("W") ' canh lai

20 Picture1.CurrentX = 0

21 Picture1.Print ii

22 End If

23 Next

24 Next

25 For i = 0 To 1000 Step 100

26 Picture1.Line (i, 0)-(i, 0.1), vbBlue ' Ðánh dâ'u

27 Picture1.CurrentX = Picture1.CurrentX - Picture1.TextWidth("aa")

28 Picture1.CurrentY = Picture1.CurrentY + Picture1.TextHeight("a")

29 Picture1.Print i

30 Next i

31 ' ve duong bieu dien ham so

32 ' -y1

33 Picture1.ForeColor = vbYellow

34 X = 1

35 y = Log(1.5 * X) / td

36 Picture1.CurrentX = X

37 Picture1.CurrentY = y

38 For X = 1 To 1000

39 y = Log(1.5 * X) / td

40 Picture1.Line -(X, y)

41 Next X

42 ' -y2

43 Picture1.ForeColor = vbRed

44 X = 1

45 y = Log(240000 / X) / td

48 For X = 1 To 1000

49 y = Log(240000 / X) / td

51 Next X

52 ' -Y = y1 + y2

53 Picture1.ForeColor = vbBlue

54 X = 1

55 y = Log(80000 + (240000 / X) + (1.5 * X)) / td

58 For X = 1 To 1000

59 y = Log(80000 + (240000 / X) + (1.5 * X)) / td

61 Next X

62 End Sub

63

Tạo ListBox và ComboBox ngược

Trang 8

1 Private Declare Function GetWindowLong Lib "user32" Alias

"GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long)

As Long

2 Private Declare Function SetWindowLong Lib "user32" Alias

"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

3 Private Const GWL_STYLE = (-16)

4 Private Const GWL_EXSTYLE = (-20)

5

7 'Test

8 Dim i As Byte

9 For i = 0 To 10

10 Combo1.AddItem "Dong thu " & i

11 List1.AddItem "Dong thu " & i

13

14

15 Dim m_Style_Cmb As Long

16 m_Style_Cmb = GetWindowLong(Combo1.hwnd, GWL_EXSTYLE)

17 m_Style_Cmb = m_Style_Cmb Or &H3000

18 Call SetWindowLong(Combo1.hwnd, GWL_EXSTYLE,

m_Style_Cmb) 19

20 Dim m_Style_Lst As Long

21 m_Style_Lst = GetWindowLong(List1.hwnd, GWL_EXSTYLE)

22 ' m_Style_Lst = m_Style Or &H4000 'Chu canh lề Trái

23 m_Style_Lst = m_Style_Lst Or &H5000 'Chu canh lề Phải

24 Call SetWindowLong(List1.hwnd, GWL_EXSTYLE,

m_Style_Lst)

25 End Sub

26

Tạo form bằng Code

1 Option Explicit

2 Declare Function CreateWindowEx Lib "user32" Alias

"CreateWindowExA" (ByVal dwExStyle As Long, _

3 ByVal lpClassName As String, _

4 ByVal lpWindowName As String, _

5 ByVal dwStyle As Long, _

6 ByVal x

As Long, _

7 ByVal y

As Long, _

8 ByVal nWidth As Long, _

9 ByVal nHeight As Long, _

10 ByVal hWndParent As Long, _

11 ByVal hMenu As Long, _

12 ByVal hInstance As Long, _

Trang 9

13 lpParam As Any) As Long

14

15 Declare Function LoadIcon Lib "user32" Alias

"LoadIconA" (ByVal hInstance As Long, ByVal lpIconName As String) As Long

16 Declare Function LoadCursor Lib "user32" Alias

"LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName

As String) As Long

17 Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long

18 Declare Function RegisterClassEx Lib "user32" Alias

"RegisterClassExA" (pcWndClassEx As WNDCLASSEX) As Integer

19 Declare Function ShowWindow Lib "user32" (ByVal hwnd

As Long, ByVal nCmdShow As Long) As Long

20 Declare Function UpdateWindow Lib "user32" (ByVal hwnd

As Long) As Long

21 Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long

22 Declare Function PostMessage Lib "user32" Alias

"PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

23 Declare Function DefWindowProc Lib "user32" Alias

"DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

24 Declare Function GetMessage Lib "user32" Alias

"GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long

25 Declare Function TranslateMessage Lib "user32" (lpMsg

As MSG) As Long

26 Declare Function DispatchMessage Lib "user32" Alias

"DispatchMessageA" (lpMsg As MSG) As Long

27 Declare Sub PostQuitMessage Lib "user32" (ByVal

nExitCode As Long)

28 Declare Function BeginPaint Lib "user32" (ByVal hwnd

As Long, lpPaint As PAINTSTRUCT) As Long

29 Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long

30 Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

31 Declare Function DrawText Lib "user32" Alias

"DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long

32

33

34 Type WNDCLASSEX

35 cbSize As Long

36 style As Long

37 lpfnWndProc As Long

38 cbClsExtra As Long

39 cbWndExtra As Long

40 hInstance As Long

41 hIcon As Long

42 hCursor As Long

43 hbrBackground As Long

44 lpszMenuName As String

45 lpszClassName As String

46 hIconSm As Long

47 End Type

48

49

50 Type POINTAPI

Trang 10

51 x As Long

52 y As Long

53 End Type

54

55 Type MSG

56 hwnd As Long

57 message As Long

58 wParam As Long

59 lParam As Long

60 time As Long

61 pt As POINTAPI

62 End Type

63

64 Type RECT

65 Left As Long

66 Top As Long

67 Right As Long

68 Bottom As Long

69 End Type

70

71 Type PAINTSTRUCT

72 hdc As Long

73 fErase As Long

74 rcPaint As RECT

75 fRestore As Long

76 fIncUpdate As Long

77 rgbReserved(32) As Byte 'this was declared incorrectly in VB API viewer

78 End Type

79

80 Public Const WS_VISIBLE As Long = &H10000000

81 Public Const WS_VSCROLL As Long = &H200000

82 Public Const WS_TABSTOP As Long = &H10000

83 Public Const WS_THICKFRAME As Long = &H40000

84 Public Const WS_MAXIMIZE As Long = &H1000000

85 Public Const WS_MAXIMIZEBOX As Long = &H10000

86 Public Const WS_MINIMIZE As Long = &H20000000

87 Public Const WS_MINIMIZEBOX As Long = &H20000

88 Public Const WS_SYSMENU As Long = &H80000

89 Public Const WS_BORDER As Long = &H800000

90 Public Const WS_CAPTION As Long = &HC00000 ' WS_BORDER Or WS_DLGFRAME

91 Public Const WS_CHILD As Long = &H40000000

92 Public Const WS_CHILDWINDOW As Long = (WS_CHILD)

93 Public Const WS_CLIPCHILDREN As Long = &H2000000

94 Public Const WS_CLIPSIBLINGS As Long = &H4000000

95 Public Const WS_DISABLED As Long = &H8000000

96 Public Const WS_DLGFRAME As Long = &H400000

97 Public Const WS_EX_ACCEPTFILES As Long = &H10&

98 Public Const WS_EX_DLGMODALFRAME As Long = &H1&

99 Public Const WS_EX_NOPARENTNOTIFY As Long = &H4&

100 Public Const WS_EX_TOPMOST As Long = &H8&

101 Public Const WS_EX_TRANSPARENT As Long = &H20&

102 Public Const WS_GROUP As Long = &H20000

103 Public Const WS_HSCROLL As Long = &H100000

104 Public Const WS_ICONIC As Long = WS_MINIMIZE

105 Public Const WS_OVERLAPPED As Long = &H0&

106 Public Const WS_OVERLAPPEDWINDOW As Long =

(WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME

Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)

107 Public Const WS_POPUP As Long = &H80000000

108 Public Const WS_POPUPWINDOW As Long = (WS_POPUP Or WS_BORDER Or WS_SYSMENU)

Định dạng
Số trang	13
Dung lượng	118,5 KB