Завтра у меня день рождения! Поздравления принимаются.
Читайте!

Книги

		Переход на VB .NET. Стратегии, концепции, код (цена ~ 158 руб.) Эта книга была задумана как одна из первых книг о .NET, которая ознакомит читателя с основными идеями новой архитектуры и подготовит его к знакомству с более детальной литературой, например документацией Microsoft и ее толкованиями, которая неизбежно появится на рынке. Она поможет вам взглянуть на эту технологию с позиций ваших собственных рабочих планов и быстро освоить те концепции, которые покажутся необычными для большинства прогр...
		Автор(ы): Дан Эпплман, Издательство: Питер, 2002 г.
		Программирование на VB.NET. Учебный курс (цена ~ 119 руб.) Эта книга является вводным курсом по изучению языка программирования Visual Basic .NET. Даны основные принципы объектно-ориентированного программирования в контексте языка VB .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 можно найти здесь.

наверх

---

VBNet CD 04 2003

   VBNet.RU представляет новый компакт диск "VBNet CD 04 2003". Диск был существенно переработан. Добавлено около 200 мб новой информации и софта.
   Добавлены новые разделы:

• Эксклюзив - Здесь публикуются примеры и статьи, которые Вы не увидите нигде, кроме этого CD и моего копьютера... Ну в мой комп вряд ли кто-нибудь полезет, значит эти материалы есть только на этом CD! На данном компакт-диске находится 3 статьи ("Обзор ADO .NET", "Обзор ASP .NET", "Массивы и коллекции в Visual Basic .NET") и 5 примеров с большим количеством комментариев на русском языке (использование ADO .NET, отправка почты в VB .NET средствами CDO, отправка почты в VB .NET прямым взаимодействием с SMTP-сервером, использование технологии MS Agent в VB .NET и преобразование цветов в разные системы (RGB, YUV, YIQ, CMY, CMYK)).
• Примеры - разнообразные примеры от простейших (использование массивов) до 3-мегобайтных коммерческих приложений с исходниками на VB.

   Раздел "Книги" пополнился книгой Андрея Гончарова "Мышление в стиле Visual Basic" в формате pdf.
   Большие изменения в разделе "Софт". Добавлены несколько патчей и исправлений для VS .NET. Также добавлены инструменты для создания приложений для мобильных утсройств.
   В раздел "ActiveX" добавлено 15 бесплатных компонентов и библиотек.

   Полное содержание диска Вы можете скачать здесь.

   Диск распространяется по почте наложенным платежом.
   Цена: 60 рублей + 40 рублей (за почтовые расходы) = 100 рублей. Действует система скидок для постоянных клиентов.
   Заказать диск можно здесь.



наверх

---

Работа с CommonDialog без ocx: ShowColor/ShowPrinter

Данный пример (у меня на компе) реагирует только на два события:

Call ShowColor
Call ShowPrinter

Поэтому этот пример является далеко не полным.

Option Explicit

'API function called by ChooseColor method
Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As ChooseColor) As Long
'API function called by ChooseFont method
Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONT) As Long
'API function inside ShowHelp method
Private Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hWnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long
'API function called by ShowOpen method
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OpenFilename) As Long
'API function called by ShowSave method
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OpenFilename) As Long
'API function called by ShowPrint method
Private Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PrintDlg) As Long
'API function to retrieve extended error information
Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
'API memory functions
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

'constants for API memory functions
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

Public Enum ColorDlgFlags
CC_RGBINIT = &H1
CC_FULLOPEN = &H2
CC_PREVENTFULLOPEN = &H4
CC_SHOWHELP = &H8
CC_ENABLEHOOK = &H10
CC_ENABLETEMPLATE = &H20
CC_ENABLETEMPLATEHANDLE = &H40
CC_SOLIDCOLOR = &H80
CC_ANYCOLOR = &H100
End Enum

'data buffer for the ChooseColor function
Private Type ChooseColor
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As Long
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

'constants for LOGFONT
Private Const LF_FACESIZE = 32
Private Const LF_FULLFACESIZE = 64
Private Const FW_BOLD = 700

'data buffer for the ChooseFont function
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type

'data buffer for the ChooseFont function
Private Type CHOOSEFONT
lStructSize As Long
hwndOwner As Long
hdc As Long
lpLogFont As Long
iPointSize As Long
flags As Long
rgbColors As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
hInstance As Long
lpszStyle As String
nFontType As Integer
MISSING_ALIGNMENT As Integer
nSizeMin As Long
nSizeMax As Long
End Type

'data buffer for the GetOpenFileName and GetSaveFileName functions
Private Type OpenFilename
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
iFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

'data buffer for the PrintDlg function
Private Type PrintDlg
lStructSize As Long
hwndOwner As Long
hDevMode As Long
hDevNames As Long
hdc As Long
flags As Long
nFromPage As Integer
nToPage As Integer
nMinPage As Integer
nMaxPage As Integer
nCopies As Integer
hInstance As Long
lCustData As Long
lpfnPrintHook As Long
lpfnSetupHook As Long
lpPrintTemplateName As String
lpSetupTemplateName As String
hPrintTemplate As Long
hSetupTemplate As Long
End Type

'internal property buffers

Private iAction As Integer 'internal buffer for Action property
Private bCancelError As Boolean 'internal buffer for CancelError property
Private lColor As Long 'internal buffer for Color property
Private lCopies As Long 'internal buffer for lCopies property
Private sDefaultExt As String 'internal buffer for sDefaultExt property
Private sDialogTitle As String 'internal buffer for DialogTitle property
Private sFileName As String 'internal buffer for FileName property
Private sFileTitle As String 'internal buffer for FileTitle property
Private sFilter As String 'internal buffer for Filter property
Private iFilterIndex As Integer 'internal buffer for FilterIndex property
Private lFlags As Long 'internal buffer for Flags property
Private bFontBold As Boolean 'internal buffer for FontBold property
Private bFontItalic As Boolean 'internal buffer for FontItalic property
Private sFontName As String 'internal buffer for FontName property
Private lFontSize As Long 'internal buffer for FontSize property
Private bFontStrikethru As Boolean 'internal buffer for FontStrikethru property
Private bFontUnderline As Boolean 'internal buffer for FontUnderline property
Private lFromPage As Long 'internal buffer for FromPage property
Private lhdc As Long 'internal buffer for hdc property
Private lHelpCommand As Long 'internal buffer for HelpCommand property
Private sHelpContext As String 'internal buffer for HelpContext property
Private sHelpFile As String 'internal buffer for HelpFile property
Private sHelpKey As String 'internal buffer for HelpKey property
Private sInitDir As String 'internal buffer for InitDir property
Private lMax As Long 'internal buffer for Max property
Private lMaxFileSize As Long 'internal buffer for MaxFileSize property
Private lMin As Long 'internal buffer for Min property
Private objObject As Object 'internal buffer for Object property
Private iPrinterDefault As Integer 'internal buffer for PrinterDefault property
Private lToPage As Long 'internal buffer for ToPage property

Private lApiReturn As Long 'internal buffer for APIReturn property
Private lExtendedError As Long 'internal buffer for ExtendedError property

'constants for color dialog
Private Const CDERR_DIALOGFAILURE = &HFFFF
Private Const CDERR_FINDRESFAILURE = &H6
Private Const CDERR_GENERALCODES = &H0
Private Const CDERR_INITIALIZATION = &H2
Private Const CDERR_LOADRESFAILURE = &H7
Private Const CDERR_LOADSTRFAILURE = &H5
Private Const CDERR_LOCKRESFAILURE = &H8
Private Const CDERR_MEMALLOCFAILURE = &H9
Private Const CDERR_MEMLOCKFAILURE = &HA
Private Const CDERR_NOHINSTANCE = &H4
Private Const CDERR_NOHOOK = &HB
Private Const CDERR_NOTEMPLATE = &H3
Private Const CDERR_REGISTERMSGFAIL = &HC
Private Const CDERR_STRUCTSIZE = &H1

'constants for file dialog

Private Const FNERR_BUFFERTOOSMALL = &H3003
Private Const FNERR_FILENAMECODES = &H3000
Private Const FNERR_INVALIDFILENAME = &H3002
Private Const FNERR_SUBCLASSFAILURE = &H3001

Public Sub ShowColor()
'display the color dialog box
Dim tChooseColor As ChooseColor
Dim alCustomColors(15) As Long
Dim lCustomColorSize As Long
Dim lCustomColorAddress As Long
Dim lMemHandle As Long

Dim n As Integer

On Error GoTo ShowColorError

'*** init property buffers
iAction = 3 'Action property - ShowColor
lApiReturn = 0 'APIReturn property
lExtendedError = 0 'ExtendedError property
'*** prepare tChooseColor data
'lStructSize As Long
tChooseColor.lStructSize = Len(tChooseColor)
'hwndOwner As Long
tChooseColor.hwndOwner = lhdc
'hInstance As Long
'rgbResult As Long
tChooseColor.rgbResult = lColor
'lpCustColors As Long
' Fill custom colors array with all white
For n = 0 To UBound(alCustomColors)
alCustomColors(n) = &HFFFFFF
Next
' Get size of memory needed for custom colors
lCustomColorSize = Len(alCustomColors(0)) * 16
' Get a global memory block to hold a copy of the custom colors
lMemHandle = GlobalAlloc(GHND, lCustomColorSize)
If lMemHandle = 0 Then
Exit Sub
End If
' Lock the custom color's global memory block
lCustomColorAddress = GlobalLock(lMemHandle)
If lCustomColorAddress = 0 Then
Exit Sub
End If
' Copy custom colors to the global memory block
Call CopyMemory(ByVal lCustomColorAddress, alCustomColors(0), lCustomColorSize)
tChooseColor.lpCustColors = lCustomColorAddress
'flags As Long
tChooseColor.flags = lFlags
'lCustData As Long
'lpfnHook As Long
'lpTemplateName As String
'*** call the ChooseColor API function
lApiReturn = ChooseColor(tChooseColor)
'*** handle return from ChooseColor API function
Select Case lApiReturn
Case 0 'user canceled
If bCancelError = True Then
'generate an error
On Error GoTo 0
Err.Raise Number:=vbObjectError + 894, Description:="Cancel Pressed"
Exit Sub
End If
Case 1 'user selected a color
'update property buffer
lColor = tChooseColor.rgbResult
Case Else 'an error occured
'call CommDlgExtendedError
lExtendedError = CommDlgExtendedError
End Select
Exit Sub

ShowColorError:
Exit Sub
End Sub

Public Sub ShowFont()
'display the font dialog box
Dim tLogFont As LOGFONT
Dim tChooseFont As CHOOSEFONT
Dim lLogFontSize As Long
Dim lLogFontAddress As Long
Dim lMemHandle As Long
Dim lReturn As Long
Dim sFont As String
Dim lBytePoint As Long
On Error GoTo ShowFontError

'*** init property buffers
iAction = 4 'Action property - ShowFont
lApiReturn = 0 'APIReturn property
lExtendedError = 0 'ExtendedError property
'*** prepare tChooseFont data
'tLogFont.lfHeight As Long
'tLogFont.lfWidth As Long
'tLogFont.lfEscapement As Long
'tLogFont.lfOrientation As Long
'tLogFont.lfWeight As Long - init from FontBold property
If bFontBold = True Then
tLogFont.lfWeight = FW_BOLD
End If
'tLogFont.lfItalic As Byte - init from FontItalic property
If bFontItalic = True Then
tLogFont.lfItalic = 1
End If
'tLogFont.lfUnderline As Byte - init from FontUnderline property
If bFontUnderline = True Then
tLogFont.lfUnderline = 1
End If
'tLogFont.lfStrikeOut As Byte - init from FontStrikethru property
If bFontStrikethru = True Then
tLogFont.lfStrikeOut = 1
End If
'tLogFont.lfCharSet As Byte
'tLogFont.lfOutPrecision As Byte
'tLogFont.lfClipPrecision As Byte
'tLogFont.lfQuality As Byte
'tLogFont.lfPitchAndFamily As Byte
'tLogFont.lfFaceName(LF_FACESIZE) As Byte
'tChooseFont.lStructSize As Long
tChooseFont.lStructSize = Len(tChooseFont)
'tChooseFont.hwndOwner As Long
'tChooseFont.hdc As Long
'tChooseFont.lpLogFont As Long
lLogFontSize = Len(tLogFont)
' Get a global memory block to hold a copy of tLogFont - exit on failure
lMemHandle = GlobalAlloc(GHND, lLogFontSize)
If lMemHandle = 0 Then
Exit Sub
End If
' Lock tLogFont's global memory block - exit on failure
lLogFontAddress = GlobalLock(lMemHandle)
If lLogFontAddress = 0 Then
Exit Sub
End If
' Copy tLogFont to the global memory block
Call CopyMemory(ByVal lLogFontAddress, tLogFont, lLogFontSize)
tChooseFont.lpLogFont = lLogFontAddress
'tChooseFont.iPointSize As Long - init from FontSize property
tChooseFont.iPointSize = lFontSize * 10
'tChooseFont.flags As Long - init from Flags property
tChooseFont.flags = lFlags
'tChooseFont.rgbColors As Long
'tChooseFont.lCustData As Long
'tChooseFont.lpfnHook As Long
'tChooseFont.lpTemplateName As String
'tChooseFont.hInstance As Long
'tChooseFont.lpszStyle As String
'sFont = Chr$(0) & Space$(20) & Chr$(0)
'tChooseFont.lpszStyle = sFont
'tChooseFont.nFontType As Integer
'tChooseFont.MISSING_ALIGNMENT As Integer
'tChooseFont.nSizeMin As Long
'tChooseFont.nSizeMax As Long
'*** call the CHOOSEFONT API function
lApiReturn = CHOOSEFONT(tChooseFont) 'store to APIReturn property
'*** handle return from CHOOSEFONT API function
Select Case lApiReturn
Case 0 'user canceled
If bCancelError = True Then
'generate an error
Err.Raise (2001)
Exit Sub
End If

Case 1 'user selected a font
' Copy global memory block to tLogFont
Call CopyMemory(tLogFont, ByVal lLogFontAddress, lLogFontSize)
'tLogFont.lfWeight As Long - store to FontBold property
If tLogFont.lfWeight >= FW_BOLD Then
bFontBold = True
Else
bFontBold = False
End If
'tLogFont.lfItalic As Byte - store to FontItalic property
If tLogFont.lfItalic = 1 Then
bFontItalic = True
Else
bFontItalic = False
End If
'tLogFont.lfUnderline As Byte - store to FontUnderline property
If tLogFont.lfUnderline = 1 Then
bFontUnderline = True
Else
bFontUnderline = False
End If

'tLogFont.lfStrikeOut As Byte - store to FontStrikethru property
If tLogFont.lfStrikeOut = 1 Then
bFontStrikethru = True
Else
bFontStrikethru = False
End If

'tLogFont.lfFaceName(LF_FACESIZE) As Byte - store to FontName property
FontName = sByteArrayToString(tLogFont.lfFaceName())

'tChooseFont.iPointSize As Long - store to FontSize property
lFontSize = CLng(tChooseFont.iPointSize / 10)

Case Else 'an error occured
'call CommDlgExtendedError
lExtendedError = CommDlgExtendedError 'store to ExtendedError property

End Select

Exit Sub

ShowFontError:
Exit Sub
End Sub

Public Sub ShowHelp()
'run winhelp.exe with the specified help file
Dim sHelpFileBuff As String
Dim lData As Long

On Error GoTo ShowHelpError

'*** init Private properties
iAction = 6 'Action property - ShowHelp
lApiReturn = 0 'APIReturn property
lExtendedError = 0 'ExtendedError property

'*** prepare the buffers and parameters for the API function
'sHelpFile is a null terminated string
sHelpFileBuff = sHelpFile & Chr$(0)

'sData is dependent on lHelpCommand
Select Case lHelpCommand
Case 0
lData = 0
Case Else
lData = 0
End Select

'*** call the API function
lApiReturn = WinHelp(lhdc, sHelpFile, lHelpCommand, lData) ' - Store to APIReturn property

Select Case lApiReturn
Case 0 '
'call CommDlgExtendedError
lExtendedError = CommDlgExtendedError ' - store to ExtendedError property

Case Else '
'call CommDlgExtendedError
lExtendedError = CommDlgExtendedError

End Select

Exit Sub

ShowHelpError:
Exit Sub
End Sub

Public Sub ShowOpen()
'display the file open dialog box
ShowFileDialog (1) 'Action property - ShowOpen
End Sub

Public Sub ShowPrinter()
'display the print dialog
Dim tPrintDlg As PrintDlg

On Error GoTo ShowPrinterError

'*** init public properties
iAction = 5 'Action property - ShowPrint
lApiReturn = 0 'APIReturn property
lExtendedError = 0 'ExtendedError property

'*** prepare tPrintDlg data

'lStructSize As Long
tPrintDlg.lStructSize = Len(tPrintDlg)

'hwndOwner As Long

'hDevMode As Long

'hDevNames As Long

'hdc As Long - init from hDC property
tPrintDlg.hdc = lhdc

'flags As Long - init from Flags property
tPrintDlg.flags = lFlags

'nFromPage As Integer - init from FromPage property
tPrintDlg.nFromPage = lFromPage

'nToPage As Integer - init from ToPage property
tPrintDlg.nToPage = lToPage

'nMinPage As Integer - init from Min property
tPrintDlg.nMinPage = lMin

'nMaxPage As Integer - init from Max property
tPrintDlg.nMaxPage = lMax

'nCopies As Integer - init from Copies property
tPrintDlg.nCopies = lCopies

'hInstance As Long

'lCustData As Long

'*** Call the PrintDlg API function
lApiReturn = PrintDlg(tPrintDlg)

'*** handle return from PrintDlg API function
Select Case lApiReturn

Case 0 'user canceled
If bCancelError = True Then
'generate an error
Err.Raise (2001)
Exit Sub
End If

Case 1 'user selected OK
'nFromPage As Integer - store to FromPage property
lFromPage = tPrintDlg.nFromPage

'nToPage As Integer - store to ToPage property
lToPage = tPrintDlg.nToPage

'nMinPage As Integer - store to Min property
lMin = tPrintDlg.nMinPage

'nMaxPage As Integer - store to Max property
lMax = tPrintDlg.nMaxPage

'nCopies As Integer - store to Copies property
lCopies = tPrintDlg.nCopies

Case Else 'an error occured
'call CommDlgExtendedError
lExtendedError = CommDlgExtendedError 'store to ExtendedError property

End Select

Exit Sub

ShowPrinterError:
Exit Sub
End Sub

Public Sub ShowSave()
'display the file save dialog box
ShowFileDialog (2) 'Action property - ShowSave
End Sub

Private Function sLeftOfNull(ByVal sIn As String)
'returns the part of sIn preceding Chr$(0)
Dim lNullPos As Long

'init output
sLeftOfNull = sIn

'get position of first Chr$(0) in sIn
lNullPos = InStr(sIn, Chr$(0))

'return part of sIn to left of first Chr$(0) if found
If lNullPos > 0 Then
sLeftOfNull = Mid$(sIn, 1, lNullPos - 1)
End If
End Function


Private Function sAPIFilter(sIn)
'prepares sIn for use as a filter string in API common dialog functions
Dim lChrNdx As Long
Dim sOneChr As String
Dim sOutStr As String

'convert any | characters to nulls
For lChrNdx = 1 To Len(sIn)
sOneChr = Mid$(sIn, lChrNdx, 1)
If sOneChr = "|" Then
sOutStr = sOutStr & Chr$(0)
Else
sOutStr = sOutStr & sOneChr
End If
Next

'add a null to the end
sOutStr = sOutStr & Chr$(0)

'return sOutStr
sAPIFilter = sOutStr

End Function


Private Function sByteArrayToString(abBytes() As Byte) As String
'return a string from a byte array
Dim lBytePoint As Long
Dim lByteVal As Long
Dim sOut As String

'init array pointer
lBytePoint = LBound(abBytes)

'fill sOut with characters in array
While lBytePoint
lByteVal = abBytes(lBytePoint)

'return sOut and stop if Chr$(0) is encountered
If lByteVal = 0 Then
sByteArrayToString = sOut
Exit Function
Else
sOut = sOut & Chr$(lByteVal)
End If

lBytePoint = lBytePoint + 1
Wend

'return sOut if Chr$(0) wasn't encountered
sByteArrayToString = sOut
End Function

Private Sub ShowFileDialog(ByVal iAction As Integer)
'display the file dialog for ShowOpen or ShowSave

Dim tOpenFile As OpenFilename
Dim lMaxSize As Long
Dim sFileNameBuff As String
Dim sFileTitleBuff As String

On Error GoTo ShowFileDialogError

'*** init property buffers

iAction = iAction 'Action property
lApiReturn = 0 'APIReturn property
lExtendedError = 0 'ExtendedError property

'*** prepare tOpenFile data

'tOpenFile.lStructSize As Long
tOpenFile.lStructSize = Len(tOpenFile)

'tOpenFile.hWndOwner As Long - init from hdc property
tOpenFile.hwndOwner = lhdc

'tOpenFile.lpstrFilter As String - init from Filter property
tOpenFile.lpstrFilter = sAPIFilter(sFilter)

'tOpenFile.iFilterIndex As Long - init from FilterIndex property
tOpenFile.iFilterIndex = iFilterIndex

'tOpenFile.lpstrFile As String
'determine size of buffer from MaxFileSize property
If lMaxFileSize > 0 Then
lMaxSize = lMaxFileSize
Else
lMaxSize = 255
End If

'tOpenFile.lpstrFile As Long - init from FileName property
'prepare sFileNameBuff
sFileNameBuff = sFileName
'pad with spaces
While Len(sFileNameBuff)
sFileNameBuff = sFileNameBuff & " "
Wend
'trim to length of lMaxFileSize - 1
sFileNameBuff = Mid$(sFileNameBuff, 1, lMaxFileSize - 1)
'null terminate
sFileNameBuff = sFileNameBuff & Chr$(0)
tOpenFile.lpstrFile = sFileNameBuff

'nMaxFile As Long - init from MaxFileSize property
If lMaxFileSize = 255 Then 'default is 255
tOpenFile.nMaxFile = lMaxFileSize
End If

'lpstrFileTitle As String - init from FileTitle property
'prepare sFileTitleBuff
sFileTitleBuff = sFileTitle
'pad with spaces
While Len(sFileTitleBuff)
sFileTitleBuff = sFileTitleBuff & " "
Wend
'trim to length of lMaxFileSize - 1
sFileTitleBuff = Mid$(sFileTitleBuff, 1, lMaxFileSize - 1)
'null terminate
sFileTitleBuff = sFileTitleBuff & Chr$(0)
tOpenFile.lpstrFileTitle = sFileTitleBuff
'tOpenFile.lpstrInitialDir As String - init from InitDir property
tOpenFile.lpstrInitialDir = sInitDir
'tOpenFile.lpstrTitle As String - init from DialogTitle property
tOpenFile.lpstrTitle = sDialogTitle
'tOpenFile.flags As Long - init from Flags property
tOpenFile.flags = lFlags
'tOpenFile.lpstrDefExt As String - init from DefaultExt property
tOpenFile.lpstrDefExt = sDefaultExt

'*** call the GetOpenFileName API function
Select Case iAction
Case 1 'ShowOpen
lApiReturn = GetOpenFileName(tOpenFile)
Case 2 'ShowSave
lApiReturn = GetSaveFileName(tOpenFile)
Case Else 'unknown action
Exit Sub
End Select
'*** handle return from GetOpenFileName API function
Select Case lApiReturn
Case 0 'user canceled
If bCancelError = True Then
'generate an error
Err.Raise (2001)
Exit Sub
End If
Case 1 'user selected or entered a file
'sFileName gets part of tOpenFile.lpstrFile to the left of first Chr$(0)
sFileName = sLeftOfNull(tOpenFile.lpstrFile)
sFileTitle = sLeftOfNull(tOpenFile.lpstrFileTitle)
Case Else 'an error occured
'call CommDlgExtendedError
lExtendedError = CommDlgExtendedError
End Select
Exit Sub

ShowFileDialogError:
Exit Sub
End Sub

Private Sub Command1_Click()
Call ShowColor
Call ShowPrinter
'Call ShowFont
'Call ShowHelp
'Call ShowOpen
'Call ShowSave
End Sub

наверх

---

windows: Возвращение глубины цвета

Функция возвращает глубину цвета - 8, 16, 24 или 32

Private Const PLANES& = 14
Private Const BITSPIXEL& = 12
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Function ColorDepth() As Integer
Dim intPlanes As Integer
Dim intBitsPerPixel As Integer
Dim lngDC As Long
lngDC = GetDC(0)
intPlanes = GetDeviceCaps(lngDC, PLANES)
intBitsPerPixel = GetDeviceCaps(lngDC, BITSPIXEL)
ReleaseDC 0, lngDC
ColorDepth = intPlanes * intBitsPerPixel
End Function

Private Sub Form_Load()
Dim intColorDepth As Integer
intColorDepth = ColorDepth
MsgBox intColorDepth
End Sub

наверх

---

Определить текущее разрешение экрана

Private Sub Form_Load()
Dim intWidth As Integer
Dim intHeight As Integer
intWidth = Screen.Width \ Screen.TwipsPerPixelX
intHeight = Screen.Height \ Screen.TwipsPerPixelY
MsgBox "Screen Resolution:" + vbCrLf + vbCrLf + Str$(intWidth) + " x" + Str$(intHeight), 64, "Info"
End Sub

наверх

---

Изменение набора изображений в элементе управления ImageList

В режиме разработки проекта вам может пригодиться возможность свободно добавлять изображения в элемент управления ImageList, связанный с элементом управления Toolbar, или удалять их оттуда. И поскольку VB не позволяет изменять набор изображений в ImageList, пока он связан с панелью инструментов, мы покажем вам способ, как обойти данное ограничение

Шаг 1. Заполнение элемента управления ImageList.Поместите элемент управления ImageList на форму.(Если данный компонент не входит в комплект инструментальных средств вашего проекта, то его можно добавить так, как показано в Совете 187.) Щелкните по нему правой кнопкой мыши, а затем выберите команду Properties для открытия диалогового окна Property Pages. Выберите вкладку Images и щелкните кнопку Insert Picture. В диалоговом окне Select Picture найдите изображение, которое хотите добавить в элемент управления ImageList. Присвойте ему уникальное свойство Key. Повторите эти операции, пока не заполните элемент управления ImageList так, как вам хочется.

Шаг 2. Добавление кнопок к панели инструментов.Щелкните правой кнопкой мыши элемент управления Toolbar и затем выберите команду Properties. В раскрывшемся диалоговом окне Property Pages выберите вкладку Buttons. Щелкните кнопку Insert Button и в текстовом поле Key введите уникальное имя, присвоенное изображению в элементе управления ImageList. Каждая кнопка с изображением должна иметь то же свойство Key, что и соответствующее изображение в компоненте ImageList. Каждая кнопка без изображения, например tbrSeparator или tbrPlaceholder, не должна иметь свойства Key.

Шаг 3. В событии Load для формы установите связь элементов управления ImageList и Toolbar:

Set ToolBar1.ImageList = ImageList1

Шаг 4. Присвойте изображения кнопкам на панели инструментов:

Dim myButton as Variant
For Each myButton in ToolBar1.Buttons
If myButton.Key <> Empty Then
myButton.Image = myButton.Key
' если значение свойство Key имеет
' какой-либо смысл, используйте его
' для описания и текста подсказки
myButton.Description = myButton.Key
myButton.ToolTipText = myButton.Key
End If
Next

(Источник: Компьютер-пресс'1999)

наверх

---

Получить цвет пикселя вне формы

Картинка будет иметь цвет пикселя под курсором мышки. Не важно где находится курсор (на вашей форме или нет) TextBox покажет Hex-значение цвета. Добавьте элементы Timer, PictureBox и Text Box на форму

Private Declare Function CreateDC& Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any)
Private Declare Function DeleteDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Dim z As POINTAPI

Private Sub Form_Load()
Timer1.Interval = 10
End Sub
Private Sub Timer1_Timer()
GetCursorPos z
screendc = CreateDC("DISPLAY", "", "", 0&)
'замените текст Text1 = Hex(GetPixel(screendc, z.x, z.y))
'если вы хотите увидеть Hex-значение цвета
Text1 = GetPixel(screendc, z.x, z.y)
Picture1.BackColor = GetPixel(screendc, z.x, z.y)
DeleteDC (screendc)
End Sub

наверх

---

Мои программы

BalloonMessage for MS Agent


Автора: Шатрыкин Иван и Павел Сурменок.

наверх

---

Вопрос/Ответ

Здесь Вы можете задать вопрос, или ответить на уже имеющиеся вопросы.

Вопросы:

---

Автор вопроса: 001

Ответ ожидается по этому адресу

   У меня за последнее время скопилось несколько вопросов:

1. Ваш совет проиграть MP3 на MMControl с DeviceType="MpegVideo" не пошел, да и я не нашел в реестре по указанному вами пути типы девайсов, попробовал я играть его на ActiveMovie Control, знакомые люди сказали, что должно заработать, но при запуске проекта выскакивает сообщение: System error &H80004005 (-2147467259), может кто сталкивался с аналогичной проблемой, на всякий случай у меня Win98, DirectX 8.1, VisualBasic 6 SP5, с железом проблем нет. Просьба объяснить нормально, с помощью чего и, главное, как играть MP3 в Visual Basic?

2. Можно ли с помощью WinSock'а органияовать UDP или TCP свяяь по модему на прямую, без ИНЕТа? Если можно, то как узнать номера портов для связи?

---

Автор вопроса: ximik

Ответ ожидается по этому адресу

   Можно ли на Visual Basice написать программу каторая бы уменьшала скорость CD если можно то как ?

---

Автор вопроса: Alex

Ответ ожидается по этому адресу

   Есть запрос на ACCESS который работает с переменой как передать эту переменую через VB

---

Автор вопроса: MaxiM

Ответ ожидается по этому адресу

   Как компилить прогу в vb7 (net)???
И можно ли там работать с директом икс ???

---

Автор вопроса: Valery Tesher

Ответ ожидается по этому адресу

   Как прокручивать TreeView в процессе drag-and-drop, когда курсор мышки достигает верхнего или нижнего края этого компонента?

---

Автор вопроса: Максим Гаранин

Ответ ожидается по этому адресу

   Можно ли в Access программно открыть запрос, основанный на SQL-операторе SELECT (строка с SQL-инструкцией может изменяться)?
Метод DoCmd.OpenQuery работает только для сохраненных запросов, а метод DoCmd.RunSQL не работает с SELECT.

---

Автор вопроса: Анатолий

Ответ ожидается по этому адресу

   Подскажите пож-та, у меня БД на Access-97, как выбрав на форме перекл-ль или лучше из поля со списком (VB должен определять и выводить имена принтеров, установленных в данный момент на компе) и делать его "по умолчанию". Т.е. то печатаем отчет на HP-1000, то отправляем на принтер/факс VentaFax.

---

Автор вопроса: Данила

Ответ ожидается по этому адресу

   Есть ComboBox, в нём значения из таблицы (методом ADD). Таблица подключается с помощью DAO 3.51 и имеет 2 колонки. В ComboBox выбрали значение из 1-ой колонки. Как узнать соответствующее ему значение из 2-ой колонки.

---

Автор вопроса: Sergey

Ответ ожидается по этому адресу

   1. Вы не подскажете как удалить приложение из диспетчера задач я работаю на VB 6.0 под WinXP.
2. И ещё как в этом виндовсе можно отключить драйвера, например, для мыши или как её можно откл.

---

Автор вопроса: goodroman

Ответ ожидается по этому адресу

   Что такое WINSOCK? Он штучка вообще в VB входит или это чё другое?

---

Ответы:

---

Вопрос:

   Как в коде VB прописать создание нового файла базы данных (именно создание а не обращение к существующему)? Файл нужен для real-time обновления таблицы значений, посему если пришлете кроме всего прочего еще и рекомендации по выбору типа базы данных для такой задачи - буду "спасибо".

Ответ:

Автор ответа: Alexbor

Для Access это выглядит так:

Dim wrkDefault As Workspace

'создаем временную БД
Set wrkDefault = DBEngine.Workspaces(0)

Set dbTempDB = wrkDefault.CreateDatabase(App.Path & "\TempDB.mdb", _
     dbLangCyrillic)
     
P.S. Не забудь подключить в Project-References библиотеку Microsoft DAO 3.6. Object Library.

---

Ответ:

Автор ответа: Кирко Владимир

См. примеры на http://www.vbnet.ru/faq/showfaqgroup.asp?id=23

---

Вопрос:

   Dim FileName Aa Integer
Private Sub Command1_Click()
CommonDialog1.ShowOpen
FileName = CommonDialog1.FileName
Adodc1.ConnectionString = "provider=Microsoft.jet.oledb.4.0;data source = FileName"

Возникает: Не удается найти c:\FileName
Как сделать чтобы присвоить Adodc1.DataSource= то, что находится в FileName?

Ответ:

Автор ответа: Сергей

Dim db As Connection
Set db = New Connection
db.CursorLocation = adUseClient
db.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\transport.mdb;"

---

Ответ:

Автор ответа: Шалгачёв Алексей

Попробуй так:

Private Sub Command1_Click()
Dim FileName
CommonDialog1.ShowOpen
FileName = CommonDialog1.FileName
Adodc1.ConnectionString = "provider=Microsoft.jet.oledb.4.0;data source = " & FileName
End Sub

---

Вопрос:

   Троян использует mswinsck.ocx. Как сделать, чтобы троян при запуске автоматически регистрировал mswinsck.ocx?
Может есть какой-то инсталятор, который позволяет не показывать окна, а просто запустить exe-шник и зарегить ActiveX?

Ответ:

Автор ответа: Programmer

Глянь тут http://www.vbnet.ru/forum/show.asp?id=12466

---

Ответ:

Автор ответа: Dima

regsvr32 \mswinsck.ocx /s
подробнее о ключах: regsvr32 /?

---

Вопрос:

   Подскажите как открыть Базу данных Microsoft Access 2000? С помощью Data1.databasename не получается, ругается что не подходящий формат!

Ответ:

Автор ответа: Кременченко

Была та же проблема. Может я действовал непрофессионально, но выкрутился, преобразовав базу данных Access 2000 в 97-ю (Сервис - Служебные программы - Преобразовать базу данных). Просто возникло подозрение, что этот .ocx работает только с 97 - й версией.

---

Ответ:

Автор ответа: ViTal

А если в свойстве Connect установить Access 2000?

---

Ответ:

Автор ответа: Александр Горбылёв

Это зависит от варианта подключения Access 2000. Должен быть установленным также MDAC не ниже версии 2.5. Выбирай свой случай. Далее
Set rs = oConn.Execute "SELECT..." или что-то в этом роде.

If MDB has a database password

oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
            "Data Source=c:\somepath\mydb.mdb;" & _
            "Jet OLEDB:Database Password=MyDbPassword;", _
            "myUsername", "myPassword"
  
If want to open up the MDB exclusively

oConn.Mode = adModeShareExclusive
oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
            "Data Source=c:\somepath\myDb.mdb;" & _
            "User Id=admin;" & _
            "Password=;"
  
If MDB is located on a network share

oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
            "Data Source=\\myServer\myShare\myPath\myDb.mdb;
  
If MDB is located on a remote machine
- Or use an XML Web Service via SOAP Toolkit or ASP.NET
- Or upgrade to SQL Server and use an IP connection string
- Use an ADO URL with a remote ASP web page
- Or use a "MS Remote" or RDS connection string
  
If you don't know the path to the MDB (using ASP)

<% ' ASP server-side code
oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
       "Data Source=" & Server.MapPath(".") & "\myDb.mdb;" & _
       "User Id=admin;" & _
       "Password=;"
%>
This assumes the MDB is in the same directory where the ASP page is running. Also make sure this directory has Write permissions for the user account.
  

If you don't know the path to the MDB (using VB)

oConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
            "Data Source=" & App.Path & "\myDb.mdb;" & _
            "User Id=admin;" & _
            "Password=;"
This assumes the MDB is in the same directory where the application is running.

For more information, see: OLE DB Provider for Microsoft Jet, Q191754, and Q225048

Note: Microsoft.Jet.OLEDB.3.51 only gets installed by MDAC 2.0. Q197902
Note: MDAC 2.6 and 2.7 do not contain any of the JET components. Q271908 and Q239114

To view Microsoft KB articles related to OLE DB Provider for Microsoft JET, click here

---

Ответ:

Автор ответа: Denis

Необходимо подключить DAO 3.6

---

Вопрос:

   Какую можно сделать заставку при загрузке программы?

Ответ:

Автор ответа: ]CBK[CRaSH

Создаеш форму frmLoad
создаеш процедуру main() в модуле
в проекте ставиш его в загрузку load StartUp
в процедуре пишиш

frmLoad.show
load frmMain
load frmMain2
load frmMain3
unload frmLoad
frmMain.show

---

Вопрос:

   Люди, как поместить иконку(иконки) в трей и по нажатию на нее показать форму (для каждой тконки свою)????

Ответ:

Автор ответа: Programmer

По этому поводу существует масса контролов и других причиндалов.
Сходи на www.vbnet.ru www.vbstreets.ru www.vbrussian.com там этого добра навалом.

---

---

Можете заполнить эту форму, либо отослать вопрос СЮДА

Форма для добавления нового вопроса в этот раздел. Информация отсылается по E-mail владельцу сайта.

Текст сообщения:

Ваше имя
E-mail для ответа

наверх