Disable edit in ComboBox by code
|
Private Sub obj_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub
|
|
Log on file
|
Public Function LogOnFile(level As Integer, str As String) As Boolean
Dim sLine As String
Dim iFile As Integer
Dim path As String
Dim LOGLEVEL As Integer
path = "prova.log"
iFile = FreeFile
Open path For Append Access Read Write Shared As iFile
'Print #iFile, format$(Now, "dd/mm/yyyy") & " " & Time$ & " " & format$(err.Number, "00000") & " ";
Print #iFile, Format$(Now, "dd/mm/yyyy") & " " & Time$ & " ";
Print #iFile, Left$(str + Space$(100), 100)
Close iFile
If level = 0 Then
MsgBox str
End If
End Function
|
|
Get drive, paths, extensions,...
|
Public Function GetPath(PathFile As String) As String
Dim i As Integer
Dim j As Integer
j = 1
Do
i = InStr(j, PathFile, "\")
If i > 0 Then
j = i + 1
Else
Exit Do
End If
Loop
If j > 1 Then
GetPath = Left(PathFile, j - 1)
Else
GetPath = "\"
End If
End Function
Public Function GetDrive(PathFile As String) As String
Dim i As Integer
i = InStr(PathFile, "\")
If i > 1 Then
GetDrive = Left(PathFile, i - 1)
Else
GetDrive = ""
End If
End Function
Public Function GetFile(PathFile As String) As String
Dim i As Integer
Dim j As Integer
j = 1
Do
i = InStr(j, PathFile, "\")
If i > 0 Then
j = i + 1
Else
Exit Do
End If
Loop
GetFile = Mid(PathFile, j)
End Function
Public Function GetExt(PathFile As String) As String
Dim sFile As String
Dim i As Integer
sFile = GetFile(PathFile)
i = InStr(sFile, ".")
If i > 0 Then
GetExt = Mid(sFile, i)
End If
End Function
Public Function GetFileNoExt(PathFile As String) As String
Dim i As Integer
Dim sFile As String
sFile = GetFile(PathFile)
i = InStr(sFile, ".")
If i > 0 Then
GetFileNoExt = Left(sFile, i - 1)
Else
GetFileNoExt = sFile
End If
End Function
|
|
Put in a ComboBox one field of a table
|
Public Function DbPutCombo(table As String, field As String, id As String, cmb As ComboBox) As Recordset
Dim r As Recordset
On Error Resume Next ' BEL 02.11.98
Set r = gDatabase.OpenRecordset(table, dbOpenDynaset)
r.MoveFirst
Do While Not r.EOF
cmb.AddItem r.fields(field).Value
cmb.ItemData(cmb.ListCount - 1) = r.fields(id).Value
r.MoveNext
Loop
Set DbPutCombo = r
End Function
|
|
Put in a ComboBox a file
|
Public Function FilePutCombo(path As String, cmb As ComboBox) As Integer
Dim sLine As String
Dim iFile As Integer
Dim i As Integer
i = 1
iFile = FreeFile
Open path For Input As iFile
Do
Line Input #iFile, sLine
sLine = RTrim(sLine)
If Left(sLine, 1) <> "#" Then
cmb.AddItem sLine
cmb.ItemData(cmb.ListCount - 1) = i
i = i + 1
End If
Loop Until EOF(iFile)
FilePutCombo = i - 1
cmb.listindex = 0
Close iFile
End Function
|
|
Round
|
'*----------------------------------------------------------*
'* Name : Round *
'*----------------------------------------------------------*
'* Purpose : Rounds a decimal number to a specified *
'* : number of decimal places. *
'*----------------------------------------------------------*
'* Parameters : nValue Required. Number to round. *
'* : nDigits Required. Number of decimal places. *
'*----------------------------------------------------------*
'* Returns : Rounded value *
'*----------------------------------------------------------*
Public Function Round(nValue As Double, nDigits As Integer) As Double
Round = Int(nValue * (10 ^ nDigits) + 0.5) / (10 ^ nDigits)
End Function
|
|
Byte Operations
|
Function LOWORD(ByVal dw As Long) As Integer
If dw And &H8000& Then
LOWORD = dw Or &HFFFF0000
Else
LOWORD = dw And &HFFFF&
End If
End Function
Function LOBYTE(ByVal w As Integer) As Byte
LOBYTE = w And &HFF
End Function
Function HIBYTE(ByVal w As Integer) As Byte
HIBYTE = (w And &HFF00&) \ 256
End Function
'*----------------------------------------------------------*
'* Name : MAKELONG *
'*----------------------------------------------------------*
'* Purpose : Combines two integers into a long integer. *
'*----------------------------------------------------------*
'* Parameters : wLow Required. Low WORD. *
'* : wHigh Required. High WORD. *
'*----------------------------------------------------------*
'* Description: This function is equivalent to the 'C' *
'* : language MAKELONG macro. *
'*----------------------------------------------------------*
Public Function MAKELONG(wLow As Long, wHigh As Long) As Long
MAKELONG = LOWORD(wLow) Or (&H10000 * LOWORD(wHigh))
End Function
'*----------------------------------------------------------*
'* Name : MAKELPARAM *
'*----------------------------------------------------------*
'* Purpose : Combines two integers into a long integer. *
'*----------------------------------------------------------*
'* Parameters : wLow Required. Low WORD. *
'* : wHigh Required. High WORD. *
'*----------------------------------------------------------*
'* Description: This function is equivalent to the 'C' *
'* : language MAKELPARAM macro. *
'*----------------------------------------------------------*
Public Function MAKELPARAM(wLow As Long, wHigh As Long) As Long
MAKELPARAM = MAKELONG(wLow, wHigh)
End Function
'*----------------------------------------------------------*
'* Name : MAKEWORD *
'*----------------------------------------------------------*
'* Purpose : Combines two integers into a 16-bit unsigned*
'* : integer (word). *
'*----------------------------------------------------------*
'* Parameters : wLow Required. Low BYTE. *
'* : wHigh Required. High BYTE. *
'*----------------------------------------------------------*
'* Description: This function is equivalent to the 'C' *
'* : language MAKELONG macro. *
'*----------------------------------------------------------*
Public Function MAKEWORD(wLow As Long, wHigh As Long) As Long
MAKEWORD = LOBYTE(wLow) Or (&H100& * LOBYTE(wHigh))
End Function
'*----------------------------------------------------------*
'* Name : LOWORD *
'*----------------------------------------------------------*
'* Purpose : Returns the low 16-bit integer from a 32-bit*
'* : long integer. *
'*----------------------------------------------------------*
'* Parameters : dwValue Required. 32-bit long integer value.*
'*----------------------------------------------------------*
'* Description: This function is equivalent to the 'C' *
'* : language LOWORD macro. *
'*----------------------------------------------------------*
Public Function LOWORD1(dwValue As Long) As Integer
MoveMemory LOWORD1, dwValue, 2
End Function
'*----------------------------------------------------------*
'* Name : HIWORD *
'*----------------------------------------------------------*
'* Purpose : Returns the high 16-bit integer from a *
'* : 32-bit long integer. *
'*----------------------------------------------------------*
'* Parameters : dwValue Required. 32-bit long integer value.*
'*----------------------------------------------------------*
'* Description: This function is equivalent to the 'C' *
'* : language HIWORD macro. *
'*----------------------------------------------------------*
Public Function HIWORD1(dwValue As Long) As Integer
MoveMemory HIWORD1, ByVal VarPtr(dwValue) + 2, 2
End Function
'*----------------------------------------------------------*
'* Name : LOBYTE *
'*----------------------------------------------------------*
'* Purpose : Returns the low 8-bit byte from a low word *
'* : of 32-bit long integer. *
'*----------------------------------------------------------*
'* Parameters : dwValue Required. 32-bit long integer value.*
'*----------------------------------------------------------*
'* Description: This function is equivalent to the 'C' *
'* : language LOBYTE macro. *
'*----------------------------------------------------------*
Public Function LOBYTE1(dwValue As Long) As Byte
MoveMemory LOBYTE1, LOWORD(dwValue), 1
End Function
'*----------------------------------------------------------*
'* Name : HIBYTE *
'*----------------------------------------------------------*
'* Purpose : Returns the high 8-bit byte from a low word *
'* : of 32-bit long integer. *
'*----------------------------------------------------------*
'* Parameters : dwValue Required. 32-bit long integer value.*
'*----------------------------------------------------------*
'* Description: This function is equivalent to the 'C' *
'* : language HIBYTE macro. *
'*----------------------------------------------------------*
Public Function HIBYTE1(dwValue As Long) As Byte
MoveMemory HIBYTE1, ByVal VarPtr(LOWORD(dwValue)) + 1, 1
End Function
'*----------------------------------------------------------*
'* Name : vbShiftLeft *
'*----------------------------------------------------------*
'* Purpose : Shift 32-bit integer value left 'n' bits. *
'*----------------------------------------------------------*
'* Parameters : Value Required. Value to shift. *
'* : Count Required. Number of bit positions to *
'* : shift value. *
'*----------------------------------------------------------*
'* Description: This function is equivalent to the 'C' *
'* : language construct '<<'. *
'*----------------------------------------------------------*
Public Function vbShiftLeft(ByVal Value As Long, _
Count As Integer) As Long
Dim i As Integer
vbShiftLeft = Value
For i = 1 To Count
vbShiftLeft = vbShiftLeft * 2
Next
End Function
'*----------------------------------------------------------*
'* Name : vbShiftRight *
'*----------------------------------------------------------*
'* Purpose : Shift 32-bit integer value right 'n' bits. *
'*----------------------------------------------------------*
'* Parameters : Value Required. Value to shift. *
'* : Count Required. Number of bit positions to *
'* : shift value. *
'*----------------------------------------------------------*
'* Description: This function is equivalent to the 'C' *
'* : language construct '>>'. *
'*----------------------------------------------------------*
Public Function vbShiftRight(ByVal Value As Long, _
Count As Integer) As Long
Dim i As Integer
vbShiftRight = Value
For i = 1 To Count
vbShiftRight = vbShiftRight \ 2
Next
End Function
'*----------------------------------------------------------*
'* Name : BitSet *
'*----------------------------------------------------------*
'* Purpose : Sets a given Bit in Number *
'*----------------------------------------------------------*
Public Function BitSet(Number As Long, _
ByVal Bit As Long) As Long
If Bit = 31 Then
Number = &H80000000 Or Number
Else
Number = (2 ^ Bit) Or Number
End If
BitSet = Number
End Function
'*----------------------------------------------------------*
'* Name : BitClear *
'*----------------------------------------------------------*
'* Purpose : Clears a given Bit in Number *
'*----------------------------------------------------------*
Public Function BitClear(Number As Long, _
ByVal Bit As Long) As Long
If Bit = 31 Then
Number = &H7FFFFFFF And Number
Else
Number = ((2 ^ Bit) Xor &HFFFFFFFF) And Number
End If
BitClear = Number
End Function
'*----------------------------------------------------------*
'* Name : BitIsSet *
'*----------------------------------------------------------*
'* Purpose : Test if bit 0 to bit 31 is set *
'*----------------------------------------------------------*
Public Function BitIsSet(ByVal Number As Long, _
ByVal Bit As Long) As Boolean
BitIsSet = False
If Bit = 31 Then
If Number And &H80000000 Then BitIsSet = True
Else
If Number And (2 ^ Bit) Then BitIsSet = True
End If
End Function
|
|
Spool a external file
|
'
' Win32 API Calls
'
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Private Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrn As Long, pDefault As Any) As Long
Private Declare Function StartDocPrinter Lib "winspool.drv" Alias "StartDocPrinterA" (ByVal hPrn As Long, ByVal level As Long, pDocInfo As DOC_INFO_1) As Long
Private Declare Function StartPagePrinter Lib "winspool.drv" (ByVal hPrn As Long) As Long
Private Declare Function WritePrinter Lib "winspool.drv" (ByVal hPrn As Long, pBuf As Any, ByVal cdBuf As Long, pcWritten As Long) As Long
Private Declare Function EndPagePrinter Lib "winspool.drv" (ByVal hPrn As Long) As Long
Private Declare Function EndDocPrinter Lib "winspool.drv" (ByVal hPrn As Long) As Long
Private Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrn As Long) As Long
'
' Structure required by StartDocPrinter
'
Private Type DOC_INFO_1
pDocName As String
pOutputFile As String
pDatatype As String
End Type
Public Sub SpoolFile(sFile As String, PrnName As String, Optional AppName As String = "")
Dim hPrn As Long
Dim buffer() As Byte
Dim hFile As Integer
Dim Written As Long
Dim di As DOC_INFO_1
Dim i As Long
Dim ret As Long
Const BufSize As Long = &H4000
On Error GoTo err1
LogOnFile 1, "SpoolFile " & sFile & " on printer:" & PrnName
'
' Extract filename from passed spec, and build job name.
' Fill remainder of DOC_INFO_1 structure.
'
If InStr(sFile, "\") Then
For i = Len(sFile) To 1 Step -1
If Mid(sFile, i, 1) = "\" Then Exit For
di.pDocName = Mid(sFile, i, 1) & di.pDocName
Next i
Else
di.pDocName = sFile
End If
If Len(AppName) Then
di.pDocName = AppName & ": " & di.pDocName
End If
di.pOutputFile = vbNullString
di.pDatatype = "RAW"
'
' Open printer for output to obtain handle.
' Set it up to begin recieving raw data.
'
On Error Resume Next
ret = OpenPrinter(PrnName, hPrn, vbNullString)
If ret = 0 Then
LogOnFile 0, "SpoolFile.Stampante:" & PrnName & " non riconosciuta (" & err.Number & "):" & err.Description
Exit Sub
End If
' informa lo spooler che un documento sara' stampato
' ritorna l'indicatore del job di stampa
ret = StartDocPrinter(hPrn, 1, di)
' informa lo spooler di una pagina in stampa
ret = StartPagePrinter(hPrn)
On Error GoTo err_open
'
' Open file and pump it to the printer.
'
hFile = FreeFile
Open sFile For Binary Access Read As hFile
'
' Read in 16K buffers and spool.
'
ReDim buffer(1 To BufSize) As Byte
LogOnFile 1, "SpoolFile.len file:" & LOF(hFile)
On Error GoTo err_rw
For i = 1 To LOF(hFile) \ BufSize
Get #hFile, , buffer
ret = WritePrinter(hPrn, buffer(1), BufSize, Written)
Next i
'
' Get last chunk of file if it doesn't
' fit evenly into a 16K buffer.
'
If LOF(hFile) Mod BufSize Then
ReDim buffer(1 To (LOF(hFile) Mod BufSize)) As Byte
Get #hFile, , buffer
ret = WritePrinter(hPrn, buffer(1), UBound(buffer), Written)
End If
Close #hFile
On Error GoTo err3
'
' Shut down spooling process.
'
ret = EndPagePrinter(hPrn)
ret = EndDocPrinter(hPrn)
ret = ClosePrinter(hPrn)
Exit Sub
err1:
LogOnFile 0, "SpoolFile.err1.spool(" & err.Number & "):" & err.Description
Exit Sub
err_open:
LogOnFile 0, "SpoolFile.err_open(" & sFile & ").spool(" & err.Number & "):" & err.Description
Exit Sub
err_rw:
LogOnFile 0, "SpoolFile.err_rw.spool(" & err.Number & "):" & err.Description
Exit Sub
err3:
LogOnFile 0, "SpoolFile.err3.spool(" & err.Number & "):" & err.Description
Exit Sub
End Sub
|
|
Get User Name via API
|
'*-------------------------------------------------------------*
'* Name : GetUserName *
'*-------------------------------------------------------------*
'* Purpose : Returns the current user name using a dll call *
'*-------------------------------------------------------------*
'* Description: Returns user name if found *
'*-------------------------------------------------------------*
Public Function GetUserName() As String
Dim sBuffer As String
Dim lSize As Long
' Space for dll parameters
sBuffer = Space$(255)
lSize = Len(sBuffer)
Call GetUserNameAPI(sBuffer, lSize)
If lSize > 0 Then
' Remove empty spaces
GetUserName = Left$(sBuffer, lSize)
Else
' Return empty if no user is found
GetUserName = vbNullString
End If
End Function
|
|
...
| |
| |