Голосование:
Ваш голос отсылается по E-mail владельцу сайта, после чего голоса анализируются и на отдельной странице выводятся результаты.
Нет тем.
Доска почёта:
Sergey Y. Tkachev
Кононенко Роман
Kirill
Sergey Sapozhnikov
Sobic
Ссылки:
Несколько слов от автора:
Очередной 45-ый выпуск рассылки.
Читайте!
Читайте!
Содержание выпуска
- Книги
- Основы работы с формой
- Заблокировать кнопку X на форме
- Сделать вашу форм поверх всех
- Создать градиент-Title Bar
- Спрятать/показать панель заголовка
- Определить, загружена ли форма
- Вопрос/Ответ
Книги
Остальные книги о VB можно найти здесь.
наверх
Основы работы с формой
Максимальные размеры формы при определенном разрешении экрана (в пикселях)
Заблокировать кнопку X на форме
'Вариант 1
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Const SC_CLOSE = &HF060
Const MF_BYCOMMAND = &H0
Public Sub DisableXbutton(ByVal frmHwnd As Long)
Dim hMenu As Long
hMenu = GetSystemMenu(frmHwnd, 0&)
If hMenu Then
Call DeleteMenu(hMenu, SC_CLOSE, MF_BYCOMMAND)
DrawMenuBar (frmHwnd)
End If
End Sub
Private Sub Form_Load()
DisableXbutton (Me.hwnd)
End Sub
'Вариант 2
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Const MF_BYPOSITION = &H400&
Public Sub DisableCloseButton(F As Form)
Dim hSysMenu As Long
hSysMenu = GetSystemMenu(F.hwnd, 0)
RemoveMenu hSysMenu, 6, MF_BYPOSITION
RemoveMenu hSysMenu, 5, MF_BYPOSITION
End Sub
Private Sub Command1_Click()
Call DisableCloseButton(Form1)
End Sub
наверх
Сделать вашу форм поверх всех
Добавьте 2 CommandButton (под именем Command1 и Command2). Когда вы нажимаете первую кнопку, ваша форма поверх всех
Private Declare Function SetWindowPos Lib "user32" (ByVal h%, ByVal hb%, ByVal x%, ByVal Y%, ByVal cx%, ByVal cy%, ByVal F%) As Integer
Const SWP_NOMOVE = 2
Const SWP_NOSIZE = 1
Const flags = SWP_NOMOVE Or SWP_NOSIZE
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Private Sub Command1_Click()
res = SetWindowPos(Form1.hwnd, HWND_TOPMOST, 0, 0, 0, 0, flags) 'Форма on-top
End Sub
Private Sub Command2_Click()
res = SetWindowPos(Form1.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, flags) 'Форма non-on-top
End Sub
наверх
Создать градиент-Title Bar
Добавьте модуль в ваш проект
'КОД ФОРМЫ
Private Sub Form_Load()
GradForceColors = True
'Замените 'True' на 'False' если хотите получить горизонтальную прорисовку
GradVerticalGradient = True
'Установить цвет активного заголовка
GradForcedText = vbWhite
'Замените две установки цвета ниже для изменения цвета фона активного заголовка
GradForcedFirst = &H800000
GradForcedSecond = &H8000
'Установить цвет неактивного заголовка
GradForcedTextA = &HC0C0C0
'Замените две установки цвета ниже для изменения цвета фона неактивного заголовка
GradForcedFirstA = vbBlack
GradForcedSecondA = vbBlue
GradientGetCapsFont
GradientForm Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
GradientReleaseForm Me
End Sub
'КОД МОДУЛЯ
Public GradForceColors As Boolean
Public GradVerticalGradient As Boolean
Public GradForcedText As Long, GradForcedTextA As Long
Public GradForcedFirst As Long, GradForcedSecond As Long
Public GradForcedFirstA As Long, GradForcedSecondA As Long
Dim GradhWnd As Long, GradIcon As Long
Dim DrawDC As Long, tmpDC As Long
Dim hRgn As Long
Dim tmpGradFont As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_WNDPROC = (-4)
Private Const GWL_STYLE = (-16)
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Const LF_FACESIZE = 32
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(1 To LF_FACESIZE) As Byte
End Type
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SPI_GETNONCLIENTMETRICS = 41
Private Type NONCLIENTMETRICS
cbSize As Long
iBorderWidth As Long
iScrollWidth As Long
iScrollHeight As Long
iCaptionWidth As Long
iCaptionHeight As Long
lfCaptionFont As LOGFONT
iSMCaptionWidth As Long
iSMCaptionHeight As Long
lfSMCaptionFont As LOGFONT
iMenuWidth As Long
iMenuHeight As Long
lfMenuFont As LOGFONT
lfStatusFont As LOGFONT
lfMessageFont As LOGFONT
End Type
Dim CaptionFont As LOGFONT
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function IsZoomed Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Const IDC_SIZENS = 32645&
Private Const IDC_SIZEWE = 32644&
Private Const IDC_SIZENWSE = 32642&
Private Const IDC_SIZENESW = 32643&
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Const WS_BORDER = &H800000
Private Const WS_CAPTION = &HC00000
Private Const WS_DLGFRAME = &H400000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_OVERLAPPED = &H0&
Private Const WS_SYSMENU = &H80000
Private Const WS_THICKFRAME = &H40000
Private Const WS_POPUP = &H80000000
Private Const WS_SIZEBOX = WS_THICKFRAME
Private Const WS_TILED = WS_OVERLAPPED
Private Const WS_VISIBLE = &H10000000
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function OffsetClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal Y As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal Y As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hDC As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_SINGLELINE = &H20
Private Const DT_VCENTER = &H4
Private Const DT_END_ELLIPSIS = &H8000&
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long) As Long
Private Declare Function GetClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long) As Long
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 Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Const COLOR_ACTIVECAPTION = 2
Private Const COLOR_CAPTIONTEXT = 9
Private Const COLOR_INACTIVECAPTION = 3
Private Const COLOR_INACTIVECAPTIONTEXT = 19
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Const TRANSPARENT = 1
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXBORDER = 5
Private Const SM_CXDLGFRAME = 7
Private Const SM_CXFRAME = 32
Private Const SM_CXICON = 11
Private Const SM_CXSMSIZE = 30
Private Const SM_CYBORDER = 6
Private Const SM_CYCAPTION = 4
Private Const SM_CYDLGFRAME = 8
Private Const SM_CYFRAME = 33
Private Const SM_CYICON = 12
Private Const SM_CYMENU = 15
Private Const SM_CYSMSIZE = 31
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function ExcludeClipRect Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DrawFrameControl Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Long
Private Const DFC_CAPTION = 1
Private Const DFCS_CAPTIONRESTORE = &H3
Private Const DFCS_CAPTIONMIN = &H1
Private Const DFCS_CAPTIONMAX = &H2
Private Const DFCS_CAPTIONHELP = &H4
Private Const DFCS_CAPTIONCLOSE = &H0
Private Const DFCS_INACTIVE = &H100
Private Const WM_SIZE = &H5
Private Const WM_SETCURSOR = &H20
Private Const WM_GETICON = &H7F
Private Const WM_SETICON = &H80
Private Const WM_NCACTIVATE = &H86
Private Const WM_MDIACTIVATE = &H222
Private Const WM_KILLFOCUS = &H8
Private Const WM_MOUSEACTIVATE = &H21
Private Const WM_MDIGETACTIVE = &H229
Private Const MA_ACTIVATE = 1
Private Const WM_SETTEXT = &HC
Private Const WM_NCPAINT = &H85
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_NCRBUTTONDOWN = &HA4
Private Const WM_SYSCOMMAND = &H112
Private Const WM_INITMENUPOPUP = &H117
Private Const SC_MOUSEMENU = &HF090&
Private Const SC_MOVE = &HF010&
Private Const HTCAPTION = 2
Private Const HTSYSMENU = 3
Private Const HTLEFT = 10
Private Const HTRIGHT = 11
Private Const HTTOP = 12
Private Const HTTOPLEFT = 13
Private Const HTTOPRIGHT = 14
Private Const HTBOTTOM = 15
Private Const HTBOTTOMLEFT = 16
Private Const HTBOTTOMRIGHT = 17
Private Function LoWord(LongIn As Long) As Integer
If (LongIn And &HFFFF&) > &H7FFF Then
LoWord = (LongIn And &HFFFF&) - &H10000
Else
LoWord = LongIn And &HFFFF&
End If
End Function
Private Sub GetColors(IsActive As Boolean, LColor As Long, RColor As Long)
If IsActive Then
If GradForceColors Then
LColor = GradForcedFirst
RColor = GradForcedSecond
Else
LColor = vbBlack
RColor = GetSysColor(COLOR_ACTIVECAPTION)
End If
Else
If GradForceColors Then
LColor = GradForcedFirstA
RColor = GradForcedSecondA
Else
LColor = vbBlack
RColor = GetSysColor(COLOR_INACTIVECAPTION)
End If
End If
End Sub
Public Sub GradientGetCapsFont()
Dim NCM As NONCLIENTMETRICS
Dim lfNew As LOGFONT
NCM.cbSize = Len(NCM)
Call SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, NCM, 0)
CaptionFont = NCM.lfCaptionFont
End Sub
Private Sub GetCaptionRect(hWnd As Long, rct As RECT)
Dim XBorder As Long
Dim fStyle As Long
Dim YHeight As Long
YHeight = GetSystemMetrics(SM_CYCAPTION)
fStyle = GetWindowLong(hWnd, GWL_STYLE)
Select Case fStyle And &H80
Case &H80
XBorder = GetSystemMetrics(SM_CXDLGFRAME)
Case Else
XBorder = GetSystemMetrics(SM_CXFRAME)
End Select
rct.Left = XBorder
rct.Right = XBorder
rct.Top = XBorder
rct.Bottom = rct.Top + YHeight - 1
End Sub
Private Sub GradateColors(Colors() As Long, ByVal Color1 As Long, ByVal Color2 As Long)
Dim i As Long
Dim dblR As Double, dblG As Double, dblB As Double
Dim addR As Double, addG As Double, addB As Double
Dim bckR As Double, bckG As Double, bckB As Double
dblR = CDbl(Color1 And &HFF)
dblG = CDbl(Color1 And &HFF00&) / 255
dblB = CDbl(Color1 And &HFF0000) / &HFF00&
bckR = CDbl(Color2 And &HFF&)
bckG = CDbl(Color2 And &HFF00&) / 255
bckB = CDbl(Color2 And &HFF0000) / &HFF00&
addR = (bckR - dblR) / UBound(Colors)
addG = (bckG - dblG) / UBound(Colors)
addB = (bckB - dblB) / UBound(Colors)
For i = 0 To UBound(Colors)
dblR = dblR + addR
dblG = dblG + addG
dblB = dblB + addB
If dblR > 255 Then dblR = 255
If dblG > 255 Then dblG = 255
If dblB > 255 Then dblB = 255
If dblR < 0 Then dblR = 0
If dblG < 0 Then dblG = 0
If dblG < 0 Then dblB = 0
Colors(i) = RGB(dblR, dblG, dblB)
Next
End Sub
Private Function DrawGradient(ByVal Color1 As Long, ByVal Color2 As Long) As Long
Dim i As Long
Dim DestWidth As Long, DestHeight As Long
Dim StartPnt As Long, EndPnt As Long
Dim PixelStep As Long, XBorder As Long
Dim WndRect As RECT
Dim OldFont As Long
Dim fStyle As Long, fText As String
Dim SMSize As Long, SMSizeY As Long
On Error Resume Next
SMSize = GetSystemMetrics(SM_CXSMSIZE)
SMSizeY = GetSystemMetrics(SM_CYSMSIZE)
GetWindowRect GradhWnd, WndRect
With WndRect
DestWidth = .Right - .Left
End With
DestHeight = GetSystemMetrics(SM_CYCAPTION)
fText = Space$(255)
Call GetWindowText(GradhWnd, fText, 255)
fText = Trim$(fText)
fStyle = GetWindowLong(GradhWnd, GWL_STYLE)
Select Case fStyle And &H80
Case &H80
XBorder = GetSystemMetrics(SM_CXDLGFRAME)
DestWidth = (DestWidth - XBorder)
Case Else
XBorder = GetSystemMetrics(SM_CXFRAME)
DestWidth = DestWidth - XBorder
End Select
StartPnt = XBorder
EndPnt = XBorder + DestWidth - 4
Dim rct As RECT
Dim hBr As Long
With rct
If Not GradVerticalGradient Then
PixelStep = DestWidth \ 8
ReDim Colors(PixelStep) As Long
GradateColors Colors(), Color1, Color2
.Top = XBorder
.Left = XBorder
.Right = XBorder + (DestWidth \ PixelStep)
.Bottom = (XBorder + DestHeight - 1)
If (fStyle And &H80) = &H80 Then EndPnt = EndPnt + 1
For i = 0 To PixelStep - 1
hBr = CreateSolidBrush(Colors(i))
FillRect DrawDC, rct, hBr
DeleteObject hBr
OffsetRect rct, (DestWidth \ PixelStep), 0
If i = PixelStep - 2 Then .Right = EndPnt
Next
Else
PixelStep = DestHeight \ 1
ReDim Colors(PixelStep) As Long
GradateColors Colors(), Color2, Color1
.Top = XBorder
.Left = XBorder
If (fStyle And &H80) = &H80 Then
.Right = (XBorder * 2) + DestWidth + 2
Else
.Right = (XBorder * 2) + DestWidth
End If
.Bottom = XBorder + (DestHeight \ PixelStep)
For i = 0 To PixelStep - 1
hBr = CreateSolidBrush(Colors(i))
FillRect DrawDC, rct, hBr
DeleteObject hBr
OffsetRect rct, 0, (DestHeight \ PixelStep)
If i = PixelStep - 2 Then .Bottom = XBorder + (DestHeight - 1)
.Bottom = XBorder + (DestHeight - 1)
Next
End If
.Top = XBorder
If GradIcon <> 0 Then
.Left = XBorder + SMSize + 2
DrawIconEx DrawDC, XBorder + 1, XBorder + 1, GradIcon, SMSize - 2, SMSize - 2, ByVal 0&, ByVal 0&, 2
Else
.Left = XBorder
End If
tmpGradFont = CreateFontIndirect(CaptionFont)
OldFont = SelectObject(DrawDC, tmpGradFont)
SetBkMode DrawDC, TRANSPARENT
If GradForceColors Then
If Color1 = GradForcedFirst Then
SetTextColor DrawDC, GradForcedText
Else
SetTextColor DrawDC, GradForcedTextA
End If
Else
If Color2 = GetSysColor(COLOR_ACTIVECAPTION) Then
SetTextColor DrawDC, GetSysColor(COLOR_CAPTIONTEXT)
Else
SetTextColor DrawDC, GetSysColor(COLOR_INACTIVECAPTIONTEXT)
End If
End If
.Left = .Left + 2
.Right = .Right - 10
DrawText DrawDC, fText, Len(fText) - 1, rct, DT_SINGLELINE Or DT_END_ELLIPSIS Or DT_VCENTER
SelectObject DrawDC, OldFont
DeleteObject tmpGradFont
tmpGradFont = 0
Dim frct As RECT
If (fStyle And WS_SYSMENU) = WS_SYSMENU Then
Dim CurMaxPic As Long
If IsZoomed(GradhWnd) Then
CurMaxPic = DFCS_CAPTIONRESTORE
Else
CurMaxPic = DFCS_CAPTIONMAX
End If
With frct
.Right = DestWidth - 2
.Left = .Right - SMSize + 2
.Top = XBorder + 2
.Bottom = .Top + (DestHeight - 5)
End With
DrawFrameControl DrawDC, frct, DFC_CAPTION, DFCS_CAPTIONCLOSE
OffsetRect frct, -(SMSize), 0
If (fStyle And WS_MAXIMIZEBOX) = WS_MAXIMIZEBOX And (fStyle And WS_MINIMIZEBOX) = WS_MINIMIZEBOX Then
DrawFrameControl DrawDC, frct, DFC_CAPTION, CurMaxPic
OffsetRect frct, -(SMSize) + 2, 0
DrawFrameControl DrawDC, frct, DFC_CAPTION, DFCS_CAPTIONMIN
ElseIf (fStyle And WS_MAXIMIZEBOX) = WS_MAXIMIZEBOX Then
DrawFrameControl DrawDC, frct, DFC_CAPTION, CurMaxPic
OffsetRect frct, -(SMSize) + 2, 0
DrawFrameControl DrawDC, frct, DFC_CAPTION, DFCS_CAPTIONMIN Or DFCS_INACTIVE
ElseIf (fStyle And WS_MINIMIZEBOX) = WS_MINIMIZEBOX Then
DrawFrameControl DrawDC, frct, DFC_CAPTION, CurMaxPic Or DFCS_INACTIVE
OffsetRect frct, -(SMSize) + 2, 0
DrawFrameControl DrawDC, frct, DFC_CAPTION, DFCS_CAPTIONMIN
End If
End If
.Left = XBorder
.Right = .Right + 12
If tmpDC <> 0 Then
BitBlt tmpDC, .Left, .Top, .Right - .Left - 10, .Bottom - .Top, DrawDC, .Left, .Top, vbSrcCopy
ExcludeClipRect tmpDC, XBorder, XBorder, DestWidth, XBorder(DestHeight - 1)
End If
End With
End Function
Public Function GradientCallback(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim OldGradProc As Long
Dim OldBMP As Long, NewBMP As Long
Dim rcWnd As RECT
Dim tmpFrm As Form
Dim tmpCol1 As Long, tmpCol2 As Long
Static GettingIcon As Boolean
GradhWnd = hWnd
OldGradProc = GetProp(GradhWnd, "OldMeProc")
If Not GettingIcon Then
GettingIcon = True
GradIcon = SendMessage(hWnd, WM_GETICON, 0, ByVal 0&)
GettingIcon = False
End If
Select Case wMsg
Case WM_NCACTIVATE, WM_MDIACTIVATE, WM_KILLFOCUS, WM_MOUSEACTIVATE
GetWindowRect GradhWnd, rcWnd
tmpDC = GetWindowDC(GradhWnd)
DrawDC = CreateCompatibleDC(tmpDC)
NewBMP = CreateCompatibleBitmap(tmpDC, rcWnd.Right - rcWnd.Left, 50)
OldBMP = SelectObject(DrawDC, NewBMP)
With rcWnd
hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
SelectClipRgn tmpDC, hRgn
OffsetClipRgn tmpDC, -.Left, -.Top
End With
If wMsg = WM_KILLFOCUS And GetParent(GradhWnd) <> 0 Then
GetColors False, tmpCol1, tmpCol2
ElseIf wMsg = WM_NCACTIVATE And wParam And _
(GetParent(GradhWnd) = 0) Then
GetColors True, tmpCol1, tmpCol2
ElseIf wMsg = WM_NCACTIVATE And wParam = 0 And (GetParent(GradhWnd) = 0) Then
GetColors False, tmpCol1, tmpCol2
ElseIf wParam = GradhWnd And GetParent(GradhWnd) <> 0 Then
GetColors False, tmpCol1, tmpCol2
ElseIf SendMessage(GetParent(GradhWnd), WM_MDIGETACTIVE, 0, 0) = GradhWnd Then
GetColors True, tmpCol1, tmpCol2
ElseIf GetActiveWindow() = GradhWnd Then
GetColors True, tmpCol1, tmpCol2
Else
GetColors False, tmpCol1, tmpCol2
End If
DrawGradient tmpCol1, tmpCol2
SelectObject DrawDC, OldBMP
DeleteObject NewBMP
DeleteDC DrawDC
OffsetClipRgn tmpDC, rcWnd.Left, rcWnd.Top
GetClipRgn tmpDC, hRgn
If wMsg = WM_MOUSEACTIVATE Then
GradientCallback = MA_ACTIVATE
Else
GradientCallback = 1
End If
ReleaseDC GradhWnd, tmpDC
DeleteObject hRgn
tmpDC = 0
Exit Function
Case WM_SETTEXT, WM_NCPAINT, WM_NCLBUTTONDOWN, _
WM_NCRBUTTONDOWN, WM_SYSCOMMAND, WM_INITMENUPOPUP
GetWindowRect GradhWnd, rcWnd
tmpDC = GetWindowDC(GradhWnd)
DrawDC = CreateCompatibleDC(tmpDC)
NewBMP = CreateCompatibleBitmap(tmpDC, rcWnd.Right - rcWnd.Left, 50)
OldBMP = SelectObject(DrawDC, NewBMP)
With rcWnd
hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
SelectClipRgn tmpDC, hRgn
OffsetClipRgn tmpDC, -.Left, -.Top
End With
If (GetActiveWindow() = GradhWnd) Then
GetColors True, tmpCol1, tmpCol2
ElseIf SendMessage(GetParent(GradhWnd), WM_MDIGETACTIVE, 0, 0) = GradhWnd Then
GetColors True, tmpCol1, tmpCol2
Else
GetColors False, tmpCol1, tmpCol2
End If
DrawGradient tmpCol1, tmpCol2
SelectObject DrawDC, OldBMP
DeleteObject NewBMP
DeleteDC DrawDC
OffsetClipRgn tmpDC, rcWnd.Left, rcWnd.Top
GetClipRgn tmpDC, hRgn
GradientCallback = CallWindowProc(OldGradProc, hWnd, WM_NCPAINT, hRgn, lParam)
ReleaseDC GradhWnd, tmpDC
DeleteObject hRgn
tmpDC = 0
If wMsg = (WM_NCLBUTTONDOWN And wParam <> HTSYSMENU And wParam <> HTCAPTION) Or wMsg = _
(WM_SYSCOMMAND And Not (wParam = SC_MOUSEMENU)) Then
GetCaptionRect GradhWnd, rcWnd
ExcludeClipRect tmpDC, rcWnd.Left, rcWnd.Top, rcWnd.Right, rcWnd.Bottom
ElseIf wMsg = WM_NCLBUTTONDOWN And wParam = HTCAPTION Then
If IsZoomed(GradhWnd) = 0 Then
GradientCallback = SendMessage(GradhWnd, WM_SYSCOMMAND, SC_MOVE, ByVal 0&)
End If
Exit Function
Else
Exit Function
End If
Case WM_SIZE
If hWnd = GradhWnd Then
SendMessage GradhWnd, WM_NCPAINT, 0, 0
End If
Case WM_SETCURSOR
Select Case LoWord(lParam)
Case HTTOP, HTBOTTOM
SetCursor LoadCursor(ByVal 0&, IDC_SIZENS)
Case HTLEFT, HTRIGHT
SetCursor LoadCursor(ByVal 0&, IDC_SIZEWE)
Case HTTOPLEFT, HTBOTTOMRIGHT
SetCursor LoadCursor(ByVal 0&, IDC_SIZENWSE)
Case HTTOPRIGHT, HTBOTTOMLEFT
SetCursor LoadCursor(ByVal 0&, IDC_SIZENESW)
Case Else
GoTo JustCallBack
End Select
GradientCallback = 1
Exit Function
End Select
JustCallBack:
GradientCallback = CallWindowProc(OldGradProc, hWnd, wMsg, wParam, lParam)
End Function
Public Sub GradientForm(frm As Form)
Dim tmpProc As Long
tmpProc = SetWindowLong(frm.hWnd, GWL_WNDPROC, AddressOf GradientCallback)
SetProp frm.hWnd, "OldMeProc", tmpProc
End Sub
Public Sub GradientReleaseForm(frm As Form)
Dim tmpProc As Long
tmpProc = GetProp(frm.hWnd, "OldMeProc")
RemoveProp frm.hWnd, "OldMeProc"
If tmpProc = 0 Then Exit Sub
SetWindowLong frm.hWnd, GWL_WNDPROC, tmpProc
End Sub
наверх
Спрятать/показать панель заголовка
Добавьте 2 CommandButton на форму
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_SYSMENU = &H80000
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Enum ESetWindowPosStyles
SWP_SHOWWINDOW = &H40
SWP_HIDEWINDOW = &H80
SWP_FRAMECHANGED = &H20
SWP_NOACTIVATE = &H10
SWP_NOCOPYBITS = &H100
SWP_NOMOVE = &H2
SWP_NOOWNERZORDER = &H200
SWP_NOREDRAW = &H8
SWP_NOREPOSITION = SWP_NOOWNERZORDER
SWP_NOSIZE = &H1
SWP_NOZORDER = &H4
SWP_DRAWFRAME = SWP_FRAMECHANGED
HWND_NOTOPMOST = -2
End Enum
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Function ShowTitleBar(ByVal bState As Boolean)
Dim lStyle As Long
Dim tR As RECT
GetWindowRect Me.hwnd, tR
lStyle = GetWindowLong(Me.hwnd, GWL_STYLE)
If (bState) Then
Me.Caption = Me.Tag
If Me.ControlBox Then
lStyle = lStyle Or WS_SYSMENU
End If
If Me.MaxButton Then
lStyle = lStyle Or WS_MAXIMIZEBOX
End If
If Me.MinButton Then
lStyle = lStyle Or WS_MINIMIZEBOX
End If
If Me.Caption = "" Then
lStyle = lStyle Or WS_CAPTION
End If
Else
Me.Tag = Me.Caption
Me.Caption = ""
lStyle = lStyle And Not WS_SYSMENU
lStyle = lStyle And Not WS_MAXIMIZEBOX
lStyle = lStyle And Not WS_MINIMIZEBOX
lStyle = lStyle And Not WS_CAPTION
End If
SetWindowLong Me.hwnd, GWL_STYLE, lStyle
SetWindowPos Me.hwnd, 0, tR.Left, tR.Top, tR.Right - tR.Left, tR.Bottom - tR.Top, SWP_NOREPOSITION Or SWP_NOZORDER Or SWP_FRAMECHANGED
Me.Refresh
End Function
Private Sub Command1_Click()
ShowTitleBar False
End Sub
Private Sub Command2_Click()
ShowTitleBar True
End Sub
наверх
Определить, загружена ли форма
Добавьте 2 CommandButton и другую форму (Form 2)
Function FormLoadedByName(FormName As String) As Boolean
Dim i As Integer, fnamelc As String
fnamelc = LCase$(FormName)
FormLoadedByName = False
For i = 0 To Forms.Count - 1
If LCase$(Forms(i).Name) = fnamelc Then
FormLoadedByName = True
Exit Function
End If
Next
End Function
Private Sub Command1_Click()
'Замените 'Form2' именем формы, про которую хотите знать...
If FormLoadedByName("Form2") = True Then
MsgBox "Форма загружена"
Else
MsgBox "Форма не загружена"
End If
End Sub
Private Sub Command2_Click()
Load Form2
End Sub
наверх
Мои программы
BalloonMessage for MS Agent
Автор: Шатрыкин Иван. Соавтор: Павел Сурменок.
наверх
Вопрос/Ответ
Автор вопроса: P@Ssword
Ответ ожидается по этому адресу
Может, у кого есть описания протоколов SMTP и POP3? Скиньте мне, plz.
Автор вопроса: Иван
Ответ ожидается по этому адресу
Я яапускаю программу EXE, сделанную во Flash таким обраяом:
Shell App.Path & "\" & "Times.exe", vbMaximizedFocus
Проблема в том, что данная программа не раяварачивает окно на максимальный раямер, а оставляет яаголовок. Подскажите, может кто встречался с такой проблеммой.
Автор вопроса: Саша
Ответ ожидается по этому адресу
Как скопировать текст находящейся вне формы.
Автор вопроса: Velin
Ответ ожидается по этому адресу
Как из Excel сохранить данные в *.dbf файл, но не лист целеком (сохранить как...), а выборочно
Автор вопроса: Samit
Ответ ожидается по этому адресу
Как можно непосредственно из программы отсылать письма без почтового клиента?
Автор вопроса: Pasha
Ответ ожидается по этому адресу
Кто нибудь сталкивался с такой проблемой: если создается соединение между 2 компьютерами через Winsock, а потом закрыть соединение то неудастся соединиться заново пока не закроешь и не откроешь программу ?
Автор вопроса: Xatab
Ответ ожидается по этому адресу
Плиз кто нибудь киньте на мыло программу перекодировщик VB в VC. Очень нужно.
Автор вопроса: sapient
Ответ ожидается по этому адресу
Как средствами VBA for Excel 97 получить список файлов в папке и каким обрпзом их всех последовательно пооткрывать (все *.xls)?
Автор вопроса: Ревягин_Алексей
Ответ ожидается по этому адресу
Вписал этот код:
Option Explicit
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
Private Const MF_BITMAP = &H4&
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Declare Function GetMenuInfo Lib "user32" (ByVal hMenu As Long, lpcmi As tagMENUINFO) As Long
Private Declare Function SetMenuInfo Lib "user32" (ByVal hMenu As Long, lpcmi As tagMENUINFO) As Long
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Private Type tagMENUINFO
cbSize As Long
fMask As Long
dwStyle As Long
cyMax As Long
hbrBack As Long
dwContextHelpID As Long
dwMenuData As Long
End Type
Private Const BS_SOLID = 0
Private Const MIM_APPLYTOSUBMENUS = &H80000000
Private Const MIM_BACKGROUND = &H2
Private Sub Form_Load()
Dim ret As Long
Dim hMenu As Long
Dim hBrush As Long
Dim lbBrushInfo As LOGBRUSH
Dim miMenuInfo As tagMENUINFO
lbBrushInfo.lbStyle = BS_SOLID
lbBrushInfo.lbColor = <цвет>
lbBrushInfo.lbHatch = 0
hBrush = CreateBrushIndirect(lbBrushInfo)
hMenu = GetMenu(Me.hwnd)
miMenuInfo.cbSize = Len(miMenuInfo)
ret = GetMenuInfo(hMenu, miMenuInfo)
miMenuInfo.fMask = MIM_APPLYTOSUBMENUS Or MIM_BACKGROUND
miMenuInfo.hbrBack = hBrush
ret = SetMenuInfo(hMenu, miMenuInfo)
SetMenuItemBitmaps hMenu, GetMenuItemID(GetSubMenu(hMenu, 0), 0), MF_BITMAP, LoadResPicture(101, vbResBitmap), LoadResPicture(101, vbResBitmap)
SetMenuItemBitmaps hMenu, GetMenuItemID(GetSubMenu(hMenu, 0), 1), MF_BITMAP, LoadResPicture(104, vbResBitmap), LoadResPicture(104, vbResBitmap)
SetMenuItemBitmaps hMenu, GetMenuItemID(GetSubMenu(hMenu, 0), 2), MF_BITMAP, LoadResPicture(107, vbResBitmap), LoadResPicture(107, vbResBitmap)
End Sub
1) Почему при каждом вызове PopupMenu или просто при нажатии на кнопку меню появляются разные картинки, имеющиеся у меня на форме, а не которые надо(из файла ресурсов либо с формы(например:
SetMenuItemBitmaps hMenu, GetMenuItemID(GetSubMenu(hMenu, 0), 2), MF_BITMAP,Picture1(0).Picture),Picture1(0).Picture))).
2)как из файла ресурсов читать: GIF'ы, JPG, EXE? (BMP в 5 раз больше по размеру чем соответстующий ему GIF или JPG)
Автор вопроса: rul@langepas.wsnet.ru
Ответ ожидается по этому адресу
Подскажите пожалуйста, как в VB 3.0 использовать WinSoket. А лучше отошлите (если есть) исходничок.
Автор вопроса: Андрей
Ответ ожидается по этому адресу
Пишу прогу на visual basic 5.0, сталкнулся с такой проблемой, как при нажатии на кнопку раявернуть окно выбора документов и нажатии на соответсвующий документ открыть Word.
Автор вопроса: Андрей
Ответ ожидается по этому адресу
Народ требуется ХЕЛП, как в Visual Basic 5.0 сделать чтоб при нажатии, например кнопки Command1 открывалась программа Word. Если можно подробнее об этом.
Автор вопроса: Саша
Ответ ожидается по этому адресу
Что такое hwnd. Что можно сделать зная hwnd чужего окна.
Ответы:
Вопрос:
У меня в базе данных, в одной таблице два поля. В первом названия клипов, во втором названия файлов. Первое поле выводится на ListBox. Как сделать, чтобы при двойном нажатии на какой-либо строке в поле 1, в MediaPlayer загружался файл из соответствующего поля 2?
Ответ:
Автор ответа: Ревягин_Алексей
Помести но форму объект Windows MediaPlayer и обзови его так : MP1
Помести на форму TextBox1 с Visible=false и укажи у него меню
Properties->DataSource=ОБЪЕКТ_КОТОРЫЙ_ПРИСОЕДИНЁН К_БД (напр, Data1)
Properties->DataField=ИМЯ_ПОЛЯ_ГДЕ_ХРАНЯТСЯ_НАЗВАНИЯ_ФАЙЛОВ
и впиши следующий код:
Private Sub ListBox1_dblclick()
'так как у тебя в поле 2 хранятся названия файлов, то
Data1.recordset.absoluteposition=listbox1.listindex
MP1.FileName="_ПУТЬ_ДО_ПАПКИ_С_ФАЙЛАМИ_" & textbox1.text
end sub
Вопрос:
Как мне соядать SETUP не более 2Мб.
Хочу поделиться своей ОЧЕНЬ ПРРОСТОЙ программкой, которая всего лишь соядает текстовый файл, а SETUP к нему весит от 10 до 14 Мб.
Можно как-нибудь справиться с этим?
Понимаю, что эта тема всех достала, но еще никто мне доступно не ответил, все как-то абстрактно.
Ответ:
Автор ответа: Мунгалов Андрей
проблема в том что программы написанные на VB не работают без библиотеки исполнения а она одна для VB6 весит около 1,3 мега + если используешь какие-то ActiveX компоненты они тоже прилагаются к дистрибутиву. поэтому даже если программа делает просто 2+2 она все равно будет много места занимать. выход можно попробовать такой узнать на той машине куда будешь ставить программу, есть библиотека или нет, может ее уже с другой программой ставили. тогда можно просто один EXE файл скопировать.
Вопрос:
Как мне соядать SETUP не более 2Мб.
Хочу поделиться своей ОЧЕНЬ ПРРОСТОЙ программкой, которая всего лишь соядает текстовый файл, а SETUP к нему весит от 10 до 14 Мб.
Можно как-нибудь справиться с этим?
Понимаю, что эта тема всех достала, но еще никто мне доступно не ответил, все как-то абстрактно.
Ответ:
Автор ответа: Иван
С папки System скопируй в директорию где лежит твоя программа следующие файлы: Richtx32.ocx, Msvbvm60.dll. Вот пожалуй и всё.
Ещё очень важно, чтобы на компе, на котором будет ставиться программа, эти файлы лежали либо в одной директории с exe, либо в папке System. Да и ещё на всякий случай замечу, что всегда тебе придётся к своим проектам ложить Msvbvm60.dll, т.к. именно он отвечает за основные элементы VB. А если используешь дополнительные библиотеки, то просто необходимо посмотреть на какой ocx он ссылается. Можно обойтись и без инсталяшки, если использовать программу Fusion, но она немного замедляет работу программы.
Вопрос:
Подскажите плз, как мне безоговорочно переписать существующий файл.
Вот что у меня есть:
excelapp.Workbooks(1).SaveAs FileName:="c:\tmp.xls", AccessMode:=xlShared
Сейчас, если файл c:\tmp.xls есть, то задается вопрос, переписать ли поверх. Мне же надо, чтобы он это не спрашивал, а сразу, молча переписывал.
Ответ:
Автор ответа: Kirill
Чтоб не выводились предупреждения в офисных приложениях надо свойство DisplayAlerts установить в False:
excelapp.DisplayAlerts = False
...
excelapp.Workbooks(1).SaveAs FileName:="c:\tmp.xls", AccessMode:=xlShared
...
excelapp.DisplayAlerts = True
Вопрос:
Подскажите плз, как мне безоговорочно переписать существующий файл.
Вот что у меня есть:
excelapp.Workbooks(1).SaveAs FileName:="c:\tmp.xls", AccessMode:=xlShared
Сейчас, если файл c:\tmp.xls есть, то задается вопрос, переписать ли поверх. Мне же надо, чтобы он это не спрашивал, а сразу, молча переписывал.
Ответ:
Автор ответа: Ревягин_Алексей
в модуле:
Public Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
В процедуре перемещения
Kill ПУТЬ_К_СТАРОМУ_ФАЙЛУ
MoveFile ПУТЬ_К_НОВОМУ_ФАЙЛУ, ПУТЬ_К_СТАРОМУ_ФАЙЛУ
Вопрос:
Какие вояможности VB поддерживает VBScript? или какие не поддерживает?
Ответ:
Автор ответа: DeadMorozzz
VBScript это практечески одно и тоже, что и VB. Т.е. ты можешь без проблем код из VBScript ксопировать в VB и все будет работать. А вот наоборот сложнее из-за объектов =). Короче говоря, то, что ты можешь сделать на VB, ты можешь сделать и на VBScript, за исключением, пожалуй, работы с объектами и формами, но и там можно кое-что придумать...
Вопрос:
Помогите разобраться в функцией "open" чтения данных из файла. Я запутался с типом "input,output,random,binary" и присвоением. Подскажите где можно найти подробнее об этом операторе..
Ответ:
Автор ответа: Igoryk
В общем функция Open служит для работы с файлами.
Open File For Output as 1 - создает файл File, а если таковой был, то очищает его.
Open File For Append as 1 - создает файл, но если файл существует, то открывает его и добавляет в конец запись, которую ты укажешь (Print #1 или Write #1)
Open File For Input as 1 - открывает файл для чтения из него информации.
Open File For Random as 1 - открывает файл для чтения\записи из\в файла типы данных, например
Type My
a as string*4
b as long
End Type
Open File For Random as 1
Get #1,,My
В этом случае 4 байта окажется в My.a, и 4 байта (тип Long) в My.b
Open File For Binary as 1 - делает с файлом то же, что и Random, но используется для двоичного доступа к файлу: например, считать байт определенным номером и т.п.
Вопрос:
Помогите разобраться в функцией "open" чтения данных из файла. Я запутался с типом "input,output,random,binary" и присвоением. Подскажите где можно найти подробнее об этом операторе..
Ответ:
Автор ответа: Filippov Anton Sergeevich
Тут все просто. Формат такой:
open "полное_имя_файла" for <опция> as #n
open - Команда открытия файла;
полное_имя_файла - полное имя файла, который требуется открыть;
<опция> - для чего открывается файл:
input - чтение данных,
output - перезапись файла (если он не существовал, то будет создан)
append - устанавливает счтитывающе-записывающее устройство на конец файла, для добавления данных в конец файла.
#n - номер от #1 до #256. Например первый файл открывается как #1, второй как #2...
После завершения операций ввода-вывода файл следует закрыть
close #n - для закрытия файла с номером N или close для закрытия всех открытых файлов.
вывод:
input #n, "куда_выводить"
#n - номер файла, из которого выводится строка "куда_выводить" - переменная, textbox, label и т.д.
запись:
print #n,"строка"
в качестве "строки" может быть конкретная строка, переменная, текстовое поле, параметр (Например Form1.caption).
Вопрос:
Помогите разобраться в функцией "open" чтения данных из файла. Я запутался с типом "input,output,random,binary" и присвоением. Подскажите где можно найти подробнее об этом операторе..
Ответ:
Автор ответа: Ревягин_Алексей
dim FNumber as integer
Private Sub Command1_click()
fnumber=freefile
open "ПУТЬ_К_НОВОМУ_ФАЙЛУ" for output as fnumber
print #fnumber,"СТРОКИ_В_ФАЙЛЕ"
close fnumber
end sub
Private Sub Command2_click()
fnumber=freefile
open "ПУТЬ_К_СУЩЕСТВУЮЩЕМУ_ФАЙЛУ" for input as fnumber
line input #fnumber, "ПЕРЕМЕННАЯ_В_КОТОРУЮ_СОХРАНЯЕТСЯ_СТРОКА"
close fnumber
end sub
Private Sub Command3_Click()
fnumber=freefile
open "ПУТЬ_К_СУЩЕСТВУЮЩЕМУ_ФАЙЛУ" for append as fnumber
print #fnumber, "СТРОКА_КОТОРАЯ_БУДЕТ_ДОБАВЛЕНА_В_КОНЕЦ_ФАЙЛА"
close fnumber
end sub
Вопрос:
1)Как реально прописать прогу в реестре ?
2)Как найти в richtextbox слова какие выберешь ну там и изменить их цвет ?
3)Как сделать так чтоб комп проверял столкнулись объекты или нет для игры очень надо ?
Ответ:
Автор ответа: Roman 'Devil' Yuakovlev
2) Функция instr и дальше selstart, sellenght
3) Проверять их координаты... или заплатить мне 1000 долларов, я буду проверять за него... Конкретнее вопрос можно?
Вопрос:
1)Как реально прописать прогу в реестре ?
2)Как найти в richtextbox слова какие выберешь ну там и изменить их цвет ?
3)Как сделать так чтоб комп проверял столкнулись объекты или нет для игры очень надо ?
Ответ:
Автор ответа: Igoryk
2. Ну например ищешь в тексте слово "комп", для этого используй следующий код:
MyWord="комп" ' Это слово которое нужно найти
MyColor=RGB(255,0,0) ' Каким цветом выделить слово
FindText=Instr(RichTextBox1.Text,MyWord) 'Ищет слово в тексте
If FindText<>0 Then 'Если удалось что-то найти
RichTextBox1.SelStart = FindText 'Начинаем помечать слово
RichTextBox1.SelLength = Len(MyWord) 'Заканчиваем
RichTextBox1.SelColor = MyColor 'Меняем цвет текста
RichTextBox1.SelLength = 0 'Снимаем выделение
End IF
3. Если я тебя правильно понял, то посмотри на http://www.igoryksoft.narod.ru/vb/vb12.htm
Вопрос:
1)Как реально прописать прогу в реестре ?
2)Как найти в richtextbox слова какие выберешь ну там и изменить их цвет ?
3)Как сделать так чтоб комп проверял столкнулись объекты или нет для игры очень надо ?
Ответ:
Автор ответа: Ревягин_Алексей
dim pos as long
Private Function _ПОИСК_СЛОВ_(slovo as string)
With RTFBox
if pos=0 then
pos = .Find(slovo, 0, Len(.Text))
else
pos = .Find(slovo, pos + 1, Len(.Text))
endif
If pos = -1 Then
pos = 0
i = i + 1
Else
.SelStart = pos
.SelLength = Len(slovo)
.SelColor = ЦВЕТ_КАКИМ_НАДО_ВЫДЕЛИТЬ_НАЙДЕНОЕ_СЛОВО
.SelLength=0
End If
End With
End Function
Вопрос:
Подскажите, как отправить готовый отчет ия Access или Exele по почте (адрес всегда один и тот же)
Ответ:
Автор ответа: Сергей
для отправки книги EXEL по Email пользуюсь функцией:
Application.Dialogs(xlDialogSendMail).Show ("adress@yahoo.com")
но при этом адрес получателя должен быть, также, записан в адресную книгу.
Вопрос:
Я подключаюсь к базе данных .mdb используя ADODB. Одно из полей "word" таблицы "Catalog" содержит данные типа OLE-объект. Там находятся файлы *.doc. Каким образом я смогу получить их содержимое (хотябы добраться до Object.Words.Item(#).Text)?
Ответ:
Автор ответа: Н. Шувалов
Посмотри по этому адресу:
http://vbnet.ru/faq/showtopic.asp?id=133
Можете заполнить эту форму, либо отослать вопрос СЮДА
Форма для добавления нового вопроса в этот раздел. Информация отсылается по E-mail владельцу сайта.
наверх
 |
ADO и Visual Basic. Руководство разработчикаВ книге описано использование технологии доступа к данным (ADO) с помощью основного инструмента разработки приложений Microsoft - Visual Basic 6.0. Из книги вы узнаете, как можно исследовать источники данных при помощи окна Data View, как создавать формы для ввода и запроса данных, используя связанные элементы управления, и подсоединяться к источникам данных со сложной иерархической структурой средствами Data Environment. Далее вы изучите, как можно, используя Data Report, представлять информацию в форме, подходящей для печати, или как следует исполнять некоторые, наиболее широко распространенные задачи, связанные с обработкой данных, используя ADO внутри кода Visual Basic. В последних главах книги рассмотрены дополнительные операции, используемые в коде, в том числе формирование данных, для создания иерархических наборов записей, применение ADO в сети Internet и даже создание собственных источников данных. Чтобы более полно использовать средства ADO для извлечения информации из различных источников, в приложении к книге вы найдете справочник по языку SQL, в котором обсуждаются основы работы с оператором SQL SELECT.Автор: Гандерлой М. Издательсвто: Энтроп, Век Год издания: 2001 Кол-во страниц: 336 Стоимость: 177 р. Формат: 70х100/16 Переплёт: мягкий |
 |
Excel, VBA, Internet в экономике и финансахКнига является руководством по использованию Microsoft Excel, разработке офисных бизнес-приложений средствами VBA и конструированию Web-страниц на базе DHTML и VBScript. Рассматриваются приемы создания отчетной финансовой и экономической документации средствами MS Excel, способы анализа и обработки собранной информации для принятия на ее основе оптимального решения; даются ответы на вопросы, которые возникают у программиста при разработке автоматизированных и интегрированных систем с помощью VBA; описываются особенности конструирования пользовательских элементов управления ActiveX, а также написания Windows-сценариев. Большое внимание уделено принципам создания интерактивных Web-страниц, виртуальных каталогов и магазинов. Книга содержит уникальную коллекцию типичных примеров. Почти каждая глава заканчивается списком упражнений, способствующих закреплению материалаАвтор: Гарнаев А Издательсвто: BHV - Санкт - Петербург Год издания: 2001 Кол-во страниц: 816 Стоимость: 230 р. Формат: 70х100/16 Переплёт: мягкий |
 |
MCSD. Сертификационный экзамен 70-175. Разработка распределенных приложений на Visual Basic 6.0. Учебный курс (+ CD-ROM)Настоящий учебный курс рекомендован корпорацией Microsoft как официальное пособие для подготовки к экзамену 70-175 «Designing and Implementing Distributed Applications with Microsoft Visual Basic 6.0» по программе сертификации разработчиков программных решений на основе продуктов Microsoft (Microsoft Certified Solutions Developer, MCSD). Эта книга познакомит Вас с основными понятиями, концепциями и методами, необходимыми для разработок распределенных программных решений на базе Visual Basic 6.0.Автор: MCSD Training Kit Издательсвто: Русская Редакция Год издания: 2000 Кол-во страниц: 400 Стоимость: 272 р. Формат: 70х100/1670х100/16 Переплёт: мягкий |
 |
Microsoft Visual Basic 5.0В книге рассматривается новая пятая версия Microsoft Visual Basic - языка программирования, являющегося фактическим стандартом визуального проектирования приложений. Описываются общие черты Visual Basic, реализованные в нем концепции объектно-ориентированного программирования, среда разработки (IDE). Далее рассматривается объектно-ориентированная модель Visual Basic и доступные разработчику объектные компоненты. Подробно описываются технологии программирования на языке Visual Basic и SQL, отладка и оптимизация кода приложения, вопросы компиляции исполняемых модулей. В последующих главах освещаются практические вопросы построения приложений - работа с текстом и графикой, механизмы доступа и управления данными, работа с внешними базами данных и создание приложений клиент/сервер. Книга предназначена для широкого круга программистов, работающих в области обработки данных и информационных систем.Автор: Шмидт В Издательсвто: ABF Год издания: 1997 Кол-во страниц: 688 Стоимость: 85 р. Формат: 84x108/16 Переплёт: мягкий |
 |
Microsoft Visual Basic 6.0Нет описанияАвтор: Лабор В, Макарчук Д Издательсвто: нет данных Год издания: 2001 Кол-во страниц: 160 Стоимость: 60 р. Формат: 70х100/16 Переплёт: мягкий |
 |
Microsoft Visual Basic 6.0. Мастерская разработчика (+ CD-ROM)Книга состоит из 3 частей (34 главы) и предметного указателя. Написанная живо и доходчиво, она позволит освоить множество полезных приемов программирования, в том числе объектно-ориентированного, и научит, как создавать 32-разрядные приложения для Windows 95/98 и Windows NT — от экранных заставок до программ, ориентированных на Интернет. Кроме того, Вы узнаете, как расширить возможности языка за счет функций Win32 API и воспользоваться преимуществами технологии ActiveX.Автор: Джон Кларк Крейг, Джефф Уэбб Издательсвто: Русская Редакция Год издания: 2001 Кол-во страниц: 720 Стоимость: 272 р. Формат: 70х100/16 Переплёт: твёрдый |
 |
VB Script и ActiveXКнига предназначена для разработчиков Web - приложений на языке VBScript, желающих повысить свой профессиональный уровень и стать экспертами в этой области. В ней подробно рассказывается о новых возможностях VBScript, включая использование именованных констант, функций, переменных и коллекций, приводится вся необходимая информация о технологии ActiveX, принципах взаимодействия VBScript и Visual Basic при создании приложений, работающих на сервере. Прочитав эту книгу, вы научитесь использовать звуковые эффекты, создавать анимированную графику, строить формы для ввода данных, узнаете, как с помощью VBScript создать в Web электронный магазин и отслеживать число посетителей и деланные ими покупки. Вы даже сумеете написать увлекательную мультимедийную игру для Web.Автор: Скотт Палмер Издательсвто: Питер Год издания: 1999 Кол-во страниц: 368 Стоимость: 94 р. Формат: 70х100/16 Переплёт: мягкий |
 |
VBA 2000. СамоучительВ книге содержится краткий курс по использованию языка и системы VBA для Word и Excel 2000. Книга предназначена для начинающих программировать в среде Windows 95/98 с использованием в качестве базовых таких объектов Word и Excel, как документы, рабочие книги, листы и так далее. Материала книги достаточно для создания как простых макросов, помогающих автоматизировать рутинную повторяющуюся работу над документами и электронными таблицами, так и для разработки достаточно сложных приложений, обрабатывающих данные в диалоговых окнах, обеспечивающих пользователя самыми современными интерфейсными средствами.Автор: Кузьменко В Издательсвто: Бином Год издания: 2000 Кол-во страниц: 416 Стоимость: 116 р. Формат: 70х100/16 Переплёт: мягкий |
 |
Visual Basic 6 Desktop. Экзамен 70-176Книги серии `Экзамен – экстерном` представляют собой удобные, сжатые, хорошо структурированные конспекты для подготовки к сдаче сертификационных экзаменов на звание Microsoft Certified Solution Developer. Книга `Visual Basic 6.0 Desktop. Экзамен 70-176` содержит только действительно необходимый материал, типовые вопросы с ответами и пример экзамена. Возможно, некоторые подходы, применяемые автором, покажутся вам не совсем привычными - не удивляйтесь: это не учебник по Visual Basic; организация материала в этой книге призвана максимально облегчить задачу экзаменуемого. Учтите, что в ряде случаев экзаменационные вопросы выходят за рамки тем, отраженных в документации по Visual Basic, а иной раз правильные ответы на них даже входят в противоречие с `официальной` информацией.Автор: Майкл Макдоналд Издательсвто: Питер Год издания: 2001 Кол-во страниц: 608 Стоимость: 123 р. Формат: 60x90/16 Переплёт: мягкий |
 |
Visual Basic 6. Руководство разработчика (+ CD-ROM)Эта книга, написанная известным специалистом и неутомимым пропагандистом Visual Basic, представляет собой прекрасный путеводитель по одному из наиболее популярных визуальных средств разработки Windows-приложений. Подробно освещаются такие ключевые темы программирования на Visual Basic, как проектирование и использование элементов ActiveX, программирование баз данных и разработка Web-приложений. Несомненный интерес представляют главы, посвященные работе с графикой. Большое количество тщательно продуманных примеров облегчает восприятие материала. Подбор материала и стиль изложения делают издание интересным и полезным для программистов разных уровней.Автор: Евангелос Петрусос Издательсвто: BHV, Ирина, SYBEX Inc Год издания: 2000 Кол-во страниц: 1072 Стоимость: 267 р. Формат: 70x100/32 Переплёт: твёрдый |
Остальные книги о VB можно найти здесь.
наверх
Основы работы с формой
Максимальные размеры формы при определенном разрешении экрана (в пикселях)
Разрешение - Размеры: высота/ширина
640x480 - 7200 / 9600
800x600 - 9000 / 12000
1024x768 - 11520 / 15360
Форма без заголовка
Если вы хотите, чтобы на форме отсутствовало
поле заголовка, измените свойства формы:
Caption = ""
ControlBox = False
Отцентрировать контрол на форме
Добавьте 1 CommandButton. При нажатии на кнопку, она переместится в центр вашей формы. Все кнопки вы можете использовать любой контрол.
Private Sub Command1_Click()
'Replace all the 'Command1' below with the name of the control you want to center.
Command1.Left = (Form1.Width - Command1.Width) / 2
Command1.Top = (Form1.Height / 2 - Command1.Height)
End Sub
наверх
Заблокировать кнопку X на форме
'Вариант 1
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Const SC_CLOSE = &HF060
Const MF_BYCOMMAND = &H0
Public Sub DisableXbutton(ByVal frmHwnd As Long)
Dim hMenu As Long
hMenu = GetSystemMenu(frmHwnd, 0&)
If hMenu Then
Call DeleteMenu(hMenu, SC_CLOSE, MF_BYCOMMAND)
DrawMenuBar (frmHwnd)
End If
End Sub
Private Sub Form_Load()
DisableXbutton (Me.hwnd)
End Sub
'Вариант 2
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Const MF_BYPOSITION = &H400&
Public Sub DisableCloseButton(F As Form)
Dim hSysMenu As Long
hSysMenu = GetSystemMenu(F.hwnd, 0)
RemoveMenu hSysMenu, 6, MF_BYPOSITION
RemoveMenu hSysMenu, 5, MF_BYPOSITION
End Sub
Private Sub Command1_Click()
Call DisableCloseButton(Form1)
End Sub
наверх
Сделать вашу форм поверх всех
Добавьте 2 CommandButton (под именем Command1 и Command2). Когда вы нажимаете первую кнопку, ваша форма поверх всех
Private Declare Function SetWindowPos Lib "user32" (ByVal h%, ByVal hb%, ByVal x%, ByVal Y%, ByVal cx%, ByVal cy%, ByVal F%) As Integer
Const SWP_NOMOVE = 2
Const SWP_NOSIZE = 1
Const flags = SWP_NOMOVE Or SWP_NOSIZE
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Private Sub Command1_Click()
res = SetWindowPos(Form1.hwnd, HWND_TOPMOST, 0, 0, 0, 0, flags) 'Форма on-top
End Sub
Private Sub Command2_Click()
res = SetWindowPos(Form1.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, flags) 'Форма non-on-top
End Sub
наверх
Создать градиент-Title Bar
Добавьте модуль в ваш проект
'КОД ФОРМЫ
Private Sub Form_Load()
GradForceColors = True
'Замените 'True' на 'False' если хотите получить горизонтальную прорисовку
GradVerticalGradient = True
'Установить цвет активного заголовка
GradForcedText = vbWhite
'Замените две установки цвета ниже для изменения цвета фона активного заголовка
GradForcedFirst = &H800000
GradForcedSecond = &H8000
'Установить цвет неактивного заголовка
GradForcedTextA = &HC0C0C0
'Замените две установки цвета ниже для изменения цвета фона неактивного заголовка
GradForcedFirstA = vbBlack
GradForcedSecondA = vbBlue
GradientGetCapsFont
GradientForm Me
End Sub
Private Sub Form_Unload(Cancel As Integer)
GradientReleaseForm Me
End Sub
'КОД МОДУЛЯ
Public GradForceColors As Boolean
Public GradVerticalGradient As Boolean
Public GradForcedText As Long, GradForcedTextA As Long
Public GradForcedFirst As Long, GradForcedSecond As Long
Public GradForcedFirstA As Long, GradForcedSecondA As Long
Dim GradhWnd As Long, GradIcon As Long
Dim DrawDC As Long, tmpDC As Long
Dim hRgn As Long
Dim tmpGradFont As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_WNDPROC = (-4)
Private Const GWL_STYLE = (-16)
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Const LF_FACESIZE = 32
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(1 To LF_FACESIZE) As Byte
End Type
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SPI_GETNONCLIENTMETRICS = 41
Private Type NONCLIENTMETRICS
cbSize As Long
iBorderWidth As Long
iScrollWidth As Long
iScrollHeight As Long
iCaptionWidth As Long
iCaptionHeight As Long
lfCaptionFont As LOGFONT
iSMCaptionWidth As Long
iSMCaptionHeight As Long
lfSMCaptionFont As LOGFONT
iMenuWidth As Long
iMenuHeight As Long
lfMenuFont As LOGFONT
lfStatusFont As LOGFONT
lfMessageFont As LOGFONT
End Type
Dim CaptionFont As LOGFONT
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function IsZoomed Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Const IDC_SIZENS = 32645&
Private Const IDC_SIZEWE = 32644&
Private Const IDC_SIZENWSE = 32642&
Private Const IDC_SIZENESW = 32643&
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Const WS_BORDER = &H800000
Private Const WS_CAPTION = &HC00000
Private Const WS_DLGFRAME = &H400000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_OVERLAPPED = &H0&
Private Const WS_SYSMENU = &H80000
Private Const WS_THICKFRAME = &H40000
Private Const WS_POPUP = &H80000000
Private Const WS_SIZEBOX = WS_THICKFRAME
Private Const WS_TILED = WS_OVERLAPPED
Private Const WS_VISIBLE = &H10000000
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function OffsetClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal Y As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal Y As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hDC As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_SINGLELINE = &H20
Private Const DT_VCENTER = &H4
Private Const DT_END_ELLIPSIS = &H8000&
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long) As Long
Private Declare Function GetClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long) As Long
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 Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Const COLOR_ACTIVECAPTION = 2
Private Const COLOR_CAPTIONTEXT = 9
Private Const COLOR_INACTIVECAPTION = 3
Private Const COLOR_INACTIVECAPTIONTEXT = 19
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Const TRANSPARENT = 1
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXBORDER = 5
Private Const SM_CXDLGFRAME = 7
Private Const SM_CXFRAME = 32
Private Const SM_CXICON = 11
Private Const SM_CXSMSIZE = 30
Private Const SM_CYBORDER = 6
Private Const SM_CYCAPTION = 4
Private Const SM_CYDLGFRAME = 8
Private Const SM_CYFRAME = 33
Private Const SM_CYICON = 12
Private Const SM_CYMENU = 15
Private Const SM_CYSMSIZE = 31
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function ExcludeClipRect Lib "gdi32" (ByVal hDC As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DrawFrameControl Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal un1 As Long, ByVal un2 As Long) As Long
Private Const DFC_CAPTION = 1
Private Const DFCS_CAPTIONRESTORE = &H3
Private Const DFCS_CAPTIONMIN = &H1
Private Const DFCS_CAPTIONMAX = &H2
Private Const DFCS_CAPTIONHELP = &H4
Private Const DFCS_CAPTIONCLOSE = &H0
Private Const DFCS_INACTIVE = &H100
Private Const WM_SIZE = &H5
Private Const WM_SETCURSOR = &H20
Private Const WM_GETICON = &H7F
Private Const WM_SETICON = &H80
Private Const WM_NCACTIVATE = &H86
Private Const WM_MDIACTIVATE = &H222
Private Const WM_KILLFOCUS = &H8
Private Const WM_MOUSEACTIVATE = &H21
Private Const WM_MDIGETACTIVE = &H229
Private Const MA_ACTIVATE = 1
Private Const WM_SETTEXT = &HC
Private Const WM_NCPAINT = &H85
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_NCRBUTTONDOWN = &HA4
Private Const WM_SYSCOMMAND = &H112
Private Const WM_INITMENUPOPUP = &H117
Private Const SC_MOUSEMENU = &HF090&
Private Const SC_MOVE = &HF010&
Private Const HTCAPTION = 2
Private Const HTSYSMENU = 3
Private Const HTLEFT = 10
Private Const HTRIGHT = 11
Private Const HTTOP = 12
Private Const HTTOPLEFT = 13
Private Const HTTOPRIGHT = 14
Private Const HTBOTTOM = 15
Private Const HTBOTTOMLEFT = 16
Private Const HTBOTTOMRIGHT = 17
Private Function LoWord(LongIn As Long) As Integer
If (LongIn And &HFFFF&) > &H7FFF Then
LoWord = (LongIn And &HFFFF&) - &H10000
Else
LoWord = LongIn And &HFFFF&
End If
End Function
Private Sub GetColors(IsActive As Boolean, LColor As Long, RColor As Long)
If IsActive Then
If GradForceColors Then
LColor = GradForcedFirst
RColor = GradForcedSecond
Else
LColor = vbBlack
RColor = GetSysColor(COLOR_ACTIVECAPTION)
End If
Else
If GradForceColors Then
LColor = GradForcedFirstA
RColor = GradForcedSecondA
Else
LColor = vbBlack
RColor = GetSysColor(COLOR_INACTIVECAPTION)
End If
End If
End Sub
Public Sub GradientGetCapsFont()
Dim NCM As NONCLIENTMETRICS
Dim lfNew As LOGFONT
NCM.cbSize = Len(NCM)
Call SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, NCM, 0)
CaptionFont = NCM.lfCaptionFont
End Sub
Private Sub GetCaptionRect(hWnd As Long, rct As RECT)
Dim XBorder As Long
Dim fStyle As Long
Dim YHeight As Long
YHeight = GetSystemMetrics(SM_CYCAPTION)
fStyle = GetWindowLong(hWnd, GWL_STYLE)
Select Case fStyle And &H80
Case &H80
XBorder = GetSystemMetrics(SM_CXDLGFRAME)
Case Else
XBorder = GetSystemMetrics(SM_CXFRAME)
End Select
rct.Left = XBorder
rct.Right = XBorder
rct.Top = XBorder
rct.Bottom = rct.Top + YHeight - 1
End Sub
Private Sub GradateColors(Colors() As Long, ByVal Color1 As Long, ByVal Color2 As Long)
Dim i As Long
Dim dblR As Double, dblG As Double, dblB As Double
Dim addR As Double, addG As Double, addB As Double
Dim bckR As Double, bckG As Double, bckB As Double
dblR = CDbl(Color1 And &HFF)
dblG = CDbl(Color1 And &HFF00&) / 255
dblB = CDbl(Color1 And &HFF0000) / &HFF00&
bckR = CDbl(Color2 And &HFF&)
bckG = CDbl(Color2 And &HFF00&) / 255
bckB = CDbl(Color2 And &HFF0000) / &HFF00&
addR = (bckR - dblR) / UBound(Colors)
addG = (bckG - dblG) / UBound(Colors)
addB = (bckB - dblB) / UBound(Colors)
For i = 0 To UBound(Colors)
dblR = dblR + addR
dblG = dblG + addG
dblB = dblB + addB
If dblR > 255 Then dblR = 255
If dblG > 255 Then dblG = 255
If dblB > 255 Then dblB = 255
If dblR < 0 Then dblR = 0
If dblG < 0 Then dblG = 0
If dblG < 0 Then dblB = 0
Colors(i) = RGB(dblR, dblG, dblB)
Next
End Sub
Private Function DrawGradient(ByVal Color1 As Long, ByVal Color2 As Long) As Long
Dim i As Long
Dim DestWidth As Long, DestHeight As Long
Dim StartPnt As Long, EndPnt As Long
Dim PixelStep As Long, XBorder As Long
Dim WndRect As RECT
Dim OldFont As Long
Dim fStyle As Long, fText As String
Dim SMSize As Long, SMSizeY As Long
On Error Resume Next
SMSize = GetSystemMetrics(SM_CXSMSIZE)
SMSizeY = GetSystemMetrics(SM_CYSMSIZE)
GetWindowRect GradhWnd, WndRect
With WndRect
DestWidth = .Right - .Left
End With
DestHeight = GetSystemMetrics(SM_CYCAPTION)
fText = Space$(255)
Call GetWindowText(GradhWnd, fText, 255)
fText = Trim$(fText)
fStyle = GetWindowLong(GradhWnd, GWL_STYLE)
Select Case fStyle And &H80
Case &H80
XBorder = GetSystemMetrics(SM_CXDLGFRAME)
DestWidth = (DestWidth - XBorder)
Case Else
XBorder = GetSystemMetrics(SM_CXFRAME)
DestWidth = DestWidth - XBorder
End Select
StartPnt = XBorder
EndPnt = XBorder + DestWidth - 4
Dim rct As RECT
Dim hBr As Long
With rct
If Not GradVerticalGradient Then
PixelStep = DestWidth \ 8
ReDim Colors(PixelStep) As Long
GradateColors Colors(), Color1, Color2
.Top = XBorder
.Left = XBorder
.Right = XBorder + (DestWidth \ PixelStep)
.Bottom = (XBorder + DestHeight - 1)
If (fStyle And &H80) = &H80 Then EndPnt = EndPnt + 1
For i = 0 To PixelStep - 1
hBr = CreateSolidBrush(Colors(i))
FillRect DrawDC, rct, hBr
DeleteObject hBr
OffsetRect rct, (DestWidth \ PixelStep), 0
If i = PixelStep - 2 Then .Right = EndPnt
Next
Else
PixelStep = DestHeight \ 1
ReDim Colors(PixelStep) As Long
GradateColors Colors(), Color2, Color1
.Top = XBorder
.Left = XBorder
If (fStyle And &H80) = &H80 Then
.Right = (XBorder * 2) + DestWidth + 2
Else
.Right = (XBorder * 2) + DestWidth
End If
.Bottom = XBorder + (DestHeight \ PixelStep)
For i = 0 To PixelStep - 1
hBr = CreateSolidBrush(Colors(i))
FillRect DrawDC, rct, hBr
DeleteObject hBr
OffsetRect rct, 0, (DestHeight \ PixelStep)
If i = PixelStep - 2 Then .Bottom = XBorder + (DestHeight - 1)
.Bottom = XBorder + (DestHeight - 1)
Next
End If
.Top = XBorder
If GradIcon <> 0 Then
.Left = XBorder + SMSize + 2
DrawIconEx DrawDC, XBorder + 1, XBorder + 1, GradIcon, SMSize - 2, SMSize - 2, ByVal 0&, ByVal 0&, 2
Else
.Left = XBorder
End If
tmpGradFont = CreateFontIndirect(CaptionFont)
OldFont = SelectObject(DrawDC, tmpGradFont)
SetBkMode DrawDC, TRANSPARENT
If GradForceColors Then
If Color1 = GradForcedFirst Then
SetTextColor DrawDC, GradForcedText
Else
SetTextColor DrawDC, GradForcedTextA
End If
Else
If Color2 = GetSysColor(COLOR_ACTIVECAPTION) Then
SetTextColor DrawDC, GetSysColor(COLOR_CAPTIONTEXT)
Else
SetTextColor DrawDC, GetSysColor(COLOR_INACTIVECAPTIONTEXT)
End If
End If
.Left = .Left + 2
.Right = .Right - 10
DrawText DrawDC, fText, Len(fText) - 1, rct, DT_SINGLELINE Or DT_END_ELLIPSIS Or DT_VCENTER
SelectObject DrawDC, OldFont
DeleteObject tmpGradFont
tmpGradFont = 0
Dim frct As RECT
If (fStyle And WS_SYSMENU) = WS_SYSMENU Then
Dim CurMaxPic As Long
If IsZoomed(GradhWnd) Then
CurMaxPic = DFCS_CAPTIONRESTORE
Else
CurMaxPic = DFCS_CAPTIONMAX
End If
With frct
.Right = DestWidth - 2
.Left = .Right - SMSize + 2
.Top = XBorder + 2
.Bottom = .Top + (DestHeight - 5)
End With
DrawFrameControl DrawDC, frct, DFC_CAPTION, DFCS_CAPTIONCLOSE
OffsetRect frct, -(SMSize), 0
If (fStyle And WS_MAXIMIZEBOX) = WS_MAXIMIZEBOX And (fStyle And WS_MINIMIZEBOX) = WS_MINIMIZEBOX Then
DrawFrameControl DrawDC, frct, DFC_CAPTION, CurMaxPic
OffsetRect frct, -(SMSize) + 2, 0
DrawFrameControl DrawDC, frct, DFC_CAPTION, DFCS_CAPTIONMIN
ElseIf (fStyle And WS_MAXIMIZEBOX) = WS_MAXIMIZEBOX Then
DrawFrameControl DrawDC, frct, DFC_CAPTION, CurMaxPic
OffsetRect frct, -(SMSize) + 2, 0
DrawFrameControl DrawDC, frct, DFC_CAPTION, DFCS_CAPTIONMIN Or DFCS_INACTIVE
ElseIf (fStyle And WS_MINIMIZEBOX) = WS_MINIMIZEBOX Then
DrawFrameControl DrawDC, frct, DFC_CAPTION, CurMaxPic Or DFCS_INACTIVE
OffsetRect frct, -(SMSize) + 2, 0
DrawFrameControl DrawDC, frct, DFC_CAPTION, DFCS_CAPTIONMIN
End If
End If
.Left = XBorder
.Right = .Right + 12
If tmpDC <> 0 Then
BitBlt tmpDC, .Left, .Top, .Right - .Left - 10, .Bottom - .Top, DrawDC, .Left, .Top, vbSrcCopy
ExcludeClipRect tmpDC, XBorder, XBorder, DestWidth, XBorder(DestHeight - 1)
End If
End With
End Function
Public Function GradientCallback(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim OldGradProc As Long
Dim OldBMP As Long, NewBMP As Long
Dim rcWnd As RECT
Dim tmpFrm As Form
Dim tmpCol1 As Long, tmpCol2 As Long
Static GettingIcon As Boolean
GradhWnd = hWnd
OldGradProc = GetProp(GradhWnd, "OldMeProc")
If Not GettingIcon Then
GettingIcon = True
GradIcon = SendMessage(hWnd, WM_GETICON, 0, ByVal 0&)
GettingIcon = False
End If
Select Case wMsg
Case WM_NCACTIVATE, WM_MDIACTIVATE, WM_KILLFOCUS, WM_MOUSEACTIVATE
GetWindowRect GradhWnd, rcWnd
tmpDC = GetWindowDC(GradhWnd)
DrawDC = CreateCompatibleDC(tmpDC)
NewBMP = CreateCompatibleBitmap(tmpDC, rcWnd.Right - rcWnd.Left, 50)
OldBMP = SelectObject(DrawDC, NewBMP)
With rcWnd
hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
SelectClipRgn tmpDC, hRgn
OffsetClipRgn tmpDC, -.Left, -.Top
End With
If wMsg = WM_KILLFOCUS And GetParent(GradhWnd) <> 0 Then
GetColors False, tmpCol1, tmpCol2
ElseIf wMsg = WM_NCACTIVATE And wParam And _
(GetParent(GradhWnd) = 0) Then
GetColors True, tmpCol1, tmpCol2
ElseIf wMsg = WM_NCACTIVATE And wParam = 0 And (GetParent(GradhWnd) = 0) Then
GetColors False, tmpCol1, tmpCol2
ElseIf wParam = GradhWnd And GetParent(GradhWnd) <> 0 Then
GetColors False, tmpCol1, tmpCol2
ElseIf SendMessage(GetParent(GradhWnd), WM_MDIGETACTIVE, 0, 0) = GradhWnd Then
GetColors True, tmpCol1, tmpCol2
ElseIf GetActiveWindow() = GradhWnd Then
GetColors True, tmpCol1, tmpCol2
Else
GetColors False, tmpCol1, tmpCol2
End If
DrawGradient tmpCol1, tmpCol2
SelectObject DrawDC, OldBMP
DeleteObject NewBMP
DeleteDC DrawDC
OffsetClipRgn tmpDC, rcWnd.Left, rcWnd.Top
GetClipRgn tmpDC, hRgn
If wMsg = WM_MOUSEACTIVATE Then
GradientCallback = MA_ACTIVATE
Else
GradientCallback = 1
End If
ReleaseDC GradhWnd, tmpDC
DeleteObject hRgn
tmpDC = 0
Exit Function
Case WM_SETTEXT, WM_NCPAINT, WM_NCLBUTTONDOWN, _
WM_NCRBUTTONDOWN, WM_SYSCOMMAND, WM_INITMENUPOPUP
GetWindowRect GradhWnd, rcWnd
tmpDC = GetWindowDC(GradhWnd)
DrawDC = CreateCompatibleDC(tmpDC)
NewBMP = CreateCompatibleBitmap(tmpDC, rcWnd.Right - rcWnd.Left, 50)
OldBMP = SelectObject(DrawDC, NewBMP)
With rcWnd
hRgn = CreateRectRgn(.Left, .Top, .Right, .Bottom)
SelectClipRgn tmpDC, hRgn
OffsetClipRgn tmpDC, -.Left, -.Top
End With
If (GetActiveWindow() = GradhWnd) Then
GetColors True, tmpCol1, tmpCol2
ElseIf SendMessage(GetParent(GradhWnd), WM_MDIGETACTIVE, 0, 0) = GradhWnd Then
GetColors True, tmpCol1, tmpCol2
Else
GetColors False, tmpCol1, tmpCol2
End If
DrawGradient tmpCol1, tmpCol2
SelectObject DrawDC, OldBMP
DeleteObject NewBMP
DeleteDC DrawDC
OffsetClipRgn tmpDC, rcWnd.Left, rcWnd.Top
GetClipRgn tmpDC, hRgn
GradientCallback = CallWindowProc(OldGradProc, hWnd, WM_NCPAINT, hRgn, lParam)
ReleaseDC GradhWnd, tmpDC
DeleteObject hRgn
tmpDC = 0
If wMsg = (WM_NCLBUTTONDOWN And wParam <> HTSYSMENU And wParam <> HTCAPTION) Or wMsg = _
(WM_SYSCOMMAND And Not (wParam = SC_MOUSEMENU)) Then
GetCaptionRect GradhWnd, rcWnd
ExcludeClipRect tmpDC, rcWnd.Left, rcWnd.Top, rcWnd.Right, rcWnd.Bottom
ElseIf wMsg = WM_NCLBUTTONDOWN And wParam = HTCAPTION Then
If IsZoomed(GradhWnd) = 0 Then
GradientCallback = SendMessage(GradhWnd, WM_SYSCOMMAND, SC_MOVE, ByVal 0&)
End If
Exit Function
Else
Exit Function
End If
Case WM_SIZE
If hWnd = GradhWnd Then
SendMessage GradhWnd, WM_NCPAINT, 0, 0
End If
Case WM_SETCURSOR
Select Case LoWord(lParam)
Case HTTOP, HTBOTTOM
SetCursor LoadCursor(ByVal 0&, IDC_SIZENS)
Case HTLEFT, HTRIGHT
SetCursor LoadCursor(ByVal 0&, IDC_SIZEWE)
Case HTTOPLEFT, HTBOTTOMRIGHT
SetCursor LoadCursor(ByVal 0&, IDC_SIZENWSE)
Case HTTOPRIGHT, HTBOTTOMLEFT
SetCursor LoadCursor(ByVal 0&, IDC_SIZENESW)
Case Else
GoTo JustCallBack
End Select
GradientCallback = 1
Exit Function
End Select
JustCallBack:
GradientCallback = CallWindowProc(OldGradProc, hWnd, wMsg, wParam, lParam)
End Function
Public Sub GradientForm(frm As Form)
Dim tmpProc As Long
tmpProc = SetWindowLong(frm.hWnd, GWL_WNDPROC, AddressOf GradientCallback)
SetProp frm.hWnd, "OldMeProc", tmpProc
End Sub
Public Sub GradientReleaseForm(frm As Form)
Dim tmpProc As Long
tmpProc = GetProp(frm.hWnd, "OldMeProc")
RemoveProp frm.hWnd, "OldMeProc"
If tmpProc = 0 Then Exit Sub
SetWindowLong frm.hWnd, GWL_WNDPROC, tmpProc
End Sub
наверх
Спрятать/показать панель заголовка
Добавьте 2 CommandButton на форму
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_SYSMENU = &H80000
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Enum ESetWindowPosStyles
SWP_SHOWWINDOW = &H40
SWP_HIDEWINDOW = &H80
SWP_FRAMECHANGED = &H20
SWP_NOACTIVATE = &H10
SWP_NOCOPYBITS = &H100
SWP_NOMOVE = &H2
SWP_NOOWNERZORDER = &H200
SWP_NOREDRAW = &H8
SWP_NOREPOSITION = SWP_NOOWNERZORDER
SWP_NOSIZE = &H1
SWP_NOZORDER = &H4
SWP_DRAWFRAME = SWP_FRAMECHANGED
HWND_NOTOPMOST = -2
End Enum
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Function ShowTitleBar(ByVal bState As Boolean)
Dim lStyle As Long
Dim tR As RECT
GetWindowRect Me.hwnd, tR
lStyle = GetWindowLong(Me.hwnd, GWL_STYLE)
If (bState) Then
Me.Caption = Me.Tag
If Me.ControlBox Then
lStyle = lStyle Or WS_SYSMENU
End If
If Me.MaxButton Then
lStyle = lStyle Or WS_MAXIMIZEBOX
End If
If Me.MinButton Then
lStyle = lStyle Or WS_MINIMIZEBOX
End If
If Me.Caption = "" Then
lStyle = lStyle Or WS_CAPTION
End If
Else
Me.Tag = Me.Caption
Me.Caption = ""
lStyle = lStyle And Not WS_SYSMENU
lStyle = lStyle And Not WS_MAXIMIZEBOX
lStyle = lStyle And Not WS_MINIMIZEBOX
lStyle = lStyle And Not WS_CAPTION
End If
SetWindowLong Me.hwnd, GWL_STYLE, lStyle
SetWindowPos Me.hwnd, 0, tR.Left, tR.Top, tR.Right - tR.Left, tR.Bottom - tR.Top, SWP_NOREPOSITION Or SWP_NOZORDER Or SWP_FRAMECHANGED
Me.Refresh
End Function
Private Sub Command1_Click()
ShowTitleBar False
End Sub
Private Sub Command2_Click()
ShowTitleBar True
End Sub
наверх
Определить, загружена ли форма
Добавьте 2 CommandButton и другую форму (Form 2)
Function FormLoadedByName(FormName As String) As Boolean
Dim i As Integer, fnamelc As String
fnamelc = LCase$(FormName)
FormLoadedByName = False
For i = 0 To Forms.Count - 1
If LCase$(Forms(i).Name) = fnamelc Then
FormLoadedByName = True
Exit Function
End If
Next
End Function
Private Sub Command1_Click()
'Замените 'Form2' именем формы, про которую хотите знать...
If FormLoadedByName("Form2") = True Then
MsgBox "Форма загружена"
Else
MsgBox "Форма не загружена"
End If
End Sub
Private Sub Command2_Click()
Load Form2
End Sub
наверх
Мои программы
BalloonMessage for MS Agent
BalloonMessage for Microsoft Agent реализует диалог программы с
пользователем, используя при этом технологию Microsoft Agent. OCX реализует три
типа диалоговых окон: InputBox, MsgBox и MsgLabels.
Автор: Шатрыкин Иван. Соавтор: Павел Сурменок.
наверх
Вопрос/Ответ
Здесь Вы можете задать вопрос, или ответить на уже имеющиеся вопросы.
Вопросы:Автор вопроса: P@Ssword
Ответ ожидается по этому адресу
Может, у кого есть описания протоколов SMTP и POP3? Скиньте мне, plz.
Автор вопроса: Иван
Ответ ожидается по этому адресу
Я яапускаю программу EXE, сделанную во Flash таким обраяом:
Shell App.Path & "\" & "Times.exe", vbMaximizedFocus
Проблема в том, что данная программа не раяварачивает окно на максимальный раямер, а оставляет яаголовок. Подскажите, может кто встречался с такой проблеммой.
Автор вопроса: Саша
Ответ ожидается по этому адресу
Как скопировать текст находящейся вне формы.
Автор вопроса: Velin
Ответ ожидается по этому адресу
Как из Excel сохранить данные в *.dbf файл, но не лист целеком (сохранить как...), а выборочно
Автор вопроса: Samit
Ответ ожидается по этому адресу
Как можно непосредственно из программы отсылать письма без почтового клиента?
Автор вопроса: Pasha
Ответ ожидается по этому адресу
Кто нибудь сталкивался с такой проблемой: если создается соединение между 2 компьютерами через Winsock, а потом закрыть соединение то неудастся соединиться заново пока не закроешь и не откроешь программу ?
Автор вопроса: Xatab
Ответ ожидается по этому адресу
Плиз кто нибудь киньте на мыло программу перекодировщик VB в VC. Очень нужно.
Автор вопроса: sapient
Ответ ожидается по этому адресу
Как средствами VBA for Excel 97 получить список файлов в папке и каким обрпзом их всех последовательно пооткрывать (все *.xls)?
Автор вопроса: Ревягин_Алексей
Ответ ожидается по этому адресу
Вписал этот код:
Option Explicit
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
Private Const MF_BITMAP = &H4&
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Declare Function GetMenuInfo Lib "user32" (ByVal hMenu As Long, lpcmi As tagMENUINFO) As Long
Private Declare Function SetMenuInfo Lib "user32" (ByVal hMenu As Long, lpcmi As tagMENUINFO) As Long
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Private Type tagMENUINFO
cbSize As Long
fMask As Long
dwStyle As Long
cyMax As Long
hbrBack As Long
dwContextHelpID As Long
dwMenuData As Long
End Type
Private Const BS_SOLID = 0
Private Const MIM_APPLYTOSUBMENUS = &H80000000
Private Const MIM_BACKGROUND = &H2
Private Sub Form_Load()
Dim ret As Long
Dim hMenu As Long
Dim hBrush As Long
Dim lbBrushInfo As LOGBRUSH
Dim miMenuInfo As tagMENUINFO
lbBrushInfo.lbStyle = BS_SOLID
lbBrushInfo.lbColor = <цвет>
lbBrushInfo.lbHatch = 0
hBrush = CreateBrushIndirect(lbBrushInfo)
hMenu = GetMenu(Me.hwnd)
miMenuInfo.cbSize = Len(miMenuInfo)
ret = GetMenuInfo(hMenu, miMenuInfo)
miMenuInfo.fMask = MIM_APPLYTOSUBMENUS Or MIM_BACKGROUND
miMenuInfo.hbrBack = hBrush
ret = SetMenuInfo(hMenu, miMenuInfo)
SetMenuItemBitmaps hMenu, GetMenuItemID(GetSubMenu(hMenu, 0), 0), MF_BITMAP, LoadResPicture(101, vbResBitmap), LoadResPicture(101, vbResBitmap)
SetMenuItemBitmaps hMenu, GetMenuItemID(GetSubMenu(hMenu, 0), 1), MF_BITMAP, LoadResPicture(104, vbResBitmap), LoadResPicture(104, vbResBitmap)
SetMenuItemBitmaps hMenu, GetMenuItemID(GetSubMenu(hMenu, 0), 2), MF_BITMAP, LoadResPicture(107, vbResBitmap), LoadResPicture(107, vbResBitmap)
End Sub
1) Почему при каждом вызове PopupMenu или просто при нажатии на кнопку меню появляются разные картинки, имеющиеся у меня на форме, а не которые надо(из файла ресурсов либо с формы(например:
SetMenuItemBitmaps hMenu, GetMenuItemID(GetSubMenu(hMenu, 0), 2), MF_BITMAP,Picture1(0).Picture),Picture1(0).Picture))).
2)как из файла ресурсов читать: GIF'ы, JPG, EXE? (BMP в 5 раз больше по размеру чем соответстующий ему GIF или JPG)
Автор вопроса: rul@langepas.wsnet.ru
Ответ ожидается по этому адресу
Подскажите пожалуйста, как в VB 3.0 использовать WinSoket. А лучше отошлите (если есть) исходничок.
Автор вопроса: Андрей
Ответ ожидается по этому адресу
Пишу прогу на visual basic 5.0, сталкнулся с такой проблемой, как при нажатии на кнопку раявернуть окно выбора документов и нажатии на соответсвующий документ открыть Word.
Автор вопроса: Андрей
Ответ ожидается по этому адресу
Народ требуется ХЕЛП, как в Visual Basic 5.0 сделать чтоб при нажатии, например кнопки Command1 открывалась программа Word. Если можно подробнее об этом.
Автор вопроса: Саша
Ответ ожидается по этому адресу
Что такое hwnd. Что можно сделать зная hwnd чужего окна.
Ответы:
Вопрос:
У меня в базе данных, в одной таблице два поля. В первом названия клипов, во втором названия файлов. Первое поле выводится на ListBox. Как сделать, чтобы при двойном нажатии на какой-либо строке в поле 1, в MediaPlayer загружался файл из соответствующего поля 2?
Ответ:
Автор ответа: Ревягин_Алексей
Помести но форму объект Windows MediaPlayer и обзови его так : MP1
Помести на форму TextBox1 с Visible=false и укажи у него меню
Properties->DataSource=ОБЪЕКТ_КОТОРЫЙ_ПРИСОЕДИНЁН К_БД (напр, Data1)
Properties->DataField=ИМЯ_ПОЛЯ_ГДЕ_ХРАНЯТСЯ_НАЗВАНИЯ_ФАЙЛОВ
и впиши следующий код:
Private Sub ListBox1_dblclick()
'так как у тебя в поле 2 хранятся названия файлов, то
Data1.recordset.absoluteposition=listbox1.listindex
MP1.FileName="_ПУТЬ_ДО_ПАПКИ_С_ФАЙЛАМИ_" & textbox1.text
end sub
Вопрос:
Как мне соядать SETUP не более 2Мб.
Хочу поделиться своей ОЧЕНЬ ПРРОСТОЙ программкой, которая всего лишь соядает текстовый файл, а SETUP к нему весит от 10 до 14 Мб.
Можно как-нибудь справиться с этим?
Понимаю, что эта тема всех достала, но еще никто мне доступно не ответил, все как-то абстрактно.
Ответ:
Автор ответа: Мунгалов Андрей
проблема в том что программы написанные на VB не работают без библиотеки исполнения а она одна для VB6 весит около 1,3 мега + если используешь какие-то ActiveX компоненты они тоже прилагаются к дистрибутиву. поэтому даже если программа делает просто 2+2 она все равно будет много места занимать. выход можно попробовать такой узнать на той машине куда будешь ставить программу, есть библиотека или нет, может ее уже с другой программой ставили. тогда можно просто один EXE файл скопировать.
Вопрос:
Как мне соядать SETUP не более 2Мб.
Хочу поделиться своей ОЧЕНЬ ПРРОСТОЙ программкой, которая всего лишь соядает текстовый файл, а SETUP к нему весит от 10 до 14 Мб.
Можно как-нибудь справиться с этим?
Понимаю, что эта тема всех достала, но еще никто мне доступно не ответил, все как-то абстрактно.
Ответ:
Автор ответа: Иван
С папки System скопируй в директорию где лежит твоя программа следующие файлы: Richtx32.ocx, Msvbvm60.dll. Вот пожалуй и всё.
Ещё очень важно, чтобы на компе, на котором будет ставиться программа, эти файлы лежали либо в одной директории с exe, либо в папке System. Да и ещё на всякий случай замечу, что всегда тебе придётся к своим проектам ложить Msvbvm60.dll, т.к. именно он отвечает за основные элементы VB. А если используешь дополнительные библиотеки, то просто необходимо посмотреть на какой ocx он ссылается. Можно обойтись и без инсталяшки, если использовать программу Fusion, но она немного замедляет работу программы.
Вопрос:
Подскажите плз, как мне безоговорочно переписать существующий файл.
Вот что у меня есть:
excelapp.Workbooks(1).SaveAs FileName:="c:\tmp.xls", AccessMode:=xlShared
Сейчас, если файл c:\tmp.xls есть, то задается вопрос, переписать ли поверх. Мне же надо, чтобы он это не спрашивал, а сразу, молча переписывал.
Ответ:
Автор ответа: Kirill
Чтоб не выводились предупреждения в офисных приложениях надо свойство DisplayAlerts установить в False:
excelapp.DisplayAlerts = False
...
excelapp.Workbooks(1).SaveAs FileName:="c:\tmp.xls", AccessMode:=xlShared
...
excelapp.DisplayAlerts = True
Вопрос:
Подскажите плз, как мне безоговорочно переписать существующий файл.
Вот что у меня есть:
excelapp.Workbooks(1).SaveAs FileName:="c:\tmp.xls", AccessMode:=xlShared
Сейчас, если файл c:\tmp.xls есть, то задается вопрос, переписать ли поверх. Мне же надо, чтобы он это не спрашивал, а сразу, молча переписывал.
Ответ:
Автор ответа: Ревягин_Алексей
в модуле:
Public Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
В процедуре перемещения
Kill ПУТЬ_К_СТАРОМУ_ФАЙЛУ
MoveFile ПУТЬ_К_НОВОМУ_ФАЙЛУ, ПУТЬ_К_СТАРОМУ_ФАЙЛУ
Вопрос:
Какие вояможности VB поддерживает VBScript? или какие не поддерживает?
Ответ:
Автор ответа: DeadMorozzz
VBScript это практечески одно и тоже, что и VB. Т.е. ты можешь без проблем код из VBScript ксопировать в VB и все будет работать. А вот наоборот сложнее из-за объектов =). Короче говоря, то, что ты можешь сделать на VB, ты можешь сделать и на VBScript, за исключением, пожалуй, работы с объектами и формами, но и там можно кое-что придумать...
Вопрос:
Помогите разобраться в функцией "open" чтения данных из файла. Я запутался с типом "input,output,random,binary" и присвоением. Подскажите где можно найти подробнее об этом операторе..
Ответ:
Автор ответа: Igoryk
В общем функция Open служит для работы с файлами.
Open File For Output as 1 - создает файл File, а если таковой был, то очищает его.
Open File For Append as 1 - создает файл, но если файл существует, то открывает его и добавляет в конец запись, которую ты укажешь (Print #1 или Write #1)
Open File For Input as 1 - открывает файл для чтения из него информации.
Open File For Random as 1 - открывает файл для чтения\записи из\в файла типы данных, например
Type My
a as string*4
b as long
End Type
Open File For Random as 1
Get #1,,My
В этом случае 4 байта окажется в My.a, и 4 байта (тип Long) в My.b
Open File For Binary as 1 - делает с файлом то же, что и Random, но используется для двоичного доступа к файлу: например, считать байт определенным номером и т.п.
Вопрос:
Помогите разобраться в функцией "open" чтения данных из файла. Я запутался с типом "input,output,random,binary" и присвоением. Подскажите где можно найти подробнее об этом операторе..
Ответ:
Автор ответа: Filippov Anton Sergeevich
Тут все просто. Формат такой:
open "полное_имя_файла" for <опция> as #n
open - Команда открытия файла;
полное_имя_файла - полное имя файла, который требуется открыть;
<опция> - для чего открывается файл:
input - чтение данных,
output - перезапись файла (если он не существовал, то будет создан)
append - устанавливает счтитывающе-записывающее устройство на конец файла, для добавления данных в конец файла.
#n - номер от #1 до #256. Например первый файл открывается как #1, второй как #2...
После завершения операций ввода-вывода файл следует закрыть
close #n - для закрытия файла с номером N или close для закрытия всех открытых файлов.
вывод:
input #n, "куда_выводить"
#n - номер файла, из которого выводится строка "куда_выводить" - переменная, textbox, label и т.д.
запись:
print #n,"строка"
в качестве "строки" может быть конкретная строка, переменная, текстовое поле, параметр (Например Form1.caption).
Вопрос:
Помогите разобраться в функцией "open" чтения данных из файла. Я запутался с типом "input,output,random,binary" и присвоением. Подскажите где можно найти подробнее об этом операторе..
Ответ:
Автор ответа: Ревягин_Алексей
dim FNumber as integer
Private Sub Command1_click()
fnumber=freefile
open "ПУТЬ_К_НОВОМУ_ФАЙЛУ" for output as fnumber
print #fnumber,"СТРОКИ_В_ФАЙЛЕ"
close fnumber
end sub
Private Sub Command2_click()
fnumber=freefile
open "ПУТЬ_К_СУЩЕСТВУЮЩЕМУ_ФАЙЛУ" for input as fnumber
line input #fnumber, "ПЕРЕМЕННАЯ_В_КОТОРУЮ_СОХРАНЯЕТСЯ_СТРОКА"
close fnumber
end sub
Private Sub Command3_Click()
fnumber=freefile
open "ПУТЬ_К_СУЩЕСТВУЮЩЕМУ_ФАЙЛУ" for append as fnumber
print #fnumber, "СТРОКА_КОТОРАЯ_БУДЕТ_ДОБАВЛЕНА_В_КОНЕЦ_ФАЙЛА"
close fnumber
end sub
Вопрос:
1)Как реально прописать прогу в реестре ?
2)Как найти в richtextbox слова какие выберешь ну там и изменить их цвет ?
3)Как сделать так чтоб комп проверял столкнулись объекты или нет для игры очень надо ?
Ответ:
Автор ответа: Roman 'Devil' Yuakovlev
2) Функция instr и дальше selstart, sellenght
3) Проверять их координаты... или заплатить мне 1000 долларов, я буду проверять за него... Конкретнее вопрос можно?
Вопрос:
1)Как реально прописать прогу в реестре ?
2)Как найти в richtextbox слова какие выберешь ну там и изменить их цвет ?
3)Как сделать так чтоб комп проверял столкнулись объекты или нет для игры очень надо ?
Ответ:
Автор ответа: Igoryk
2. Ну например ищешь в тексте слово "комп", для этого используй следующий код:
MyWord="комп" ' Это слово которое нужно найти
MyColor=RGB(255,0,0) ' Каким цветом выделить слово
FindText=Instr(RichTextBox1.Text,MyWord) 'Ищет слово в тексте
If FindText<>0 Then 'Если удалось что-то найти
RichTextBox1.SelStart = FindText 'Начинаем помечать слово
RichTextBox1.SelLength = Len(MyWord) 'Заканчиваем
RichTextBox1.SelColor = MyColor 'Меняем цвет текста
RichTextBox1.SelLength = 0 'Снимаем выделение
End IF
3. Если я тебя правильно понял, то посмотри на http://www.igoryksoft.narod.ru/vb/vb12.htm
Вопрос:
1)Как реально прописать прогу в реестре ?
2)Как найти в richtextbox слова какие выберешь ну там и изменить их цвет ?
3)Как сделать так чтоб комп проверял столкнулись объекты или нет для игры очень надо ?
Ответ:
Автор ответа: Ревягин_Алексей
dim pos as long
Private Function _ПОИСК_СЛОВ_(slovo as string)
With RTFBox
if pos=0 then
pos = .Find(slovo, 0, Len(.Text))
else
pos = .Find(slovo, pos + 1, Len(.Text))
endif
If pos = -1 Then
pos = 0
i = i + 1
Else
.SelStart = pos
.SelLength = Len(slovo)
.SelColor = ЦВЕТ_КАКИМ_НАДО_ВЫДЕЛИТЬ_НАЙДЕНОЕ_СЛОВО
.SelLength=0
End If
End With
End Function
Вопрос:
Подскажите, как отправить готовый отчет ия Access или Exele по почте (адрес всегда один и тот же)
Ответ:
Автор ответа: Сергей
для отправки книги EXEL по Email пользуюсь функцией:
Application.Dialogs(xlDialogSendMail).Show ("adress@yahoo.com")
но при этом адрес получателя должен быть, также, записан в адресную книгу.
Вопрос:
Я подключаюсь к базе данных .mdb используя ADODB. Одно из полей "word" таблицы "Catalog" содержит данные типа OLE-объект. Там находятся файлы *.doc. Каким образом я смогу получить их содержимое (хотябы добраться до Object.Words.Item(#).Text)?
Ответ:
Автор ответа: Н. Шувалов
Посмотри по этому адресу:
http://vbnet.ru/faq/showtopic.asp?id=133
Можете заполнить эту форму, либо отослать вопрос СЮДА
Форма для добавления нового вопроса в этот раздел. Информация отсылается по E-mail владельцу сайта.