|
|
|
Partea a saptea a surselor (continuare).
- Auto-complete in combo-box-uri (cu date din mdb)
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const CB_FINDSTRING = &H14C
Private Const CB_SELECTSTRING = &H14D
Private Const CB_LIMITTEXT = &H141
Private Const CB_ERR = (-1)
Dim r As DAO.Recordset
Private Sub Combo1_KeyPress(KeyAscii As Integer)
Dim t$, rez&, l&
Combo1.SelText = ""
t$ = Combo1.Text & Chr$(KeyAscii)
rez& = SendMessage(Combo1.hwnd, CB_FINDSTRING, -1,ByVal t$)
If rez& <> CB_ERR Then
l& = Len(t$)
Combo1.Text = Combo1.List(rez&)
KeyAscii = 0
Combo1.SelStart = l&
Combo1.SelLength = Len(Combo1.Text) - l&
End If
End Sub
Private Sub Combo1_LostFocus()
Dim t$, rez&
t$ = Combo1.Text
rez& = SendMessage(Combo1.hwnd, CB_FINDSTRING, -1, ByVal t$)
If rez& = CB_ERR Then
Combo1.AddItem Combo1.Text
'trebuie adaugat si in baza de date
End If
End Sub
Private Sub Form_Load()
Set r = DBEngine(0).OpenDatabase(_
"C:\Program Files\DevStudio\VB\BIBLIO.MDB").OpenRecordset("Authors")
While Not r.EOF
Combo1.AddItem r.Fields(1)
r.MoveNext
Wend
r.Close
Set r = Nothing
End Sub
- Oprirea programului pentru un interval de timp
Pe lângă solutia cu Timer sau folosirea functiei API Sleep
se poate face astfel:
Private Sub Pause(interval) ' New sub
Current = Timer
Do While Timer - Current < Val(interval)
DoEvents
Loop
End Sub
- Măreste sau micsorează o imagine
Sursa este in Picture1 si va fi mutată în Picture2.
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, _
ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, _
ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, _
ByVal dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Sub Picture1_Click()
StretchBlt Picture2.hdc, 0, 0, Picture2.Width \ Screen.TwipsPerPixelX, _
Picture2.Height \ Screen.TwipsPerPixelY, _
Picture1.hdc, 0, 0, Picture1.Width \ Screen.TwipsPerPixelX, _
Picture1.Height \ Screen.TwipsPerPixelY, SRCCOPY
Picture2.Top = 0
End Sub
- Roteste o imagine sub diverse unghiuri
' add three command buttons and two pictureboxes. Load a bitmap into picture1 in design
' mode. Set both box to the same size. Routines execute 3 times faster than routines
' found in Microsoft's Knowledge Base.
private Const SRCCOPY = &HCC0020
private Const Pi = 3.14159265359
private Declare Function SetPixel Lib "GDI32" (ByVal hDC As Integer, _
ByVal X As Integer, ByVal Y As Integer, ByVal crColor As Long) As Long
private Declare Function GetPixel Lib "GDI32" (ByVal hDC As Integer, _
ByVal X As Integer, ByVal Y As Integer) As Long
private Declare Function StretchBlt% Lib "GDI32" (ByVal hDC%, ByVal X%, _
ByVal Y%, ByVal nWidth%, ByVal nHeight%, ByVal hSrcDC%, ByVal XSrc%, _
ByVal YSrc%, ByVal nSrcWidth%, ByVal nSrcHeight%, ByVal dwRop&)
Sub Form_Load ()
picture1.ScaleMode = 3
picture2.ScaleMode = 3
End Sub
Sub Command1_Click ()
'flip horizontal
picture2.Cls
px% = picture1.ScaleWidth
py% = picture1.ScaleHeight
retval% = StretchBlt(picture2.hDC, px%, 0, -px%, py%, picture1.hDC, _
0, 0, px%, py%, SRCCOPY)
End Sub
Sub Command2_Click ()
'flip vertical
picture2.Cls
px% = picture1.ScaleWidth
py% = picture1.ScaleHeight
retval% = StretchBlt(picture2.hDC, 0, py%, px%, -py%, picture1.hDC, _
0, 0, px%, py%, SRCCOPY)
End Sub
Sub Command3_Click ()
'rotate 45 degrees
picture2.Cls
Call bmp_rotate(picture1, picture2, 3.14 / 4)
End Sub
Sub bmp_rotate (pic1 As PictureBox, pic2 As PictureBox, ByVal theta!)
' bmp_rotate(pic1, pic2, theta)
' Rotate the image in a picture box.
' pic1 is the picture box with the bitmap to rotate
' pic2 is the picture box to receive the rotated bitmap
' theta is the angle of rotation
Dim c1x As Integer, c1y As Integer
Dim c2x As Integer, c2y As Integer
Dim a As Single
Dim p1x As Integer, p1y As Integer
Dim p2x As Integer, p2y As Integer
Dim n As Integer, r As Integer
c1x = pic1.ScaleWidth \ 2
c1y = pic1.ScaleHeight \ 2
c2x = pic2.ScaleWidth \ 2
c2y = pic2.ScaleHeight \ 2
If c2x < c2y Then n = c2y Else n = c2x
n = n - 1
pic1hDC% = pic1.hDC
pic2hDC% = pic2.hDC
For p2x = 0 To n
For p2y = 0 To n
If p2x = 0 Then a = Pi / 2 Else a = Atn(p2y / p2x)
r = Sqr(1& * p2x * p2x + 1& * p2y * p2y)
p1x = r * Cos(a + theta!)
p1y = r * Sin(a + theta!)
c0& = GetPixel(pic1hDC%, c1x + p1x, c1y + p1y)
c1& = GetPixel(pic1hDC%, c1x - p1x, c1y - p1y)
c2& = GetPixel(pic1hDC%, c1x + p1y, c1y - p1x)
c3& = GetPixel(pic1hDC%, c1x - p1y, c1y + p1x)
If c0& <> -1 Then xret& = SetPixel(pic2hDC%, c2x + p2x, _
c2y + p2y, c0&)
If c1& <> -1 Then xret& = SetPixel(pic2hDC%, c2x - p2x, _
c2y - p2y, c1&)
If c2& <> -1 Then xret& = SetPixel(pic2hDC%, c2x + p2y, _
c2y - p2x, c2&)
If c3& <> -1 Then xret& = SetPixel(pic2hDC%, c2x - p2y, _
c2y + p2x, c3&)
Next
t% = DoEvents()
Next
End Sub
- PC-ul are placa de sunet?
Private Declare Function waveOutGetNumDevs Lib "MMSYSTEM" () As Integer
i% = waveOutGetNumDevs()
If i% > 0 Then
MsgBox "You Can Play Wave Data"
Else
MsgBox "Cannot Play Wave Data"
End If
- Invocarea conexiunii Dial-Up
Dim X
'"MyConnectionsName" is the name under the icon in Dial-up Networking
X = Shell("rundll32.exe rnaui.dll,RnaDial " & "MyConnectionsName", 1)
DoEvents
'You can type in your password before the { below.
SendKeys "{enter}", True
DoEvents
End Sub
- Umplerea un picture-box cu aceeasi imagine (repetata)
Private Declare Function BitBlt Lib "GDI32" (ByVal hDestDC As Integer, _
ByVal X As Integer, ByVal Y As Integer, ByVal nWid As Integer, _
ByVal nHt As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, _
ByVal YSrc As Integer, ByVal dwRop As Long) As Integer
Private Sub Tile(picParent As PictureBox, picTile As PictureBox)
'This subroutine tiles a picture onto another picture.
'call syntax: Tile Picture1, Picture2
' Tile (destination), (source)
Dim TileIt As Integer
Const SRCCOPY = &HCC0020
Dim X As Integer, Y As Integer
Dim MaximumX As Integer, MaximumY As Integer
MaximumX = picParent.Width + picTile.Width
MaximumY = picParent.Height + picTile.Height
MaximumX = MaximumX \ Screen.TwipsPerPixelX
MaximumY = MaximumY \ Screen.TwipsPerPixelY
Dim TileWidth As Integer, TileHeight As Integer
TileWidth = picTile.Width \ Screen.TwipsPerPixelX
TileHeight = picTile.Height \ Screen.TwipsPerPixelY
For Y = 0 To MaximumY Step TileHeight
For X = 0 To MaximumX Step TileWidth
TileIt = BitBlt(picParent.hDC, X, Y, TileWidth, TileHeight, _
picTile.hDC, 0, 0, SRCCOPY)
Next
Next
End Sub
- Umplerea unei forme cu aceeasi imagine (repetata)
Private Declare Function BitBlt Lib "GDI32" (ByVal hDestDC As Integer, _
ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, _
ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, _
ByVal YSrc As Integer, ByVal dwRop As Long) As Integer
Dim maxhgt As Long, maxwid As Long
Dim pwid As Integer, phgt As Integer
Sub Form_Load ()
picture1.ScaleMode = 3
picture1.Visible = False
picture1.AutoSize = True
picture1.AutoRedraw = True
pwid = picture1.ScaleWidth
phgt = picture1.ScaleHeight
End Sub
Sub Form_Paint ()
phDC& = picture1.hDC
frmhdc& = hdc
For j% = 0 To maxhgt Step phgt
For i% = 0 To maxwid Step pwid
X% = BitBlt(frmhdc&, i%, j%, pwid, phgt, phDC&, 0, 0, &HCC0020)
Next
Next
End Sub
Sub Form_Resize ()
maxhgt = Height \ screen.TwipsPerPixelY
maxwid = Width \ screen.TwipsPerPixelX
End Sub
- Mutarea / copierea fisierelor cu API
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" _
(ByVal lpExistingFileName As String, ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" _
(ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
'Place the following code in under a command button or in a menu, etc...
source = "C:\myfile.txt"
target = "C:\Windows\myfile.txt"
'Copy File
A = CopyFile(Trim$(Source), Trim(Target), False)
If A Then
MsgBox "File copied!"
Else
MsgBox "Error. File not moved!"
End If
- Spatiu liber pe HDD
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" ( _
ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, _
lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
Dim free_Space As Long
ChDrive "C:"
Dim numSectorsPerCluster As Long
Dim numBytesPerSector As Long
Dim numFreeClusters As Long
Dim numTotalClusters As Long
Dim success As Boolean
success = GetDiskFreeSpace("C:\", numSectorsPerCluster, numBytesPerSector, _
numFreeClusters, numTotalClusters)
free_Space = numSectorsPerCluster * numBytesPerSector * numFreeClusters
Label1.Caption = "The total free space on Drive C: = " & _
format(Str$(free_Space/1024),"###,### ") & " KB"
- Determinare an bisect sau nu
Function IsLeapYear(ByVal sYear As String) As Boolean
If IsDate("02/29/" & sYear) Then
IsLeapYear = True
Else
IsLeapYear = False
End If
End Function
- Data este in week-end?
Public Function IsWeekend(ByVal vntDate As Variant) As Boolean
Dim bResult As Boolean
If IsDate(vntDate) Then
If (WeekDay(vntDate) Mod 6 = 1) Then bResult = True Else bResult = False
Else
Err.Raise 13, "Type Mismatch, Must Be Date"
End If
IsWeekend = bResult
End Function
|
| |
|
|
Visual
Basic Românesc
