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

Добрый день, Der Sohn
Сто лет уже не пользовался qbasic (кстати, вообще-то по нему отдельная тема, указанная в шапке). Поэтому, пожалуйста, проверьте [more]

Код:
DECLARE FUNCTION gets! (x1!, y1!, x2!, y2!, x3!, y3!)
DIM arr(9, 2)
DATA 2,3
DATA 1,1
DATA -6,5
DATA 23,88
DATA 9,21
DATA 131,1
DATA 76,14
DATA 46,57
DATA 17,8
FOR i = 0 TO 8: FOR j = 0 TO 1
READ arr(i, j)
NEXT j, i

smin = gets(arr(0, 0), arr(0, 1), arr(1, 0), arr(1, 1), arr(2, 0), arr(2, 1))
smax = smin

FOR i = 0 TO 8: FOR j = i + 1 TO 8: FOR k = i + 2 TO 8
scurr = gets(arr(i, 0), arr(i, 1), arr(j, 0), arr(j, 1), arr(k, 0), arr(k, 1))
IF scurr < smin THEN smin = scurr
IF scurr > smax THEN smax = scurr
NEXT k, j, i
PRINT smin; smax


FUNCTION gets (x1, y1, x2, y2, x3, y3)
sgets1 = (x1 - x3) * (y2 - y3)
sgets2 = (x2 - x3) * (y1 - y3)
gets = ABS(sgets1 - sgets2) / 2
END FUNCTION

спасибо

более года назад написал программу средствами Visual Studio: VB (визуал бейсик), сейчас в коде программы появилась необходимость внести изменения (арифметического характера), вс вместе вб давно удалены, остались лишь файлы которые в архиве приложенном - скачал новый вс-вб, но не получаеться войти в режим редактирования кода программы, я этим очень поверхностно занимался... плз помогите


http://files.mail.ru/8C39C475E5354C02BFDBAD7952B7D7F5

Помогите пожалуйста
[more=если есть желание]Ребят, помогите (дуб я в макросах): есть файл с тучей гиперссылок на папки и PDF файлы, но пришлось всю базу проектов перелопатить и все ссылки похерились.
Руками исправлять ссылки (не формульные =ГИПЕРССЫЛКА()) я умру. Для вас пара пустяков написать макрос, т.к. все эти фичи есть в разных макросах, но я даже объединить их не могу. Суть: брать существующую ссылку, откинуть всё до последнего знака "\" (т.к. ссылки не только на файлы но и на папки), по оставшемуся делать поиск в заданной папке и заменять ссылку на найденное.
Пример:
старая ссылка - 3G/0001 АТС-35/БС/2-34-0001-БС (АТС-35).pdf
берем из неё - 2-34-0001-БС(АТС-35).pdf
ищем в папке d:\Мои документы\!ПРОЕКТЫ\
находится - d:\Мои документы\!ПРОЕКТЫ\001_АТС-35\2-34-0001 АТС-35\БС\2-34-0001-БС (АТС-35).pdf
меняем ссылку на - 001_АТС-35\2-34-0001 АТС-35\БС\2-34-0001-БС (АТС-35).pdf

Ведь понимаю, что просто, но реализовать не могу (
[/more]

Есть код, который делает почти то, что надо, но на [more=C]
#include <windows.h>
#include <stdlib.h>
#include <stdio.h>
#define PATH "C:\\"
#define INFILE "test.txt"
#define OUTFILE "out.txt"

//////////////////////////////////////////////////////////////////////////////////////////////////////
void findFile(char* wrkdir, char* fname, FILE* f)
{
    HANDLE hFile;
    WIN32_FIND_DATA file_data;
    char wrkdirtemp[MAX_PATH], buf[MAX_PATH];

    strcpy(wrkdirtemp, wrkdir);

    if(wrkdirtemp[strlen(wrkdirtemp) - 1] != '\\')
        strcat(wrkdirtemp, "\\");
    sprintf(buf, "%s*", wrkdirtemp);

    hFile = FindFirstFile(buf, &file_data);
    if(INVALID_HANDLE_VALUE == hFile)
        return;

    do
    {
        if(file_data.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY)
        {
            if('.' == *(short*)&file_data.cFileName || '..' == *(short*)&file_data.cFileName)
                continue;

            sprintf(buf, "%s%s", wrkdirtemp, file_data.cFileName);
            findFile(buf, fname, f);
        }
        else if(!strcmp(file_data.cFileName, fname))
            fprintf(f, "%s%s\r\n", wrkdirtemp, file_data.cFileName);

    } while(FindNextFile(hFile, &file_data));

    FindClose(hFile);
}

//////////////////////////////////////////////////////////////////////////////////////////////////////
int main()
{
    FILE *fi, *fo;
    char *path, *ptr, line[0x400];
    
    if(!(fi = fopen(INFILE, "rb")))
    {
        puts("Can't open an input file\n");
        return -1;
    }
    if(!(fo = fopen(OUTFILE, "wb")))
    {
        puts("Can't create an output file\n");
        return -1;
    }

    path = PATH;
    while(fgets(line, sizeof(line), fi))
    {    
        for(ptr = line + strlen(line); (*ptr != '\\') && (*ptr != '/'); --ptr)
            if('\r' == *ptr || '\n' == *ptr)
                *ptr = 0;
        findFile(path, ptr + 1, fo);
    }

    fclose(fi);
    fclose(fo);
    return 0;
}
[/more].

ne_viens
спасибо. но тут проблема именно с встроенными ссылками. ели бы они были в виде формулы, то я бы не напрягал уважаемое сообщество, а извратился с текстовыми формулами и получил результат.
в вашем примере идет работа с простым текстом.

Что такое формула ссылки?
Выше описанный код построчно берёт из файла ссылок названия файлов (то, что за последним "\" или "/"), находит эти файлы в данной директории и построчно записывает полные пути к этим файлам в out.txt. Лишние начала потом в любом редакторе можно удалить. Не то?

zporuchik
Не очень понял, что это у вас за ссылки такие получаются, но получилось что-то [more=такое...]такое:

Код:

Option Explicit

Public Sub total_replace() 'Optional ByVal alternate_path As String)
On Error GoTo ERROR_HANDLER

Const ALTERNATE_PATH As String = "d:\Мои документы\!ПРОЕКТЫ\"

Dim cur_ws As Worksheet: Set cur_ws = ActiveSheet
Dim cur_cell As Range: For Each cur_cell In cur_ws.UsedRange

' TODO: cache filelist of ALTERNATE_PATH into something (collection/dictionary)


' find hyperlink
Dim has_hyperlink As Boolean: has_hyperlink = False
Dim hyperlink As String: hyperlink = ""
hyperlink = get_hyperlink(cur_cell)
has_hyperlink = Len(hyperlink) > 0


' find alternate link
Dim has_alt_link As Boolean: has_alt_link = False
Dim alt_link As String: alt_link = ""
If has_hyperlink Then
alt_link = get_alt_link(ALTERNATE_PATH, hyperlink)
has_alt_link = Len(alt_link) > 0
If has_alt_link Then alt_link = Replace(alt_link, ALTERNATE_PATH, "") ' removes origin folder from path (for what ???)
End If


' change link
' highlight cell
' white -- hyperlink not found
' red -- hyperlink found / alternate link not found
' green -- hyperlink found / link changed
If has_alt_link Then
cur_cell.Hyperlinks(1).Address = alt_link
cur_cell.Interior.ColorIndex = 4 ' green
ElseIf has_hyperlink Then
cur_cell.Interior.ColorIndex = 3 ' red
Else
cur_cell.Interior.ColorIndex = xlNone ' white
End If

Next cur_cell

MsgBox "!"

Exit Sub
ERROR_HANDLER:
End Sub

Private Function get_hyperlink(ByRef cur_cell As Range) As String
On Error GoTo ERROR_HANDLER

get_hyperlink = cur_cell.Hyperlinks(1).Address

Exit Function
ERROR_HANDLER: get_hyperlink = ""
End Function

Private Function get_alt_link(ByVal path As String, ByVal old_link As String) As String
On Error GoTo ERROR_HANDLER

Dim ret_link As String: ret_link = ""

Dim fso As FileSystemObject: Set fso = New FileSystemObject
Dim searched_obj As String: searched_obj = fso.GetFileName(old_link)

ret_link = get_alt_link_folder(path, old_link)
If Len(ret_link) = 0 Then ret_link = get_alt_link_file(path, old_link)

get_alt_link = ret_link

Exit Function
ERROR_HANDLER: get_alt_link = ""
End Function

Private Function get_alt_link_file(ByVal path As String, ByVal old_link As String) As String
On Error GoTo ERROR_HANDLER

Dim ret_link As String: ret_link = ""

Dim fso As FileSystemObject: Set fso = New FileSystemObject
Dim searched_file As String: searched_file = LCase(fso.GetFileName(old_link))
Dim cur_dir As Folder: Set cur_dir = fso.GetFolder(path)

Dim cur_file As File: For Each cur_file In cur_dir.Files
If LCase(cur_file.Name) = searched_file Then ret_link = cur_file.path

If Len(ret_link) > 0 Then Exit For
Next cur_file

' nothing found in current folder, sifting through subfolders
If Len(ret_link) = 0 Then
Dim cur_subdir As Folder: For Each cur_subdir In cur_dir.SubFolders
ret_link = get_alt_link_file(cur_subdir.path, old_link)

If Len(ret_link) > 0 Then Exit For
Next cur_subdir
End If

get_alt_link_file = ret_link

Exit Function
ERROR_HANDLER: get_alt_link_file = ""
End Function

Private Function get_alt_link_folder(ByVal path As String, ByVal old_link As String) As String
On Error GoTo ERROR_HANDLER

Dim ret_link As String: ret_link = ""

Dim fso As FileSystemObject: Set fso = New FileSystemObject
Dim searched_folder As String: searched_folder = LCase(fso.GetFileName(old_link))
Dim cur_dir As Folder: Set cur_dir = fso.GetFolder(path)

Dim cur_subdir As Folder: For Each cur_subdir In cur_dir.SubFolders
If LCase(cur_subdir.Name) = searched_folder Then ret_link = cur_subdir.path

If Len(ret_link) > 0 Then Exit For
Next cur_subdir

' nothing found in current folder, sifting through subfolders
If Len(ret_link) = 0 Then
For Each cur_subdir In cur_dir.SubFolders
ret_link = get_alt_link_folder(cur_subdir.path, old_link)

If Len(ret_link) > 0 Then Exit For
Next cur_subdir
End If

get_alt_link_folder = ret_link

Exit Function
ERROR_HANDLER: get_alt_link_folder = ""
End Function

ne_viens
не формула ссылки, а формульные, т.е. записанные через ввод формулы =ГИПЕРССЫЛКА()
у меня же ссылки введены через инструмент "гиперссылка" (Вставка-гиперссылка CTRL+K)? а сними такой фокус не прокатывает.

Legio

Цитата:

если есть что-то с совпадающими именами

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

еще раз: всем спасибо. когда задача будет решена окончательно могу поделиться кодом, если надо.

подскажите: как из макроса прочитать гиперссылку, содержащую адрес ячейки в другом документе эксель?
например:
1800\а\Список.xls - Альянс!А18

zporuchik
С такими вопросами лучше всё-таки в профильную тему уже переходить

Есть макрос, который переносит данные с одного рабочего листа на другой, при наложении фильтра данные переносятся также как и без фильтра, а необходимо, чтобы переносились только отфильтрованные данные.
Как это можно сделать?

Здравствуйте! Если не затруднит какого-нибудь крутого программиста, то помогите, пожалуйста, начинающему. Пишу калькулятор по типу Windows на VB. Практически готов (сложно была в зажите "от дурака"). Но есть еще одно НО. Нужно, чтобы он считал, например, так: 2*5*9=90 (а НЕ так: 2*5 = 10, затем 10*9 = 90). То есть считалось 3 и более числа сразу. Есть идеи, но не знаю как осуществить. Буду очень признательно. (ответить можете на своем языке, я разберусь). Очень прошу!

maschinarium0
Попробуйте так.

[more] Legio
немного непонятно, причем тут вообще типы данных? мне просто нужно, чтобы последовательно могли выполняться более трех действий одновременно. а не посредством нажатия кнопки "=", чтобы повторялось предыдущее действие
если можете, то объясните хоть на словах с помощью чего это можно сделать, полжалуйста.. . Очень надо
_Код (часть) ______
Private Sub equally_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles equally.Click
y = txt.Text
If order = 1 Then z = x + y
If order = 2 Then z = x - y
If order = 3 Then z = x * y
If order = 4 Then z = x / y
txt.Text = z
If (x / 0 = z) Then
txt.Text = " "
MsgBox("На ноль делить нельзя!", MsgBoxStyle.Information, "Ошибка")
End If
If x = "" Or y = "" Then txt.Text = ""
MsgBox("Введите данные")
End Sub
_____
Private Sub plus_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles plus.Click
x = txt.Text
txt.Text = ""
order = 1
End Sub
[/more]

Вы весь проект выкладывайте, что ли, -- а то не очень понятно, что вы там сейчас делаете, и чего вам на самом деле надо.

А пример только показывает, как можно, -- не сильно задумываясь о том, что происходит, -- получить значение произвольного арифметического выражения. И насколько глубоко вы хотите задуматься не очень понятно до сих пор.

[more] Public Class WinCalc
Dim x As Double, y As Double, z As Double, order As Integer ' order - числовое значение арифметич. действия
Dim prov As Integer 'запоминание необходимости обнуления поля txt
Dim znak As Integer
Dim buf As Double
Private Sub equally_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles equally.Click
y = txt.Text
If order = 1 Then z = x + y
If order = 2 Then z = x - y
If order = 3 Then z = x * y
If order = 4 Then z = x / y
txt.Text = z
If (x / 0 = z) Then
txt.Text = " "
MsgBox("На ноль делить нельзя!", MsgBoxStyle.Information, "Ошибка")
End If
End Sub

'Кнопки он 0 до 9
Private Sub three_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles three.Click
txt.Text = txt.Text + "3"
End Sub
Private Sub one_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles one.Click
txt.Text = txt.Text + "1"
End Sub
Private Sub two_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles two.Click
txt.Text = txt.Text + "2"
End Sub
Private Sub four_Click_1(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles four.Click
txt.Text = txt.Text + "4"
End Sub
Private Sub five_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles five.Click
txt.Text = txt.Text + "5"
End Sub
Private Sub six_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles six.Click
txt.Text = txt.Text + "6"
End Sub
Private Sub seven_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles seven.Click
txt.Text = txt.Text + "7"
End Sub
Private Sub eight_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles eight.Click
txt.Text = txt.Text + "8"
End Sub
Private Sub nine_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles nine.Click
txt.Text = txt.Text + "9"
End Sub

Private Sub zero_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles zero.Click
If txt.Text = "0" Then
Else
txt.Text &= "0" 'Запрет на ввод нескольких нулей подряд в начале
End If
End Sub

Private Sub coma_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles coma.Click
If prov <> 0 Then
txt.Text = ""
End If
If InStr(txt.Text, ",") = 0 Then
If txt.Text = "" Then
txt.Text = "0," 'если вводить запятую в место, где перед ней ничего не стоит, то выводится: 0.8, например
Else
txt.Text = txt.Text + ","
End If
prov = 0
If znak > 1 Then
znak = 1
End If
Else
Exit Sub
End If
End Sub

Private Sub sign_Click(ByVal sender As System.Object, ByVal e As System.EventArgs)
z = txt.Text
z = z * (-1) 'Смена на противоположный знак
txt.Text = z
End Sub

Private Sub plus_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles plus.Click
x = txt.Text
txt.Text = ""
order = 1
End Sub

Private Sub minus_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles minus.Click
x = txt.Text
txt.Text = ""
order = 2
End Sub

Private Sub multiplication_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles multiplication.Click
x = txt.Text
txt.Text = ""
order = 3
End Sub

Private Sub degree_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles degree.Click
x = txt.Text
txt.Text = ""
order = 4
End Sub

Private Sub c_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles c.Click
x = 0
y = 0
z = 0
order = 0
txt.Text = ""
End Sub

Private Sub txt_KeyPress(ByVal sender As Object, ByVal e As System.Windows.Forms.KeyPressEventArgs) Handles txt.KeyPress
If Not (IsNumeric(e.KeyChar) Or ((e.KeyChar = ".") Or (e.KeyChar = ",")) Or (e.KeyChar = "-")) Then e.Handled = True
End Sub

Private Sub back_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles back.Click
txt.Text = txt.Text.Substring(0, txt.Text.Length - 1)
End Sub
End Class [/more]

Какая то ошибка с циклами. Выделяет Next i и пишет, что он без For.

Dim G(1 To 16, 1 To 9) As Single
Dim l As Integer
Dim k As Integer
Dim a As Integer
Dim i As Integer
Dim s1 As Integer

Sheets("Лист1").Select
For l = 1 To 16
k = 0
For i = 1 To 9
a = Cells(i + 3, l + 1)
If a = "-" Then
k = k + 1
Next i
Cells(13, l + 1) = k
If k > Max Then
Max = k
s1 = Cells(3, l + 1)
End If
Next l
Cells(14, 2) = s1

End Sub

Alyrain
Строка "If a = "-" Then" не имеет "End If"
PS. Судя по "Sheets("Лист1").Select" вопрос не по Visual Basic.
Это скорее для Excel VBA

Не могли бы помочь?

Задача: вывести квадраты четных чисел от 1 до 12 .
Задача простая(даже очень), но проблема в том, что выводит только последнее число(в данном случае 12)..

проверял без условия и квадрата - тоже выводит только последнее, т.е цикл не срабатывает..

Dim i As Integer
For i = 1 To 12 Step 1
If (i Mod 2 = 0) Then
TextBox2.Text = ("квадрат " + Str(i) + " = " + Str(i * i))
End If
Next i
End Sub

Помогите плиз, ситуация тупая, не могу её сдать..

ERGHERH24
Вот тебе рабочий вариант:

Код: Sub zz()
Dim i As Long
For i = 2 To 12 Step 2
ActiveDocument.Content.InsertAfter "square of " + Str$(i) + " is " + Str$(i * i)
ActiveDocument.Content.InsertParagraphAfter
Next i
End Sub

подскажите как будет выглядеть макрос для MS Word. Есть столбец в таблице с набором слов в каждой ячейке. Нужно выбрать первое слово в каждой ячейке и перенести его в в новую ячейку (соседнюю).

Было

Иван иванов

ItsJustMe, а нельзя что-нибудь попроще(мне ещё отчёт сдавать), я не знаю этой функции "ActiveDocument.Content.."? Или хотя бы описание действий этой проги.

Доброго времени. Поомгите, пожалуйста, с задачей:

Одномерные массивы
Дан вектор Х(n). Элементы вектора с нечетными номерами нужно умножить на 3.

Как будет выглядеть код?

вычислить сумму квадратов всех элементов заданного массива X(N) , за исключением элементов кратных 5. в программе visual studio 2010 и постороить блок схему. помогите пожалуйста

Цитата:

вычислить сумму квадратов всех элементов заданного массива X(N) , за исключением элементов кратных 5.

Sub primer()

Const N = 10
Dim X(N) As Double
Sum = 0

For i = 0 To N Step 1
If Not (i Mod 5 = 0) Then
Sum = Sum + (X(i) * X(i))
End If
Next i

End Sub

Возможно эти программки пригодятся какому-нибудь учителю информатики при обучении школьников бейсику. Правда они для предка VB написаны, но переделать, если понравятся, несложно (у меня VB нет - не покупал).

c1 = 0
a$ = "&#9618;&#9617;&#9619;"
SCREEN 13
CLS
FOR j = 1 TO 4
FOR i = 1 TO 32
c1 = c1 + 1
REM SLEEP (1)
COLOR c1
s = 18 * RND(2) + j
LOCATE s, i + j
PRINT a$
NEXT i
SLEEP (1)
NEXT j

c1 = 0: k = 1
SCREEN 13
CLS
FOR j = 1 TO 100
FOR i = 1 TO 270
c1 = c1 + 1
REM SLEEP (1)
IF c1 > 240 THEN c1 = 1
COLOR c1
s = 240 * RND(2) + j
PSET (s, i + j - k), c1
NEXT i
k = k + 2
REM SLEEP (1)
NEXT j

c1 = 0: k = 1
SCREEN 13
CLS
FOR j = 15 TO 100
FOR i = 15 TO 300
c1 = c1 + 1
REM SLEEP (1)
IF c1 > 240 THEN c1 = 1
COLOR c1
s = 210 * RND(j) + j
ss = 15 - 29 * RND(i)
sss = 15 - 29 * RND(i)
LINE (s, i + j - k)-(s + ss, i + j - k - sss), c1
REM PSET (s, i + j - k), c1
NEXT i
k = k + 2
SLEEP (1)
NEXT j

ilarvandar
Читаем шапку и топаем сюда

Ещё немного Красоты на Бейсике:

c1 = 0: k = 1
SCREEN 13
CLS
FOR j = 40 TO 60
FOR i = 45 TO 70
c1 = c1 + 1
IF c1 > 240 THEN c1 = 1
COLOR c1
s = 210 * RND(j) + j
ss = 35 - 69 * RND(i)
sss = 35 - 69 * RND(i)
r = c1 * RND(i) / 3
d = 6 * RND(i)
e = d / 2 - .3
CIRCLE (s + ss, i + j - k - sss), r, c1, , , e
NEXT i
k = k + 1
SLEEP (1)
NEXT j

c1 = 0: k = 1
SCREEN 13
CLS
FOR j = 1 TO 100
FOR i = 1 TO 290
c1 = c1 + 1
IF c1 > 240 THEN c1 = 1
COLOR c1
s = ABS(300 * RND(2) + j)
s2 = ABS(i + j - k - INT(i / 2))
PSET (s, s2), c1
CIRCLE (s2, c1), i, c1
NEXT i
k = k + 2
SLEEP (1)
NEXT j

Помогите пожалуйста решить 2 задачи

1) Дан текст. Получить те символы, которые встречаются в тексте по одному разу. Текст:"Тип данных задает определенный формат."

2)Даны две строки произвольного текста.Составить процедуру, проверяющую наличие запятых в тексте и заменяющую запятые точками. Определить также, сколько предложений в тексте. В программе обрабатываются 2 строки. Текст: "Со всех сторон слышались смех, песни, веселье. Народ смышлён и понятлив."

в бейсике. Работа с массивами. Найти минимальный элемент одномерного массива и его номер в массиве. Для формирования массива использовать датчик случайных чисел. Диапазон случайных чисел: от (-100 ) до +100.