Kodovi vezani za kontrole(objekte)

Kodove mozete probati jednostavno sa Copy-Paste

Izvrsiti download file-a sa net-a

Utvrditi dali je tvoj .exe vec otvoren

Napraviti Link za neki File

Pokrenuti neki File koji je asociran za neku aplikaaciju

Utvrditi dali postoji neki File

Otvoriti File u TextBox

Snimiti text iz TextBox-a u File

Pronaci sve Drive-ove na PC-u

Dobiti informacije o File-u (Datum kreacije, Zadnja izmjena, Zadnji pristup)

Pokrenuti IE na odredjenu adresu

Izbjeci konflikt pri otvaranju File-a

Utvrditi broj Diska

Kreacija citave strukture Directorijuma

Odsvirati .wav File iz koda

Brojac Kolona i Redova u Textualnom editoru

'Izvrsiti download file-a sa net-a
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, _
ByVal szFileName As String, ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long

Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
'Ovo daje True ukoliko je download uspio, inace daje false
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function

Private Sub Command1_Click()
If DownloadFile("http://www.website.com/index.htm", _
"c:\website.htm") Then
MsgBox "Download uspio"
Else
MsgBox "Greska Download"
End If
End Sub

'Utvrditi dali je tvoj .exe vec otvoren
Private Sub Form_Load()
If App.PrevInstance Then
msg$ = "Jedan " & App.EXEName & " je vec otvoren" & Chr$(13) & "zelis otvoriti jos jedan ?"
re = MsgBox(msg$, 52)
If re = 6 Then GoTo init Else End
End If
init:
'odavde otvaras program
End Sub

'Napraviti Link za neki File
Private Declare Function fCreateShellLink Lib "Vb5stkit.dll" _'Utvrdi koji .dll file imas
(ByVal lpstrFolderName As String, _
ByVal lpstrLinkName As String, _
ByVal lpstrLinkPath As String, _
ByVal lpstrLinkArgs As String) As Long

Private Sub Command1_Click()
Call fCreateShellLink("..\..\Desktop", "Link za Blok Notes", "c:\windows\notepad.exe", "")
End Sub

'Pokrenuti neki File koji je asociran za neku aplikaaciju
Shell ("Start C:\ImeFile-a.extenzija")

'Utvrditi dali postoji neki File
Public Sub TraziFile(ImeFile As String)
On Error Resume Next
'Otvara navedeni file
Open ImeFile For Input As #1
'U slucaju eventualne greske
If Err Then
MsgBox ("File " & ImeFile & " nije pronadjen.")
Else
MsgBox "File " & ImeFile & " postoji"
Exit Sub
End If
Close #1
End Sub

Private Sub Command1_Click()
Call TraziFile("c:\Command.com")
End Sub

'Otvoriti File u TextBox
'Text1 = MultiLine (tu otvaram File)
'Text2 = Ime File-a
Private Sub Command1_Click()
Dim BUFFER As String
Dim NRFILE As Integer
Text1.Text = ""
NRFILE = FreeFile
Open App.Path & "\" & Text2.Text For Binary As NRFILE
If LOF(NRFILE) > 20000 Then MsgBox "File je veci od 20Kb. Moze doci do greske", vbCritical
While Not EOF(NRFILE)
BUFFER = Space(2048)
Get NRFILE, , BUFFER
BUFFER = Text1.Text & BUFFER
Text1.Text = BUFFER
Wend
Close NRFILE
End Sub

'Snimiti text iz TextBox-a u File
'Text1 = Text koji ce biti snimljen u File
'Text2 = destinacija i ime File
Private Sub Command1_Click()
Dim NRFILE As Integer
On Error GoTo GRESKA
NRFILE = FreeFile
Open Text2.Text For Output As NRFILE
Print #NRFILE, Text1.Text
Close NRFILE
MsgBox "File snimljen!", vbInformation + vbOKOnly
Exit Sub
GRESKA:
MsgBox "Greska prilikom snimanja File-a.", vbCritical + vbOKOnly
End Sub

'Pronaci sve Drive-ove na PC-u
'Command1 = Pokrece funkciju
'List1 = Prikazuje sve Drive-ove
Private Declare Function GetLogicalDriveStrings Lib "kernel32" _
Alias "GetLogicalDriveStringsA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) _
As Long

Function VbGetDrivesByString(colDrives As Collection) _
As Integer
Dim strBuffer As String
Dim lngBytes As Long
Dim intPos As Integer
Dim intPos2 As Integer
Dim strDrive As String
Set colDrives = New Collection
strBuffer = Space(255)
lngBytes = GetLogicalDriveStrings(Len(strBuffer), strBuffer)
intPos2 = 1
intPos = InStr(intPos2, strBuffer, vbNullChar)
Do Until intPos = 0 Or intPos > lngBytes
strDrive = Mid(strBuffer, intPos2, intPos - intPos2)
colDrives.Add strDrive, strDrive
intPos2 = intPos + 1
intPos = InStr(intPos2, strBuffer, Chr(0))
Loop
VbGetDrivesByString = colDrives.Count
End Function

Private Sub Command1_Click()
Dim colDrives As New Collection
Dim varDrive As Variant
If VbGetDrivesByString(colDrives) > 0 Then
For Each varDrive In colDrives
List1.AddItem varDrive
Next
End If
End Sub

'Ovo je iz koda, a imate i DriveListBox koji vam automatski prikaze Drive-ove

'Dobiti informacije o File-u (Datum kreacije, Zadnja izmjena, Zadnji pristup)
'U modul .bas staviti sledeci kod:
Option Explicit
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Public Const GENERIC_READ = &H80000000
Public Const FILE_SHARE_READ = &H1
Public Const OPEN_EXISTING = 3
Public Const INVALID_HANDLE_VALUE = -1
Declare Function GetFileTime Lib "Kernel32" (ByVal hFile As Long, _
lpCreationTime As FILETIME, lpLastAccessTime As FILETIME, lpLastWriteTime As FILETIME) As Long
Declare Function CreateFile Lib "Kernel32" Alias "CreateFileA" _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long
Declare Function CloseHandle Lib "Kernel32" (ByVal hObject As Long) As Long
Declare Function FileTimeToSystemTime Lib "Kernel32" (lpFileTime As _
FILETIME, lpSystemTime As SYSTEMTIME) As Long
Sub GetFileInfo(ByVal FileName As String, stCreation As String, stModify As _
String, stAccess As String)
Dim fp As Long
Dim dtCreation As FILETIME
Dim dtModify As FILETIME
Dim dtAccess As FILETIME
Dim st As SYSTEMTIME
fp = CreateFile(FileName, GENERIC_READ, FILE_SHARE_READ, 0, _
OPEN_EXISTING, 0, 0)
If fp <> INVALID_HANDLE_VALUE Then
GetFileTime fp, dtCreation, dtAccess, dtModify
FileTimeToSystemTime dtCreation, st
stCreation = Format(st.wDay & "/" & st.wMonth & "/" & st.wYear, _
"Long Date") & " - " & _
Format(st.wHour & ":" & st.wMinute & ":" & st.wSecond, _
"hh.mm.ss")
FileTimeToSystemTime dtModify, st
stModify = Format(st.wDay & "/" & st.wMonth & "/" & st.wYear, "Long Date") & " - " & _
Format(st.wHour & ":" & st.wMinute & ":" & st.wSecond, _
"hh.mm.ss")
FileTimeToSystemTime dtAccess, st
stAccess = Format(st.wDay & "/" & st.wMonth & "/" & st.wYear, "Long Date") & " - " & _
Format(st.wHour & ":" & st.wMinute & ":" & st.wSecond, _
"hh.mm.ss")
End If
CloseHandle fp
End Sub

Private Sub Command1_Click()
Dim FileName As String
Dim vCreation As String
Dim vModify As String
Dim vAccess As String
FileName = InputBox("Upisi kompletno ime File-a. ")
GetFileInfo FileName, vCreation, vModify, vAccess
MsgBox "Datum kreacije: " & vCreation & vbCrLf & _
"Zadnja izmjena: " & vModify & vbCrLf & _
"Zadnji pristup: " & vAccess
End Sub

'Pokrenuti IE na odredjenu adresu
Sub KreniBrowser()
Dim TheBrowser As Object
Set TheBrowser = CreateObject("InternetExplorer.Application")
With TheBrowser
.Visible = True
.Navigate ("http://www.miodrag.too.it")
End With
End Sub

Private Sub Command1_Click()
KreniBrowser
End Sub

'Izbjeci konflikt pri otvaranju File-a
'U VB-u da otvorite File je potrebno odrediti broj, kao na primjeru:
Open "mojfile.txt" For Append As #1
Print #1, "text"
Close #1
'Ono sto moze da se desi, ako se otvara istovremeno vise File-ova, je
'da moze biti upisan isti broj za sve sto prouzrokuje gresku.
'U tom slucaju se savjetuje:
intFile = FreeFile()
Open "mojfile.txt" For Append As #intFile
Print #intFile, "text"
Close #intFile

'Utvrditi broj Diska
'Ovaj primjer nadovezujem na 8. primjer(gore), koji odredjuje sve Drive-ove
'koji se nalaze na Pc-u.
'Dakle, ako smo utvrdili koji Drive-ovi postoje i unijeli ih u List1 sad cemo napraviti
'da klikom na slovo u List1 dobijemo MsgBox sa serijskim brojem tog diska
Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias _
"GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer _
As String, ByVal nVolumeNameSize As Integer, lpVolumeSerialNumber As Long, _
lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal _
lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long

Function BrojDiska(strDrive As String) As Long
Dim SerialNum As Long
Dim Res As Long
Dim Temp1 As String
Dim Temp2 As String
Temp1 = String$(255, Chr$(0))
Temp2 = String$(255, Chr$(0))
Res = GetVolumeInformation(strDrive, Temp1, Len(Temp1), SerialNum, 0, 0, Temp2, Len(Temp2))
BrojDiska = SerialNum
End Function

Private Sub List1_Click()
MsgBox "Serijski broj diska " & List1.Text & " je: " & vbCrLf & vbCrLf & BrojDiska(List1.Text)
End Sub

'Kreacija citave strukture Directorijuma
'Kad instalirate vasu aplikaciju, koja ima vise Directory-a nije potrebno da ih kreirate
'jedan po jedan. Citavu strukturu mozete napraviti odjednom
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" _
(ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long

Public Sub Struktura(NewDirectory As String)
Dim sDirTest As String
Dim SecAttrib As SECURITY_ATTRIBUTES
Dim bSuccess As Boolean
Dim sPath As String
Dim iCounter As Integer
Dim sTempDir As String
iFlag = 0
sPath = NewDirectory
If Right(sPath, Len(sPath)) <> "\" Then
sPath = sPath & "\"
End If
iCounter = 1
Do Until InStr(iCounter, sPath, "\") = 0
iCounter = InStr(iCounter, sPath, "\")
sTempDir = Left(sPath, iCounter)
sDirTest = Dir(sTempDir)
iCounter = iCounter + 1
'create directory
SecAttrib.lpSecurityDescriptor = &O0
SecAttrib.bInheritHandle = False
SecAttrib.nLength = Len(SecAttrib)
bSuccess = CreateDirectory(sTempDir, SecAttrib)
Loop
End Sub

Private Sub Command1_Click()
Call Struktura("c:\Program\Poddirektory\Poddirectory1\Poddirectory2\")
End Sub

'Odsvirati .wav File iz koda
'Potrebno je u modul .bas unijeti ovu deklaraciju koja koristi dll Win multimedia
Declare Function sndPlaySound Lib "winmm" Alias "sndPlaySoundA" (ByVal _
lpszSoundName As String, ByVal uFlags As Long) As Long

Private Sub Command1_Click()
Wave = sndPlaySound("c:\windows\media\The Microsoft Sound.wav", 1)
End Sub

'Brojac Kolona i Redova u Textualnom editoru
'Ako u vasoj aplikaciji koristite vas text editor moze biti korisno da vidite
'na kojoj poziciji se nalazi kursor.
'Text1.MultiLine = True
'Label1
Option Explicit
Private Const EM_LINEFROMCHAR As Long = &HC9
Private Const EM_LINEINDEX As Long = &HBB
Private Declare Function SendMessage Lib "User32.dll" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long

Private Sub Koordinate(Obj As TextBox, ByRef Kolona As Long, ByRef Red As Long)
Red = SendMessage(Obj.hwnd, EM_LINEFROMCHAR, Obj.SelStart, 0&) + 1
Kolona = Obj.SelStart - SendMessage(Obj.hwnd, EM_LINEINDEX, Red - 1, 0&)
End Sub
Private Sub Text1_Change()
Dim Kolona As Long, Red As Long
Call Koordinate(Text1, Kolona, Red)
Label1.Caption = "Kolona: " & Kolona & " - Red: " & Red
End Sub