» Задачи на Visual Basic (VB).

excel
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'код тут
End Sub

есть соображения что можно сделать хук мыши, и следить где тыкается, но это уже не чистый VBA

Есть текстовый файл. В нём строки. Длинна строк различная. От сотни до пятисот (примерно) буковок. Как создать новый файл, в котором были бы строки из первого файла в отсортированном виде (по первым 20 символам строк)? Для VB версии 3.

zelinski

Вот общий принцип. переделка скрипта от www.microsoft.com/technet/scriptcenter
строка разбивается на значимую часть(первый 20 символов) и вторую незначимую остаток). Строки записываются в память "виртуального" ADOR.Recordset и там сортируются...
Единственное, я не знаю поддерживает ли ADOR.Recordset строковые поля длиной более 255 символов. Опытным путём не на чем выяснять да и не охото...

Если не поддерживает, то тебе просто строку придется делить не на две, а на три части...

[more]
Код: Const adVarChar = 200

Const iSortedCount = 20
Const iSortedCount = 480

Const ForReading = 1
Const ForWriting = 2

Set DataList = CreateObject("ADOR.Recordset")
DataList.Fields.Append "SortedPart", adVarChar, iSortedCount
DataList.Fields.Append "UnSortedPart", adVarChar, iUnSortedCount
DataList.Open

Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("file.txt", ForReading)

Do Until objFile.AtEndOfStream
strLine = objFile.ReadLine
DataList.AddNew
DataList("SortedPart") = Left(strLine, iSortedCount)
DataList("UnSortedPart") = Mid(strLine, iSortedCount+1)
DataList.Update
Loop

objFile.Close

DataList.Sort = "SortedPart"

DataList.MoveFirst
Do Until DataList.EOF
strText = strText & DataList.Fields.Item("SortedPart") & DataList.Fields.Item("UnSortedPart") & vbCrLf
DataList.MoveNext
Loop

Set objFile = objFSO.OpenTextFile("new.file.txt",ForWriting, true)

objFile.WriteLine strText
objFile.Close

если длинна строк не очень большая то думаю чтоб не парится можно юзать лист с sorted=true


Private Sub Command2_Click()
List1.AddItem "Cweqweqwcqwq"
List1.AddItem "Aweqweqwcqwq"
List1.AddItem "Bweqweqwcqwq"
List1.AddItem "Dweqweqwcqwq"
For X = 0 To List1.ListCount - 1
Debug.Print X
Next X
End Sub

Цитата:

[/q]
[q]excel
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'код тут
End Sub

Спасибо!
Сработало!

Помогите !
Для VB версии 6
Есть бланки платежек. В них есть несколько окон в которые надо попасть при распечатке на принтере. Каким шрифтом все равно . Лиш бы попадало в окошко и там между цифрами были небольшие пробелы, т.к. я пытался вписывать разными размерами фонтов. Не получаеться. Так подсчитал что если между числом вводить пробел примерно на 30-40% от толшины цифры , то должно попадать в нужные места.
Распечатывал н а принтер вот таким кодом:
Private Sub BtnPrint_Click()
Printer.ScaleMode = 1
Printer.FontSize = 14
Printer.CurrentX = 3586
Printer.CurrentY = 2604
Printer.Print TxtBox1
....................TxtBox2
....................TxtBox3
....................TxtBox4

Printer.EndDoc
End Sub

Private Sub Command1_Click()
Text1.Text = "ANDRON"
Z = 600
Printer.ScaleMode = 1
Printer.FontSize = 14
For X = 1 To Len(Text1.Text)
Printer.CurrentX = 3386 + X * Z
Printer.CurrentY = 2604
Printer.Print Mid(Text1, X, 1)
Next X
Printer.EndDoc
End Sub

Параметр Z подобрать опционально, рекомендую использовать моноширинный шрифт.

помогите пожалуйсто! нужно осуществить следующее: во время выполнения вводим в текстбокс формулу произвольную (например y=x^2-5), нужно в ходе выполнения вытащить эту самую формулу и при заданном позднее значении х вычислять чему будет равен y
то есть программа, которая вычисляет значения произвольных формул

ppJester
Вы бы еще AI написать попросили.
Несколько больших подробностей треба.

ppJester

Цитата:

помогите пожалуйсто! нужно осуществить следующее: во время выполнения вводим в текстбокс формулу произвольную (например y=x^2-5), нужно в ходе выполнения вытащить эту самую формулу и при заданном позднее значении х вычислять чему будет равен y
то есть программа, которая вычисляет значения произвольных формул

Советую на http://www.planet-source-code.com/vb/ поискать.
Там такое добро встречалось, и в основном в виде графопостроителей (Graph Plotter и т.п.), так что отправную точку нащупать можно.

Навскидку [more=скриншот и описание одного из примеров]


Title: A 2D Advanced Graph Plotter
Description: 2D Graph Plotter
This tool draws any graph you want on precice Axii.
Type the graph's equation in the box and press Plot.
There is an expression builder to help you with all
supported functions. All VB Math functions are supported
plus a bunch more trigonometric functions plus the ability
to support any function you want, just include it in the .bas
file along with the rest.
You can specify the maximum limits for drawing.
1:1 limit is 4
You can use copy to copy the graph to the clipboard
Your most clomplete tool for drawing graphs.
If you have an account please vote.
This file came from Planet-Source-Code.com...the home millions of lines of source code
You can view comments on this code/and or vote on it at: http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=46695&lngWId=1

The author may have retained certain copyrights to this code...please observe their request and the law by reviewing all copyright conditions at the above URL.
[/more]

спасибо огромное!

AndronH

Спасибо большое. Все получилось. ДА , вы правы, пришлось опытным путем повычеслять показатель Z = ..... , что б попало в нужное место ...

Скажите, все искал как мне в TextBox-е ввести что б возможно было делать WordWrap?
В самом окне отображается нормально,доходит до 38 символа и переходит на новую . А вот когда вывожу на принтер , то не хочет строка делиться на 38 символе и перехоить на новую.

danka
Для печати практически всегда надо формировать все самому, вручную.
Для расчета длины строки при данных настройках принтера(или экрана) - проперти font, DPI - используем функцию TextWidth
Если хочется напечатать так как на экране, то надо проверять служебные символы в строке. Textbox добавляет их сам и это не vbNewLine.

Ребята!
Вот нашел такой код:

Public Sub PPrintWW(TextStr As String, Optional AutoEndDoc As Boolean)
If IsMissing(AutoEndDoc) = True Then
AutoEndDoc = False
End If
Dim TextStrW As Long, TempStr As String, LeftStr As String
TextStrW = Printer.TextWidth(TextStr)
LeftStr = TextStr
Do Until Printer.TextWidth(LeftStr) <= Printer.ScaleWidth
TempStr = LeftStr
Do Until Printer.TextWidth(TempStr) <= Printer.ScaleWidth
TempStr = Mid(TempStr, 1, Len(TempStr) - 1)
Loop
Printer.Print TempStr
LeftStr = Mid(LeftStr, Len(TempStr) + 1, Len(LeftStr) - Len(TempStr))
Loop
Printer.Print LeftStr
If AutoEndDoc = True Then
Printer.EndDoc
End If
End Sub


Но пока ничего не могу добится

Как говорится заюзаем апишную функцию SendMessage и сведем задачу к классической =)


Код:
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As Long
Const EM_LINEINDEX = &HBB
Const EM_LINELENGTH = &HC1
Const EM_GETLINE = &HC4
Const EM_GETLINECOUNT = &HBA
Public Function GetLine(hWnd As Long, Line As Long) As String
Dim sBuf As String, nLen As Long, nIndex As Long
nIndex = SendMessage(hWnd, EM_LINEINDEX, Line - 1, ByVal 0&)
If nIndex < 0 Or Line <= 0 Then Exit Function
nLen = SendMessage(hWnd, EM_LINELENGTH, nIndex, ByVal 0&)
sBuf = Space(nLen + 1)
Mid$(sBuf, 1, 1) = Chr$(nLen And &HFF)
Mid$(sBuf, 2, 1) = Chr$(nLen \ 256)
SendMessage hWnd, EM_GETLINE, Line - 1, ByVal sBuf
GetLine = Left$(sBuf, nLen)
End Function
Private Sub Command1_Click()
Text1.MultiLine = True
Text1.Text = "Andron ANDRON andron"
Text1.Text = "Andron ANDRON andron " & Text1.Text
Text1.Text = "Andron ANDRON andron " & Text1.Text
Text1.Text = "Andron ANDRON andron " & Text1.Text
Z1 = 300
Z2 = 300
Printer.ScaleMode = 1
Printer.FontSize = 14
For N = 1 To SendMessage(Text1.hWnd, EM_GETLINECOUNT, 0, 0)
For X = 1 To Len(GetLine(Text1.hWnd, CInt(N)))
Printer.CurrentX = 1000 + X * Z1
Printer.CurrentY = 1000 + N * Z2
Printer.Print Mid(Text1, X, 1)
Next X
Next N
Printer.EndDoc
End Sub

AndronH


Цитата:

Text1.MultiLine = True

Вот тут выдаёт ошибку. ЧТо-то не выходит.

Потом я убрал эту ошибку вообще и твой "Andron ANDRON andron" текст печатает.
ПЫтаюсь оставлять пустые кавычки , что печатал текст в Боксе , что я ввожу. НЕ печатает вообще.

danka
Text1.MultiLine нельзя менять в runtime. Надо установить вручную в проперти перед запуском. А линию кода закоментировать.

Ребята!
Вот попробовал этот код. Посмотрите .Он маленький. 5 кб.
_http://rapidshare.com/files/16618878/Print_a_string_on_the_printer_with_word_wrap.rar

Все мне подходит. Уже ставлю рамку /даже она может быть, но там мона ее и убрать- не существенно/ в ту точку бланка в которую мне надо. И печатает делая WordWrap. Уже даже обрадовался. Но , блин, что там не так. Печатает только то текст который в той рамке. Когда ввожу свой , то не делает разделение строк. Но рамка стоит на том месте котором я задал.
Пробовал убрать этот текст . Но мой который ввожу и хочу выводить на принтер не делает WordWrap. А на принтере идет все одной строкой.

Посмотрите , пожалуйста, что там я не так сделал. ПУсть уже и этот код может быть. НО почему не правлиьно у меня он работает.

dneprcomp

Цитата:

Text1.MultiLine нельзя менять в runtime. Надо установить вручную в проперти перед запуском

Дык у меня установлено на ТекстБоксе MultiLine.

danka
MultiLine - readonly проперти. Его НЕЛЬЗЯ менять в runtime(програмно)
Код посмотрю


Добавлено:
Код расчитан на то, что в техте обязательно присутствуют любые символы с 32 < Asc() > 126 или пробелы. При наличии таковых все работает. Кроме того, длина техта должна быть больше длины формируемой строки new_line. Т.е., техт должен заведомо занимать больше 1-й строки и удовлетворять условию:
Printer.TextWidth(txt) > line_wid

пардон в коде был косяк, но так как у мя руками было выставлены заначения у меня работало без ошибок.
Лови исправленный. в свойствах Text1 выставь MultiLine=True

Код:
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As Long
Const EM_LINEINDEX = &HBB
Const EM_LINELENGTH = &HC1
Const EM_GETLINE = &HC4
Const EM_GETLINECOUNT = &HBA
Public Function GetLine(hWnd As Long, Line As Long) As String
Dim sBuf As String, nLen As Long, nIndex As Long
nIndex = SendMessage(hWnd, EM_LINEINDEX, Line - 1, ByVal 0&)
If nIndex < 0 Or Line <= 0 Then Exit Function
nLen = SendMessage(hWnd, EM_LINELENGTH, nIndex, ByVal 0&)
sBuf = Space(nLen + 1)
Mid$(sBuf, 1, 1) = Chr$(nLen And &HFF)
Mid$(sBuf, 2, 1) = Chr$(nLen \ 256)
SendMessage hWnd, EM_GETLINE, Line - 1, ByVal sBuf
GetLine = Left$(sBuf, nLen)
End Function
Private Sub Command1_Click()
Z1 = 300
Z2 = 300
Printer.ScaleMode = 1
Printer.FontSize = 14
For N = 1 To SendMessage(Text1.hWnd, EM_GETLINECOUNT, 0, 0)
For X = 1 To Len(GetLine(Text1.hWnd, CInt(N)))
Printer.CurrentX = 1000 + X * Z1
Printer.CurrentY = 1000 + N * Z2
Printer.Print Mid(GetLine(Text1.hWnd, CInt(N)), X, 1)
Next X
Next N
Printer.EndDoc
End Sub

Как полю со списком назначить процедуру обновления (или перехода) к соответствующей записи таблицы, чтобы на форме не нажимать много раз на стрелочку> перехода к следующей записи?

что значит обновления?

Код:
Combo1.Refresh

AndronH

Всё работает . Спасибо. ТОлько сейчас немного пробую разобраться почему выдает ошибку в этой строке:
Mid$(sBuf, 2, 1) = Chr$(nLen \ 256)

когда я ввожу текст с пробелом между рядами. Если пробел в самом ряду , то все печатает коректно....

ошибочка с топиком вышла...

Цитата:

когда я ввожу текст с пробелом между рядами. Если пробел в самом ряду , то все печатает коректно....

беда не в прбелах а в переносах в конце строки
nLen = 0 выходит ошибка

вылечилось дополнительной проверкой

Код:
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As Long
Const EM_LINEINDEX = &HBB
Const EM_LINELENGTH = &HC1
Const EM_GETLINE = &HC4
Const EM_GETLINECOUNT = &HBA
Public Function GetLine(hWnd As Long, Line As Long) As String
Dim sBuf As String, nLen As Long, nIndex As Long
nIndex = SendMessage(hWnd, EM_LINEINDEX, Line - 1, ByVal 0&)
If nIndex < 0 Or Line <= 0 Then Exit Function
nLen = SendMessage(hWnd, EM_LINELENGTH, nIndex, ByVal 0&)
If nLen = 0 Then GetLine = "": Exit Function
sBuf = Space(nLen + 1)
Mid$(sBuf, 1, 1) = Chr$(nLen And &HFF)
Mid$(sBuf, 2, 1) = Chr$(nLen \ 256)
SendMessage hWnd, EM_GETLINE, Line - 1, ByVal sBuf
GetLine = Left$(sBuf, nLen)
End Function
Private Sub Command1_Click()
Z1 = 300
Z2 = 300
Printer.ScaleMode = 1
Printer.FontSize = 14
For N = 1 To SendMessage(Text1.hWnd, EM_GETLINECOUNT, 0, 0)
For X = 1 To Len(GetLine(Text1.hWnd, CInt(N)))
Printer.CurrentX = 1000 + X * Z1
Printer.CurrentY = 1000 + N * Z2
Printer.Print Mid(GetLine(Text1.hWnd, CInt(N)), X, 1)
Next X
Next N
Printer.EndDoc
End Sub

AndronH

Спасибо . Всё заработало корректно.

Вопрос а потом уже разобрался. Но так как я не могу вытерать сообщения ,то просто опишу мою проблемму ,авось комуто пригодится.
Я не мог вводить буквы в кирилице. РАспечатывалось нормально. И в ВОрде работало нормально. Поэтому ошибка была в свойствах текстового окна. Просто решилось. Я в свойствах шрифта забыл поставить кирилицу. И все решилось потом.

Цитата:

Потом когда мне надо перейти в руссский шрифт, то мне буквы не печатает. Вернее, не правильные печатает . Не керилицу.

Когда неправильные буквы? В каком окне? Если окно консольное - в нем кодировка не ANSI (Windows), a OEM (DOS). Если окно обычное, Windows GUI, может, там шрифт какой не очень подходящий по умолчанию ставится? Ну и, для полноты информации, используется VB под .NET или более ранние версии, типа VB6?

XPEHOMETP

Спасибо .. Блин , немного растерялся. Но потом порыл и нашел


Добавлено:
XPEHOMETP

Поспешил я обрадоваться. ВВодится то оно вводится в окно уже нормально. А вот распечатывается не правильно...
Как мне в коде указать , что б печатало кирилицей? Т.е. то что в TextBox -е то и выводилось на принтер.
Во засада с этим принтером


Добавлено:

Нашел я вот такой код. Но он для китайского.

Global Const LANG_CHINESE = &H4
Global Const SUBLANG_CHINESE_TRADITIONAL = &H1 ' Chinese (Taiwan)
Global Const SUBLANG_CHINESE_SIMPLIFIED = &H2 ' Chinese (PR China)
Global Const CHARSET_CHINESESIMPLIFIED = 134
Global Const CHARSET_CHINESEBIG5 = 136

Прбовал вот так

TxtBox10.Text = Convert(TxtBox10.Text, 1140, 1251) 'конвертировать с американского кода в русский. Пока не вышло.

Може т из-за того что у меня английская винда? И оно не корректно конвертирует.

Помогите Пожалуйста из рукописных формул перевести их в язык Visual Basik (в доступные для него символы). Вот URL на формулы: www.mobilize.in/formuli.png

Зарание очень благодарен.