Голосование:
Голосования сайта VBNet.Ru. Результаты голосований передаются на сайт. Проследите, что есть соединение с интернетом.
Доска почёта:
Sergey Y. Tkachev
Кононенко Роман
Kirill
Ссылки:
Несколько слов от автора:
Новый выпуск.
Читайте!
Читайте!
Содержание выпуска
- Книги
- Получить количество заданий принтера
- Получить список доступных портов
- Вызвать окно "Форматирование: Диск А:"
- Формирование из числа его "строковое" представление
- Как показать песочные часы во время работы программы
- Перекодировка текста из DOS в Windows формат
- Вопрос/Ответ
Книги
Остальные книги о VB можно найти здесь.
наверх
Получить количество заданий принтера
Вам понадобится дополнительный модуль.
'КОД ФОРМЫ
Private Sub Command1_Click()
MsgBox "Количество запущенных заданий: " & GetPrinterQueue(Printer.DeviceName)
End Sub
'КОД МОДУЛЯ
Option Explicit
Public Const CCHDEVICENAME = 32
Public Const CCHFORMNAME = 32
Public Const PRINTER_ACCESS_ADMINISTER = &H4
Public Const PRINTER_ACCESS_USE = &H8
Public Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Public Type PRINTER_DEFAULTS
pDatatype As String
pDevMode As DEVMODE
DesiredAccess As Long
End Type
Public 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 Type JOB_INFO_1_API
JobId As Long
pPrinterName As Long
pMachineName As Long
pUserName As Long
pDocument As Long
pDatatype As Long
pStatus As Long
Status As Long
Priority As Long
Position As Long
TotalPages As Long
PagesPrinted As Long
Submitted As SYSTEMTIME
End Type
Public Type JOB_INFO_1
JobId As Long
pPrinterName As String
pMachineName As String
pUserName As String
pDocument As String
pDatatype As String
pStatus As String
Status As Long
Priority As Long
Position As Long
TotalPages As Long
PagesPrinted As Long
Submitted As SYSTEMTIME
End Type
Public Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, pDefault As PRINTER_DEFAULTS) As Long
Public Declare Function EnumJobs Lib "winspool.drv" Alias "EnumJobsA" (ByVal HPrinter As Long, ByVal FirstJob As Long, ByVal NoJobs As Long, ByVal Level As Long, ByVal pJob As Long, ByVal cdBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Private Declare Sub CopyMem Lib "kernel32.dll" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, ByVal lSize As Long)
Public Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function lstrlenW Lib "kernel32.dll" (ByVal lpString As Long) As Long
Private Declare Function HeapAlloc Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GetProcessHeap Lib "kernel32.dll" () As Long
Private Declare Function HeapFree Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Public JobsDesc(0 To 127) As JOB_INFO_1
Public Function TrimStr(strName As String) As String
'Finds a null then trims the string
Dim x As Integer
x = InStr(strName, vbNullChar)
If x > 0 Then TrimStr = Left(strName, x - 1) Else TrimStr = strName
End Function
Function LPSTRtoSTRING(ByVal lngPointer As Long) As String
Dim lngLength As Long
'Get number of characters in string
lngLength = lstrlenW(lngPointer) * 2
'Initialize string so we have something to copy the string into
LPSTRtoSTRING = String(lngLength, 0)
'Copy the string
CopyMem ByVal StrPtr(LPSTRtoSTRING), ByVal lngPointer, lngLength
'Convert to Unicode
LPSTRtoSTRING = TrimStr(StrConv(LPSTRtoSTRING, vbUnicode))
End Function
'Get the number of Jobs in the specified Printer Queue (max 128)... the PrinterName can be a network path: "\\MYSERVER\MYPRINTER"
Function GetPrinterQueue(PrinterName As String) As Long
Dim PrinterStruct As PRINTER_DEFAULTS
Dim HPrinter As Long
Dim ret As Boolean
Dim Jobs(0 To 127) As JOB_INFO_1_API
Dim pcbNeeded As Long
Dim pcReturned As Long
Dim i As Integer
Dim TempBuff As Long
'Initialize the Printer structure
PrinterStruct.pDatatype = vbNullString
PrinterStruct.pDevMode.dmSize = Len(PrinterStruct.pDevMode)
PrinterStruct.DesiredAccess = PRINTER_ACCESS_USE
'Get the printer Handle
ret = OpenPrinter(PrinterName, HPrinter, PrinterStruct)
'Get the Printer active jobs
ret = EnumJobs(HPrinter, 0, 127, 1, TempBuff, 0, pcbNeeded, pcReturned)
If pcbNeeded = 0 Then
GetPrinterQueue = 0
Else
'Allocate the Buffer
TempBuff = HeapAlloc(GetProcessHeap(), 0, pcbNeeded)
ret = EnumJobs(HPrinter, 0, 127, 1, TempBuff, pcbNeeded, pcbNeeded, pcReturned)
CopyMem Jobs(0), ByVal TempBuff, pcbNeeded
For i = 0 To pcReturned - 1
JobsDesc(i).pPrinterName = LPSTRtoSTRING(Jobs(i).pPrinterName)
JobsDesc(i).pMachineName = LPSTRtoSTRING(Jobs(i).pMachineName)
JobsDesc(i).pUserName = LPSTRtoSTRING(Jobs(i).pUserName)
JobsDesc(i).pDocument = LPSTRtoSTRING(Jobs(i).pDocument)
JobsDesc(i).pDatatype = LPSTRtoSTRING(Jobs(i).pDatatype)
JobsDesc(i).pStatus = LPSTRtoSTRING(Jobs(i).pStatus)
JobsDesc(i).JobId = Jobs(i).JobId
JobsDesc(i).Status = Jobs(i).Status
JobsDesc(i).Priority = Jobs(i).Priority
JobsDesc(i).Position = Jobs(i).Position
JobsDesc(i).TotalPages = Jobs(i).TotalPages
JobsDesc(i).PagesPrinted = Jobs(i).PagesPrinted
JobsDesc(i).Submitted = Jobs(i).Submitted
Next
If TempBuff Then HeapFree GetProcessHeap(), 0, TempBuff
GetPrinterQueue = pcReturned
End If
ret = CloseHandle(HPrinter)
End Function
наверх
Получить список доступных портов
Вам понадобится дополнительный модуль.
'КОД ФОРМЫ
Private Sub Command1_Click()
Dim NumPorts As Long
Dim i As Integer
NumPorts = GetAvailablePorts("")
List1.Clear
For i = 0 To NumPorts - 1
List1.AddItem Ports(i).pPortName
Next
End Sub
'КОД МОДУЛЯ
Option Explicit
Private Declare Function EnumPorts Lib "winspool.drv" Alias "EnumPortsA" (ByVal pName As String, ByVal Level As Long, ByVal lpbPorts As Long, ByVal cbBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Private Declare Function lstrlenW Lib "kernel32.dll" (ByVal lpString As Long) As Long
Private Declare Sub CopyMem Lib "kernel32.dll" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, ByVal lSize As Long)
Private Declare Function HeapAlloc Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GetProcessHeap Lib "kernel32.dll" () As Long
Private Declare Function HeapFree Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Private Type PORT_INFO_2
pPortName As String
pMonitorName As String
pDescription As String
fPortType As Long
Reserved As Long
End Type
Private Type API_PORT_INFO_2
pPortName As Long
pMonitorName As Long
pDescription As Long
fPortType As Long
Reserved As Long
End Type
Public Ports(0 To 100) As PORT_INFO_2
Public Function TrimStr(strName As String) As String
Dim x As Integer
x = InStr(strName, vbNullChar)
If x > 0 Then TrimStr = Left(strName, x - 1) Else TrimStr = strName
End Function
Public Function LPSTRtoSTRING(ByVal lngPointer As Long) As String
Dim lngLength As Long
'Get number of characters in string
lngLength = lstrlenW(lngPointer) * 2
'Initialize string so we have something to copy the string into
LPSTRtoSTRING = String(lngLength, 0)
'Copy the string
CopyMem ByVal StrPtr(LPSTRtoSTRING), ByVal lngPointer, lngLength
'Convert to Unicode
LPSTRtoSTRING = TrimStr(StrConv(LPSTRtoSTRING, vbUnicode))
End Function
'Use ServerName to specify the name of a Remote Workstation i.e. "//WIN95WKST"
'or leave it blank "" to get the ports of the local Machine
Public Function GetAvailablePorts(ServerName As String) As Long
Dim ret As Long
Dim PortsStruct(0 To 100) As API_PORT_INFO_2
Dim pcbNeeded As Long
Dim pcReturned As Long
Dim TempBuff As Long
Dim i As Integer
'Get the amount of bytes needed to contain the data returned by the API call
ret = EnumPorts(ServerName, 2, TempBuff, 0, pcbNeeded, pcReturned)
'Allocate the Buffer
TempBuff = HeapAlloc(GetProcessHeap(), 0, pcbNeeded)
ret = EnumPorts(ServerName, 2, TempBuff, pcbNeeded, pcbNeeded, pcReturned)
If ret Then
'Convert the returned String Pointer Values to VB String Type
CopyMem PortsStruct(0), ByVal TempBuff, pcbNeeded
For i = 0 To pcReturned - 1
Ports(i).pDescription = LPSTRtoSTRING(PortsStruct(i).pDescription)
Ports(i).pPortName = LPSTRtoSTRING(PortsStruct(i).pPortName)
Ports(i).pMonitorName = LPSTRtoSTRING(PortsStruct(i).pMonitorName)
Ports(i).fPortType = PortsStruct(i).fPortType
Next
End If
GetAvailablePorts = pcReturned
'Free the Heap Space allocated for the Buffer
If TempBuff Then HeapFree GetProcessHeap(), 0, TempBuff
End Function
наверх
Вызвать окно "Форматирование: Диск А:"
Private Declare Function SHFormatDrive Lib "shell32.dll" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long
Private Declare Function GetDriveType Lib "kernel32.dll" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Const DRIVE_CDROM = 5
Const DRIVE_FIXED = 3
Const DRIVE_RAMDISK = 6
Const DRIVE_REMOTE = 4
Const DRIVE_REMOVABLE = 2
Const SHFMT_ID_DEFAULT = &HFFFF ' Option bits for options parameter
Const SHFMT_OPT_FULL = 1
Const SHFMT_OPT_SYSONLY = 2
Public Sub FormatFloppy(hWndOwner As Long, ByVal DriveLetter As String)
Dim DriveNum As Long
Dim DriveType As Long
Dim ret As Long
DriveLetter = Left(DriveLetter, 1) & ":\"
' Преобразование имени диска в номер устройства: A=0, B=1...
DriveNum = Asc(UCase(DriveLetter)) - Asc("A")
DriveType = GetDriveType(DriveLetter)
' проверка, а флоппи ли это...
If DriveType = DRIVE_REMOVABLE Then
ret = SHFormatDrive(hWndOwner, DriveNum, SHFMT_ID_DEFAULT, SHFMT_OPT_FULL)
Else
MsgBox "Это не флоппи!", vbExclamation
End If
End Sub
Private Sub Command1_Click()
FormatFloppy Me.hwnd, "A"
End Sub
наверх
Формирование из числа его "строковое" представление
Многим из вас приходилось формировать из числа, содержащего количество секунд, строку, показывающую количество часов, минут и секунд. Для этого можно воспользоваться готовым примером.
Private Sub Command1_Click()
'Передаем функции 260 минут, получаем: 4 часа 20 минут
MsgBox FormatTime(260)
End Sub
'Формирует строку с указанием количества минут(часов, секунд)
Public Function FormatTime(lTime As Long) As String
Dim lSec As Long
Dim lMin As Long
Dim lHour As Long
Dim lTemp As Long
Dim i As Long
If lTime < 60 Then
FormatTime = lTime & " сек"
ElseIf lTime / 60 < 60 Then
lTemp = lTime
Do While lTemp > 60
i = i + 1
lTemp = lTemp - 60
Loop
lMin = i
lSec = lTime - (lMin * 60)
FormatTime = lMin & " мин " & lSec & " сек"
Else
lTemp = lTime
Do While lTemp > 60 * 60
i = i + 1
lTemp = lTemp - 60 * 60
Loop
lHour = i
i = 0
lTemp = lTime - (lHour * 60 * 60)
Do While lTemp > 60
i = i + 1
lTemp = lTemp - 60
Loop
lMin = i
lSec = lTime - (lHour * 60 * 60) - (lMin * 60)
FormatTime = lHour & " час " & lMin & " мин " & lSec & " сек"
End If
End Function
наверх
Как показать песочные часы во время работы программы
Если Вам необходимо сделать действие, во время которого пользователю не "рекомендуется" пользоваться мышью (например сделать расчеты), то лучше всего сменить курсор мыши на песочные часы. Используйте эту функцию и для восстановления вида курсора.
'Процедура служит для смены кусора на песочные часы
'и восстановления его после вторичного вызова
Public Sub HourGlass(obj As Object)
Static ordMouse As Integer
Static fOn As Boolean
On Error Resume Next
'если повторный вызов
If Not fOn Then
ordMouse = obj.MousePointer 'запомнить старый
obj.MousePointer = vbHourglass 'установить новый
fOn = True 'запомнить, что уже вызывали
Else 'Если нужно восстановить
obj.MousePointer = ordMouse 'восстановить курсор
fOn = False 'запомнить, что уже восстановили
End If
End Sub
Private Sub Command1_Click()
Call HourGlass(Form1)
End Sub
наверх
Перекодировка текста из DOS в Windows формат
Если Вам нужно конвертировать текст формата DOS в Windows (1251), то в API есть на этот случай хорошая функция: OemToChar.
Объявляется она так:
Public Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Используют её следующим образом:
Dim l_lReturn as Long
Dim l_sSource as String 'исходный текст
Dim l_sDestination as String 'возвращаемый текст
l_lReturn = oemtochar(l_sSource, l_sDestination)
Кроме этой полезной функции в API имеется и обратная её функция: CharToOem. Она служит для выполнения той же работы, только наоборот, т.е.Windows (1251) в DOS.
Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
наверх
Мои программы
BalloonMessage for MS Agent
Автора: Шатрыкин Иван и Павел Сурменок.
наверх
Вопрос/Ответ
Нет вопросов.
Ответы:
Нет ответов.
Можете заполнить эту форму, либо отослать вопрос СЮДА
Форма для добавления нового вопроса в этот раздел. Информация отсылается по E-mail владельцу сайта.
наверх
|
Переход на VB .NET. Стратегии, концепции, код (цена ~ 158 руб.) Эта книга была задумана как одна из первых книг о .NET, которая ознакомит читателя с основными идеями новой архитектуры и подготовит его к знакомству с более детальной литературой, например документацией Microsoft и ее толкованиями, которая неизбежно появится на рынке. Она поможет вам взглянуть на эту технологию с позиций ваших собственных рабочих планов и быстро освоить те концепции, которые покажутся необычными для большинства прогр... |
||
|
Автор(ы): Дан Эпплман, Издательство: Питер, 2002 г.
|
|||
|
Программирование на VB.NET. Учебный курс (цена ~ 119 руб.)
Эта книга является вводным курсом по
изучению языка программирования Visual Basic .NET.
Даны основные принципы объектно-ориентированного
программирования в контексте языка VB .NET,
поскольку без хорошей подготовки в этой
области невозможно в полной мере
пользоваться всеми преимуществами VB .NET. |
||
|
Автор(ы): Г. Корнелл, Дж. Моррисон, Издательство: Питер, 2002 г.
|
|||
|
VB.NET для разработчиков (цена ~ 125 руб.) Основная задача книги - быстро ознакомить разработчиков Visual Basic с изменениями в .NET Framework. Программисты, использующие Java, C++, Delphi или другие инструменты разработки приложений и интересующиеся Visual Basic или технологией .NET Framework, также найдут эту книгу полезной. Хотя книга посвящена Visual Basic.NET, ее основная цель - продемонстрировать взаимодействие Visual Basic и ... |
||
|
Автор(ы): Кит Франклин, Издательство: Вильямс, 2002 г.
|
|||
Остальные книги о VB можно найти здесь.
наверх
Получить количество заданий принтера
Вам понадобится дополнительный модуль.
'КОД ФОРМЫ
Private Sub Command1_Click()
MsgBox "Количество запущенных заданий: " & GetPrinterQueue(Printer.DeviceName)
End Sub
'КОД МОДУЛЯ
Option Explicit
Public Const CCHDEVICENAME = 32
Public Const CCHFORMNAME = 32
Public Const PRINTER_ACCESS_ADMINISTER = &H4
Public Const PRINTER_ACCESS_USE = &H8
Public Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Public Type PRINTER_DEFAULTS
pDatatype As String
pDevMode As DEVMODE
DesiredAccess As Long
End Type
Public 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 Type JOB_INFO_1_API
JobId As Long
pPrinterName As Long
pMachineName As Long
pUserName As Long
pDocument As Long
pDatatype As Long
pStatus As Long
Status As Long
Priority As Long
Position As Long
TotalPages As Long
PagesPrinted As Long
Submitted As SYSTEMTIME
End Type
Public Type JOB_INFO_1
JobId As Long
pPrinterName As String
pMachineName As String
pUserName As String
pDocument As String
pDatatype As String
pStatus As String
Status As Long
Priority As Long
Position As Long
TotalPages As Long
PagesPrinted As Long
Submitted As SYSTEMTIME
End Type
Public Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, pDefault As PRINTER_DEFAULTS) As Long
Public Declare Function EnumJobs Lib "winspool.drv" Alias "EnumJobsA" (ByVal HPrinter As Long, ByVal FirstJob As Long, ByVal NoJobs As Long, ByVal Level As Long, ByVal pJob As Long, ByVal cdBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Private Declare Sub CopyMem Lib "kernel32.dll" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, ByVal lSize As Long)
Public Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function lstrlenW Lib "kernel32.dll" (ByVal lpString As Long) As Long
Private Declare Function HeapAlloc Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GetProcessHeap Lib "kernel32.dll" () As Long
Private Declare Function HeapFree Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Public JobsDesc(0 To 127) As JOB_INFO_1
Public Function TrimStr(strName As String) As String
'Finds a null then trims the string
Dim x As Integer
x = InStr(strName, vbNullChar)
If x > 0 Then TrimStr = Left(strName, x - 1) Else TrimStr = strName
End Function
Function LPSTRtoSTRING(ByVal lngPointer As Long) As String
Dim lngLength As Long
'Get number of characters in string
lngLength = lstrlenW(lngPointer) * 2
'Initialize string so we have something to copy the string into
LPSTRtoSTRING = String(lngLength, 0)
'Copy the string
CopyMem ByVal StrPtr(LPSTRtoSTRING), ByVal lngPointer, lngLength
'Convert to Unicode
LPSTRtoSTRING = TrimStr(StrConv(LPSTRtoSTRING, vbUnicode))
End Function
'Get the number of Jobs in the specified Printer Queue (max 128)... the PrinterName can be a network path: "\\MYSERVER\MYPRINTER"
Function GetPrinterQueue(PrinterName As String) As Long
Dim PrinterStruct As PRINTER_DEFAULTS
Dim HPrinter As Long
Dim ret As Boolean
Dim Jobs(0 To 127) As JOB_INFO_1_API
Dim pcbNeeded As Long
Dim pcReturned As Long
Dim i As Integer
Dim TempBuff As Long
'Initialize the Printer structure
PrinterStruct.pDatatype = vbNullString
PrinterStruct.pDevMode.dmSize = Len(PrinterStruct.pDevMode)
PrinterStruct.DesiredAccess = PRINTER_ACCESS_USE
'Get the printer Handle
ret = OpenPrinter(PrinterName, HPrinter, PrinterStruct)
'Get the Printer active jobs
ret = EnumJobs(HPrinter, 0, 127, 1, TempBuff, 0, pcbNeeded, pcReturned)
If pcbNeeded = 0 Then
GetPrinterQueue = 0
Else
'Allocate the Buffer
TempBuff = HeapAlloc(GetProcessHeap(), 0, pcbNeeded)
ret = EnumJobs(HPrinter, 0, 127, 1, TempBuff, pcbNeeded, pcbNeeded, pcReturned)
CopyMem Jobs(0), ByVal TempBuff, pcbNeeded
For i = 0 To pcReturned - 1
JobsDesc(i).pPrinterName = LPSTRtoSTRING(Jobs(i).pPrinterName)
JobsDesc(i).pMachineName = LPSTRtoSTRING(Jobs(i).pMachineName)
JobsDesc(i).pUserName = LPSTRtoSTRING(Jobs(i).pUserName)
JobsDesc(i).pDocument = LPSTRtoSTRING(Jobs(i).pDocument)
JobsDesc(i).pDatatype = LPSTRtoSTRING(Jobs(i).pDatatype)
JobsDesc(i).pStatus = LPSTRtoSTRING(Jobs(i).pStatus)
JobsDesc(i).JobId = Jobs(i).JobId
JobsDesc(i).Status = Jobs(i).Status
JobsDesc(i).Priority = Jobs(i).Priority
JobsDesc(i).Position = Jobs(i).Position
JobsDesc(i).TotalPages = Jobs(i).TotalPages
JobsDesc(i).PagesPrinted = Jobs(i).PagesPrinted
JobsDesc(i).Submitted = Jobs(i).Submitted
Next
If TempBuff Then HeapFree GetProcessHeap(), 0, TempBuff
GetPrinterQueue = pcReturned
End If
ret = CloseHandle(HPrinter)
End Function
наверх
Получить список доступных портов
Вам понадобится дополнительный модуль.
'КОД ФОРМЫ
Private Sub Command1_Click()
Dim NumPorts As Long
Dim i As Integer
NumPorts = GetAvailablePorts("")
List1.Clear
For i = 0 To NumPorts - 1
List1.AddItem Ports(i).pPortName
Next
End Sub
'КОД МОДУЛЯ
Option Explicit
Private Declare Function EnumPorts Lib "winspool.drv" Alias "EnumPortsA" (ByVal pName As String, ByVal Level As Long, ByVal lpbPorts As Long, ByVal cbBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Private Declare Function lstrlenW Lib "kernel32.dll" (ByVal lpString As Long) As Long
Private Declare Sub CopyMem Lib "kernel32.dll" Alias "RtlMoveMemory" (pTo As Any, uFrom As Any, ByVal lSize As Long)
Private Declare Function HeapAlloc Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GetProcessHeap Lib "kernel32.dll" () As Long
Private Declare Function HeapFree Lib "kernel32.dll" (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Private Type PORT_INFO_2
pPortName As String
pMonitorName As String
pDescription As String
fPortType As Long
Reserved As Long
End Type
Private Type API_PORT_INFO_2
pPortName As Long
pMonitorName As Long
pDescription As Long
fPortType As Long
Reserved As Long
End Type
Public Ports(0 To 100) As PORT_INFO_2
Public Function TrimStr(strName As String) As String
Dim x As Integer
x = InStr(strName, vbNullChar)
If x > 0 Then TrimStr = Left(strName, x - 1) Else TrimStr = strName
End Function
Public Function LPSTRtoSTRING(ByVal lngPointer As Long) As String
Dim lngLength As Long
'Get number of characters in string
lngLength = lstrlenW(lngPointer) * 2
'Initialize string so we have something to copy the string into
LPSTRtoSTRING = String(lngLength, 0)
'Copy the string
CopyMem ByVal StrPtr(LPSTRtoSTRING), ByVal lngPointer, lngLength
'Convert to Unicode
LPSTRtoSTRING = TrimStr(StrConv(LPSTRtoSTRING, vbUnicode))
End Function
'Use ServerName to specify the name of a Remote Workstation i.e. "//WIN95WKST"
'or leave it blank "" to get the ports of the local Machine
Public Function GetAvailablePorts(ServerName As String) As Long
Dim ret As Long
Dim PortsStruct(0 To 100) As API_PORT_INFO_2
Dim pcbNeeded As Long
Dim pcReturned As Long
Dim TempBuff As Long
Dim i As Integer
'Get the amount of bytes needed to contain the data returned by the API call
ret = EnumPorts(ServerName, 2, TempBuff, 0, pcbNeeded, pcReturned)
'Allocate the Buffer
TempBuff = HeapAlloc(GetProcessHeap(), 0, pcbNeeded)
ret = EnumPorts(ServerName, 2, TempBuff, pcbNeeded, pcbNeeded, pcReturned)
If ret Then
'Convert the returned String Pointer Values to VB String Type
CopyMem PortsStruct(0), ByVal TempBuff, pcbNeeded
For i = 0 To pcReturned - 1
Ports(i).pDescription = LPSTRtoSTRING(PortsStruct(i).pDescription)
Ports(i).pPortName = LPSTRtoSTRING(PortsStruct(i).pPortName)
Ports(i).pMonitorName = LPSTRtoSTRING(PortsStruct(i).pMonitorName)
Ports(i).fPortType = PortsStruct(i).fPortType
Next
End If
GetAvailablePorts = pcReturned
'Free the Heap Space allocated for the Buffer
If TempBuff Then HeapFree GetProcessHeap(), 0, TempBuff
End Function
наверх
Вызвать окно "Форматирование: Диск А:"
Private Declare Function SHFormatDrive Lib "shell32.dll" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long
Private Declare Function GetDriveType Lib "kernel32.dll" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Const DRIVE_CDROM = 5
Const DRIVE_FIXED = 3
Const DRIVE_RAMDISK = 6
Const DRIVE_REMOTE = 4
Const DRIVE_REMOVABLE = 2
Const SHFMT_ID_DEFAULT = &HFFFF ' Option bits for options parameter
Const SHFMT_OPT_FULL = 1
Const SHFMT_OPT_SYSONLY = 2
Public Sub FormatFloppy(hWndOwner As Long, ByVal DriveLetter As String)
Dim DriveNum As Long
Dim DriveType As Long
Dim ret As Long
DriveLetter = Left(DriveLetter, 1) & ":\"
' Преобразование имени диска в номер устройства: A=0, B=1...
DriveNum = Asc(UCase(DriveLetter)) - Asc("A")
DriveType = GetDriveType(DriveLetter)
' проверка, а флоппи ли это...
If DriveType = DRIVE_REMOVABLE Then
ret = SHFormatDrive(hWndOwner, DriveNum, SHFMT_ID_DEFAULT, SHFMT_OPT_FULL)
Else
MsgBox "Это не флоппи!", vbExclamation
End If
End Sub
Private Sub Command1_Click()
FormatFloppy Me.hwnd, "A"
End Sub
наверх
Формирование из числа его "строковое" представление
Многим из вас приходилось формировать из числа, содержащего количество секунд, строку, показывающую количество часов, минут и секунд. Для этого можно воспользоваться готовым примером.
Private Sub Command1_Click()
'Передаем функции 260 минут, получаем: 4 часа 20 минут
MsgBox FormatTime(260)
End Sub
'Формирует строку с указанием количества минут(часов, секунд)
Public Function FormatTime(lTime As Long) As String
Dim lSec As Long
Dim lMin As Long
Dim lHour As Long
Dim lTemp As Long
Dim i As Long
If lTime < 60 Then
FormatTime = lTime & " сек"
ElseIf lTime / 60 < 60 Then
lTemp = lTime
Do While lTemp > 60
i = i + 1
lTemp = lTemp - 60
Loop
lMin = i
lSec = lTime - (lMin * 60)
FormatTime = lMin & " мин " & lSec & " сек"
Else
lTemp = lTime
Do While lTemp > 60 * 60
i = i + 1
lTemp = lTemp - 60 * 60
Loop
lHour = i
i = 0
lTemp = lTime - (lHour * 60 * 60)
Do While lTemp > 60
i = i + 1
lTemp = lTemp - 60
Loop
lMin = i
lSec = lTime - (lHour * 60 * 60) - (lMin * 60)
FormatTime = lHour & " час " & lMin & " мин " & lSec & " сек"
End If
End Function
наверх
Как показать песочные часы во время работы программы
Если Вам необходимо сделать действие, во время которого пользователю не "рекомендуется" пользоваться мышью (например сделать расчеты), то лучше всего сменить курсор мыши на песочные часы. Используйте эту функцию и для восстановления вида курсора.
'Процедура служит для смены кусора на песочные часы
'и восстановления его после вторичного вызова
Public Sub HourGlass(obj As Object)
Static ordMouse As Integer
Static fOn As Boolean
On Error Resume Next
'если повторный вызов
If Not fOn Then
ordMouse = obj.MousePointer 'запомнить старый
obj.MousePointer = vbHourglass 'установить новый
fOn = True 'запомнить, что уже вызывали
Else 'Если нужно восстановить
obj.MousePointer = ordMouse 'восстановить курсор
fOn = False 'запомнить, что уже восстановили
End If
End Sub
Private Sub Command1_Click()
Call HourGlass(Form1)
End Sub
наверх
Перекодировка текста из DOS в Windows формат
Если Вам нужно конвертировать текст формата DOS в Windows (1251), то в API есть на этот случай хорошая функция: OemToChar.
Объявляется она так:
Public Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Используют её следующим образом:
Dim l_lReturn as Long
Dim l_sSource as String 'исходный текст
Dim l_sDestination as String 'возвращаемый текст
l_lReturn = oemtochar(l_sSource, l_sDestination)
Кроме этой полезной функции в API имеется и обратная её функция: CharToOem. Она служит для выполнения той же работы, только наоборот, т.е.Windows (1251) в DOS.
Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
наверх
Мои программы
BalloonMessage for MS Agent
BalloonMessage for Microsoft Agent реализует диалог программы с
пользователем, используя при этом технологию Microsoft Agent. OCX реализует три
типа диалоговых окон: InputBox, MsgBox и MsgLabels.
Автора: Шатрыкин Иван и Павел Сурменок.
наверх
Вопрос/Ответ
Здесь Вы можете задать вопрос, или ответить на уже имеющиеся вопросы.
Вопросы:Нет вопросов.
Ответы:
Нет ответов.
Можете заполнить эту форму, либо отослать вопрос СЮДА
Форма для добавления нового вопроса в этот раздел. Информация отсылается по E-mail владельцу сайта.