1) Format(num,"#####.####")

2) Используй ListBox1.Additem a(i) & vbtab & a(i) и моноширинный шрифт

Вроде там есть что-то типа Columns, но не знаю, ниразу не юзал

Ответить

На первый вопрос:

Round(doubleValue, 4)

На второй вопрос, ща ниже выдаю код формы, а потом модуля, на форме 2 ListBox (lst2, lst1) один Picture1...

Ответить

На первый вопрос:

Round(doubleValue, 4)

На второй вопрос, ща ниже выдаю код формы, а потом модуля, на форме 2 ListBox (lst2, lst1) один Picture1 с картинкой...

Ответить

На первый вопрос:

Round(doubleValue, 4)

На второй вопрос, ща ниже выдаю код формы, а потом модуля, на форме 2 ListBox (lst2, lst1) один Picture1 с картинкой...

Ответить

'Форма

Option Explicit

Private Declare Sub InitCommonControls Lib "comctl32.dll" ()

Dim hHeader1 As Long, hHeader2 As Long

Private Sub Form_Initialize()

Call InitCommonControls

End Sub

Private Sub Form_Load()

Dim i As Long

With lst1

hHeader1 = DoCreateHeader(.hwnd, _

.Left \ Screen.TwipsPerPixelX, _

.Top \ Screen.TwipsPerPixelY - 18, _

.Width \ Screen.TwipsPerPixelX, _

20, _

HDS_BUTTONS)

End With

For i = 0 To 3

Call AddHeaderItem(hHeader1, i, 80, HDI_TEXT, HDF_LEFT, "???????" & i + 1)

Next

For i = 0 To 100

lst1.AddItem Timer & vbTab & Timer & vbTab & Timer & vbTab & Timer

Next

With lst2

hHeader2 = DoCreateHeader(.hwnd, _

.Left \ Screen.TwipsPerPixelX, _

.Top \ Screen.TwipsPerPixelY - 18, _

.Width \ Screen.TwipsPerPixelX, _

20, _

&H0)

End With

For i = 0 To 2

Call AddHeaderItem(hHeader2, i, 80, HDI_TEXT Or HDI_BITMAP, HDF_LEFT, "???????" & i + 1, Picture1.Picture)

Next

For i = 0 To 100

lst2.AddItem Timer & vbTab & Timer & vbTab & Timer

Next

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

Call DestroyHeaderCtl(hHeader1)

Call DestroyHeaderCtl(hHeader2)

End Sub

Ответить

' Модуль заголовка

Option Explicit

' §§§§§§§§§§§§§§§§§§§§§§§§§§ HomeWork 2003 §§§§§§§§§§§§§§§§§§§§§§§§§§

' §§§§§§§§§§§§§§§§§§§§§§§§§§ e-mail to sne_pro@mail.ru §§§§§§§§§§§§§§

Private Declare Sub InitCommonControls Lib "comctl32.dll" ()

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function CallWindowProc Lib "user32.dll" 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 SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long

Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function SetWindowPos Lib "user32.dll" (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 Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function GetStockObject Lib "gdi32.dll" (ByVal nIndex As Long) As Long

Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function GetParent Lib "user32.dll" (ByVal hwnd As Long) As Long

Public Enum gbHWHeaderStyles

HDS_BUTTONS = &H2

HDS_HOTTRACK = &H4

End Enum

Public Enum gbHWHeaderMask

HDI_WIDTH = &H1

HDI_TEXT = &H2

HDI_BITMAP = &H10

End Enum

Public Enum gbHWHEaderFormat

HDF_LEFT = &H0

HDF_RIGHT = &H1

HDF_CENTER = &H2

HDF_OWNERDRAW = &H8000&

HDF_STRING = &H4000

HDF_BITMAP = &H2000

HDF_BITMAP_ON_RIGHT = &H1000

End Enum

Public Type RECT

Left As Long

Top As Long

Right As Long

Bottom As Long

End Type

Public Type HD_ITEM

mask As gbHWHeaderMask

cxy As Long

pszText As String

hbm As Long

cchTextMax As Long

fmt As gbHWHEaderFormat

lParam As Long

iImage As Long ' comctl 4.70+

iOrder As Long ' comctl 4.70+

End Type

Private Type gbHWCtrlData

BaseProc As Long

hwnd As Long

lstHandle As Long

End Type

Private Const WS_CHILD As Long = &H40000000

Private Const SWP_SHOWWINDOW As Long = &H40

Private Const DEFAULT_GUI_FONT As Long = &H11

Private Const WM_SETFONT As Long = &H30

Private Const LB_SETTABSTOPS As Long = &H192

Private Const WM_SETREDRAW As Long = &HB

Private Const HDM_GETITEMCOUNT As Long = &H1200

Private Const HDM_INSERTITEM As Long = &H1201

Private Const HDM_DELETEITEM As Long = &H1202

Private Const HDM_GETITEMRECT As Long = &H1207

Private ctlData() As gbHWCtrlData

Public Function DoCreateHeader(ByVal lstHandle As Long, _

ByVal rcLeft As Long, _

ByVal rcTop As Long, _

ByVal rcWidth As Long, _

ByVal rcHeight As Long, _

Optional ByVal lStyle As gbHWHeaderStyles) As Long

Dim hFont As Long, tmp As Long, lOldWndProc As Long

Call InitCommonControls

DoCreateHeader = CreateWindowEx(&H0, "SysHeader32", vbNullString, lStyle Or WS_CHILD, &H0, &H0, &H0, &H0, GetParent(lstHandle), &H0, App.hInstance, ByVal &H0)

Call SetWindowPos(DoCreateHeader, &H0, rcLeft, rcTop, rcWidth, rcHeight, SWP_SHOWWINDOW)

hFont = GetStockObject(DEFAULT_GUI_FONT)

tmp = SelectObject(DoCreateHeader, hFont)

Call SendMessage(DoCreateHeader, WM_SETFONT, hFont, ByVal True)

Call SelectObject(DoCreateHeader, tmp)

lOldWndProc = SetWindowLong(DoCreateHeader, &HFFFC, AddressOf HeaderProc)

Call AddCtl(lOldWndProc, DoCreateHeader, lstHandle)

End Function

Public Sub DestroyHeaderCtl(ByVal lClHandle As Long)

Dim Index As Integer, ProcOld As Long

Index = GetCtlByKey(lClHandle, ProcOld)

If Index = &HFFFF Then Exit Sub

Call SetWindowLong(lClHandle, &HFFFC, ProcOld)

Call RemoveCtl(Index)

End Sub

Public Sub AddHeaderItem(ByVal hHeader As Long, _

ByVal itemNo As Long, _

ByVal nItemWidth As Long, _

ByVal hdiMask As gbHWHeaderMask, _

ByVal hdiFormat As gbHWHEaderFormat, _

Optional ByRef sCaption As String, _

Optional ByRef hBitMap As Long)

Dim HDI As HD_ITEM

With HDI

.mask = hdiMask

.hbm = hBitMap

.fmt = hdiFormat

.cxy = nItemWidth

.pszText = sCaption

.cchTextMax = Len(HDI.pszText)

End With

Call SendMessage(hHeader, HDM_INSERTITEM, itemNo, HDI)

End Sub

Private Function HeaderProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

On Error Resume Next

Dim ProcOld As Long, lstHandle As Long, lWrk As Long, TabArray() As Long, rct As RECT

Call GetCtlByKey(hwnd, ProcOld, lstHandle)

HeaderProc = CallWindowProc(ProcOld, hwnd, Msg, wParam, lParam)

If Msg = &HF Then

lWrk = SendMessage(hwnd, HDM_GETITEMCOUNT, &H0, ByVal &H0)

ReDim TabArray(lWrk - &H2)

For lWrk = 0 To lWrk - &H2

Call SendMessage(hwnd, HDM_GETITEMRECT, lWrk, rct)

TabArray(lWrk) = rct.Right / 1.5

Next

Call SendMessage(lstHandle, LB_SE

Ответить

Ну и на мыло скинул тоже самое, только примером... Этого примера ни у кого нет, я сам писал... Фишка в том, что размер столбцов в Liste можно менять во время выполнения, путем изменения ширины Header'а...

Там модуль, это все к Header'у... Поьзуем

Ответить

2sne: не дописал

Ответить

' Упс, не заметил, сории, теперь все!

Option Explicit

' §§§§§§§§§§§§§§§§§§§§§§§§§§ HomeWork 2003 §§§§§§§§§§§§§§§§§§§§§§§§§§

' §§§§§§§§§§§§§§§§§§§§§§§§§§ e-mail to sne_pro@mail.ru §§§§§§§§§§§§§§

Private Declare Sub InitCommonControls Lib "comctl32.dll" ()

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function CallWindowProc Lib "user32.dll" 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 SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Function CreateWindowEx Lib "user32.dll" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long

Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function SetWindowPos Lib "user32.dll" (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 Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Declare Function GetStockObject Lib "gdi32.dll" (ByVal nIndex As Long) As Long

Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function GetParent Lib "user32.dll" (ByVal hwnd As Long) As Long

Public Enum gbHWHeaderStyles

HDS_BUTTONS = &H2

HDS_HOTTRACK = &H4

End Enum

Public Enum gbHWHeaderMask

HDI_WIDTH = &H1

HDI_TEXT = &H2

HDI_BITMAP = &H10

End Enum

Public Enum gbHWHEaderFormat

HDF_LEFT = &H0

HDF_RIGHT = &H1

HDF_CENTER = &H2

HDF_OWNERDRAW = &H8000&

HDF_STRING = &H4000

HDF_BITMAP = &H2000

HDF_BITMAP_ON_RIGHT = &H1000

End Enum

Public Type RECT

Left As Long

Top As Long

Right As Long

Bottom As Long

End Type

Public Type HD_ITEM

mask As gbHWHeaderMask

cxy As Long

pszText As String

hbm As Long

cchTextMax As Long

fmt As gbHWHEaderFormat

lParam As Long

iImage As Long ' comctl 4.70+

iOrder As Long ' comctl 4.70+

End Type

Private Type gbHWCtrlData

BaseProc As Long

hwnd As Long

lstHandle As Long

End Type

Private Const WS_CHILD As Long = &H40000000

Private Const SWP_SHOWWINDOW As Long = &H40

Private Const DEFAULT_GUI_FONT As Long = &H11

Private Const WM_SETFONT As Long = &H30

Private Const LB_SETTABSTOPS As Long = &H192

Private Const WM_SETREDRAW As Long = &HB

Private Const HDM_GETITEMCOUNT As Long = &H1200

Private Const HDM_INSERTITEM As Long = &H1201

Private Const HDM_DELETEITEM As Long = &H1202

Private Const HDM_GETITEMRECT As Long = &H1207

Private ctlData() As gbHWCtrlData

Public Function DoCreateHeader(ByVal lstHandle As Long, _

ByVal rcLeft As Long, _

ByVal rcTop As Long, _

ByVal rcWidth As Long, _

ByVal rcHeight As Long, _

Optional ByVal lStyle As gbHWHeaderStyles) As Long

Dim hFont As Long, tmp As Long, lOldWndProc As Long

Call InitCommonControls

DoCreateHeader = CreateWindowEx(&H0, "SysHeader32", vbNullString, lStyle Or WS_CHILD, &H0, &H0, &H0, &H0, GetParent(lstHandle), &H0, App.hInstance, ByVal &H0)

Call SetWindowPos(DoCreateHeader, &H0, rcLeft, rcTop, rcWidth, rcHeight, SWP_SHOWWINDOW)

hFont = GetStockObject(DEFAULT_GUI_FONT)

tmp = SelectObject(DoCreateHeader, hFont)

Call SendMessage(DoCreateHeader, WM_SETFONT, hFont, ByVal True)

Call SelectObject(DoCreateHeader, tmp)

lOldWndProc = SetWindowLong(DoCreateHeader, &HFFFC, AddressOf HeaderProc)

Call AddCtl(lOldWndProc, DoCreateHeader, lstHandle)

End Function

Public Sub DestroyHeaderCtl(ByVal lClHandle As Long)

Dim Index As Integer, ProcOld As Long

Index = GetCtlByKey(lClHandle, ProcOld)

If Index = &HFFFF Then Exit Sub

Call SetWindowLong(lClHandle, &HFFFC, ProcOld)

Call RemoveCtl(Index)

End Sub

Public Sub AddHeaderItem(ByVal hHeader As Long, _

ByVal itemNo As Long, _

ByVal nItemWidth As Long, _

ByVal hdiMask As gbHWHeaderMask, _

ByVal hdiFormat As gbHWHEaderFormat, _

Optional ByRef sCaption As String, _

Optional ByRef hBitMap As Long)

Dim HDI As HD_ITEM

With HDI

.mask = hdiMask

.hbm = hBitMap

.fmt = hdiFormat

.cxy = nItemWidth

.pszText = sCaption

.cchTextMax = Len(HDI.pszText)

End With

Call SendMessage(hHeader, HDM_INSERTITEM, itemNo, HDI)

End Sub

Private Function HeaderProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

On Error Resume Next

Dim ProcOld As Long, lstHandle As Long, lWrk As Long, TabArray() As Long, rct As RECT

Call GetCtlByKey(hwnd, ProcOld, lstHandle)

HeaderProc = CallWindowProc(ProcOld, hwnd, Msg, wParam, lParam)

If Msg = &HF Then

lWrk = SendMessage(hwnd, HDM_GETITEMCOUNT, &H0, ByVal &H0)

ReDim TabArray(lWrk - &H2)

For lWrk = 0 To lWrk - &H2

Call SendMessage(hwnd, HDM_GETITEMRECT, lWrk, rct)

TabArray(lWrk) = rct.Right / 1.5

Next

Call S

Ответить

' Так, я че-то не понял, какого хрена этот форум мой код обрезает %(((

' Продолжение модуля!!!

TabArray(lWrk) = rct.Right / 1.5

Next

Call SendMessage(lstHandle, LB_SETTABSTOPS, &H0, ByVal 0&)

Call SendMessage(lstHandle, LB_SETTABSTOPS, 2, TabArray(0))

Call SendMessage(lstHandle, &HB, WM_SETREDRAW, ByVal &H0)

End If

End Function

Private Function FindCtlByKey(ByVal hwnd As Long) As Integer

On Error GoTo er

Dim fk As Long: FindCtlByKey = &HFFFF

For fk = 0 To UBoundCtl

If hwnd = ctlData(fk).hwnd Then FindCtlByKey = fk: Exit For

Next

er:

End Function

Private Function AddCtl(ByVal BaseProc As Long, _

ByVal hwnd As Long, _

ByVal lstHandle As Long)

On Error GoTo er

Dim Index As Integer: Index = UBoundCtl + &H1

ReDim Preserve ctlData(Index)

With ctlData(Index)

.BaseProc = BaseProc

.hwnd = hwnd

.lstHandle = lstHandle

End With

AddCtl = Index

er:

End Function

Private Function RemoveCtl(ByVal Index As Integer) As Integer

On Error GoTo er

Dim ub As Long: ub = UBoundCtl

If Not ub = 0 And Not ub = &HFFFF Then

Call CopyMemory(ctlData(Index), ctlData(Index + 1), &HE * (ub - Index)) ' &HE - размер структуры

Else

Erase ctlData

End If

er:

End Function

Private Function GetCtlByKey(ByVal hwnd As Long, _

ByRef BaseProc As Long, _

Optional ByRef lstHandle As Long)

GetCtlByKey = FindCtlByKey(hwnd)

If GetCtlByKey = &HFFFF Then Exit Function

With ctlData(GetCtlByKey)

BaseProc = .BaseProc

hwnd = .hwnd

lstHandle = .lstHandle

End With

End Function

Private Function UBoundCtl() As Long

On Error GoTo er

UBoundCtl = UBound(ctlData)

Exit Function

er: UBoundCtl = &HFFFF

End Function

Ответить

Лугче просто использовать контрол ListView. Он прикольней!

Ответить

Ответить

Кого прикалывает полтора метра за своей прогой таскать, прикалывайтесь на здоровье, и вообще WinAPI рулит!!! Кто не согласен, извиняйте... скоро и вы это поймете!

Ответить

Спасибо sne, sharp!

to Sharp:

Что еще за моноширный шрифт?

Ответить

Гы... насмешил... Моноширинный шрифт - шрифт с символами равной ширины: Courier, Courier New, Lucida Console, FixedSys, Terminal etc

Ответить