BhBp Visual Basic For Application Pieces

05/05/2026

VBA ми е слабост и веднага ще поясня защо. Искам да го кажа просто. Но това е много трудно. Все едно да напишеш с думи ръководство как се вързва вратовръзка или как се издухва бутилка на Клайн. Ето един случай от практиката в който AI не може да помогне.

Работя с MS WORD - велик редактор -и правя една проста таблица с няколко колони и N реда в които записвам: В първата колона нещо на български, във всички останали - нещо на английски. Много е досадно, когато увлечен в писането изведнъж поглеждаш към екрана i wivda[, `e si pisal na anglijski. Ami towa e rezultatyt, dori move da byde i po-zle za]oto нвьусьшкихьшь здаиеафь хь нсисвсъь спь иьювс(хс иьюхдусахдяшс ........И като ти се случи това няколко пъти ти идва не знам какво да направиш, но скърцането със зъби не помага.
Какво направих ли? Ами малко код и сега съм по-продуктивен и спокоен. Какво прави кодът ми.
1. Проверява дали курсорът е в таблица или не.
2. Ако е в таблица проверява в коя колонка съм
3. Ако съм в първа колонка превключва клавиатурата на кирилица
4. Ако съм в коя да е различна от първа колонка - превключва на английски.

От тук нещата лесно могат да бъдат модифицирани. Примерно имате една таблица с 50 колонки
На кирилица трябва да пишете в колонки 1, 3, 5, 12, 18, 34, 44, 49. Във всички останали трябва да пишете на английски.
Малко променяте кода. Предварително на най горния ред в колонки 1, 3, 5, 12, 18, 34, 44, 49 записвате BG, а в останалите колонки или ENG или нищо. Кодът Ви вече проверява при събитието WindowSelectionChange какво е написано на първия ред на съответната колонка. Ако е BG – сменя на български. Ако е ENG или нищо – сменя на английски.
Ами това е. Мога да обясня подробно, ако някой прояви интерес, макар че за 30 години малцина са се осмелявали да погледнат какво има зад белия лист за писане – една вселена или бабата на AI и ChatGPT наречена алгоритмизация. Причини за това много, но най-съществената е локализацията на офис пакетите на български език и произтичащия от това ефект на недостроената Вавилонска кула.

Private Sub App_WindowSelectionChange(ByVal Sel As Selection)
'MsgBox Application.Keyboard
'If Selection.Tables.Count = 1 Then
If Sel.Information(wdWithInTable) Then
'MsgBox Sel.Information(wdWithInTable)
'MsgBox "Вие сте в таблица PROBA!" & Chr(13) & Selection.Columns(1).Index
If Selection.Columns(1).Index = 1 Then
'Application.Keyboard &H402 'BG
'Application.Keyboard &H30402
Application.Keyboard (1026) ' BG BDS
SendKeys "^+" 'Ctrl+Shift
'Application.Keyboard (132098)
'Application.Keyboard (263170)
'Application.Keyboard (-256965630)
Else
'Application.Keyboard &H409
Application.Keyboard (1033) 'ENG
'Application.Keyboard (67699721)
End If
End If
End Sub

16/03/2026

Едно е да извличаш звуци, друго е да изпълняваш концерти, трето е да композираш музика

16/03/2026

И най-оживеното и посещавано място някога е било гола поляна

09/03/2026

VBA се чувства чудесно с поддръжката на AI.
Това, което преди ставаше за часове, сега се прави за минути. Има, обаче един съществен момент. Трябва да знаеш какви са възможностите, да знаеш какво да попиташ, как да попиташ. Ето един пример. Не е пример за подражание защото в бързината е зададен малко некоректно.

vba MS WORD
тАБЛИЦА В КЛЕТКА, КОЯТО СЪДЪРЖА ЧИСЛО N СЪМ. КОД ЗА N+1 ЗА ВСЯКА СЛЕДВАЩА КЛЕТКА ДО КРАЯ НА КОЛОНАТА ИСКАМ

Правилното е нещо такова

VBA MS WORD
В ТАБЛИЦА В КЛЕТКА, КОЯТО СЪДЪРЖА ЧИСЛОТО N СЪМ. ИСКАМ КОД ЗА N+1 ЗА ВСЯКА СЛЕДВАЩА КЛЕТКА ДО КРАЯ НА КОЛОНАТА

В резултат на това ще се създаде код, изпълнението на който ще покаже нещо такова
1
2
3
4
5
6
7
54

Курсорът е бил в клетка с 1
Последният ред на таблицата е 54

А ето и генерираният код. Доскоро само да го напишеш щеше да мине доста време дори да ти го диктуват.

Sub CommandButton176_Click()
'Попълва с числа клетките в активната колона на таблицата като ги увеличава с 1 и стига до последния ред на таблицата
Dim tbl As Table
Dim startCell As Cell
Dim startRow As Long
Dim colIndex As Long
Dim lastRow As Long
Dim n As Long
Dim r As Long
Dim cellText As String

' Check if cursor is inside a table
If Not Selection.Information(wdWithInTable) Then
MsgBox "Постави курсора в клетка от таблица, която съдържа число N.", vbExclamation
Exit Sub
End If

Set startCell = Selection.Cells(1)
Set tbl = startCell.Range.Tables(1)

startRow = startCell.rowIndex
colIndex = startCell.ColumnIndex
lastRow = tbl.Rows.Count

' Read current cell text and remove end-of-cell markers
cellText = CleanCellText(startCell.Range.Text)

If Not IsNumeric(cellText) Then
MsgBox "Текущата клетка не съдържа число.", vbExclamation
Exit Sub
End If

n = CLng(cellText)

' Fill all cells below in the same column
For r = startRow + 1 To lastRow
n = n + 1
tbl.Cell(r, colIndex).Range.Text = CStr(n)
Next r
End Sub

22/10/2025

VBA код може да се създава с chatGPT или друг подобен AI. този процес е сравнително лесен за по-елементарни неща, но човек трябва точно да знае какво иска и да постави задачата правилно пред chatGPT. Най-важното за да бъде решена една задача е правилно поставеното условие.

Ето един примерен елементарен въпрос поставен на chatGPT:

vba EXCEL Код, който вмъква празен ред над текущия и копира текущия ред върху вмъкнатия

21/10/2025

21/10/2025

Много пъти съм си мислил за универсален VBA код, който да работи и в MS WORD, и в MS EXCEL, Corel DRAW.
Това не е невъзможно, но сега не искам да теоритизирам. Ето един въвеждаш ред, който има задача да разбере кое прилойение се изпълнява, за да може чрез IF.......THEN да изпълнява онези сегменти от кода, които са работещи във WORD или EXCEL или COREL
Msgbox Application.Name

Ето още един пример за универсален код, който ще работи на трите приложения
Msgbox Date или
Msgbox Time

А ето и код, който е специфичен за всяко приложение
Msgbox ActiveDocument.Name - ще работи във Word и Corel DRAW

Подобен код за Excel би изглеждал така:
Msgbox ActiveWorkBook.Name - ще работи само в Excel

За да работи и в трите приложения кодът би трябвало да проверява в кое приложение е стартиран. Ще изглежда приблизително така:
Sub ActiveDocumentName()
If Application.Name = "Mikrosoft Word" or Application.Name = "Corel" then
Msgbox Activedocument.Name
Endif

If Application.Name = "Microsoft Excel" then
Msgbox ActiweWorkBook.Name
Endif
End Sub

30/09/2025

Днес ми се случи следното и не за първи път. Имам електронен магазин. В него имам списък със стоки. Филтрирал съм списъка и резултантният списък съдържа само ПропИвит. Това са десетина реда защото има различни разновидности: ПропИвит 900 г, ПропИвит 400 г, ПропИвит 250 г, ПропИвит 11 г, ПропИвит 900 г Усилена формула + 10 г млечице, ПропИвит 900 г Усилена формула + 20 г млечице, ПропИвит 900 г Усилена формула + 30 г млечице, ПропИвит 900 г Усилена формула + 40 г млечице, ПропИвит 4 х 10 г сух
Използвам експортиращата програма на електронния магазин да ми експортира всички ПропИвит продукти с цени без ДДС в BGN в Excel документ за да мога от тези цени да получа цените с ДДС в лв. и в евро. След това този файл на Excel го използвам за да вкарам имената на продуктите и цените в CorelDraw за да ми отпечата етикети за физическите магазини.

Принципно това е схемата, но се оказва, че Windows ми е настроен така, че десетичен знак ми е запетаята, а експортираните данни са с десетичен знак точка.

Получавам следния експортиран в Excel списък
ProductCode ProductPrice
PROPIVIT_900_STANDARD 42.00000
PROPIVIT10 52.00000
PROPIVIT40 82.00000
PROPIVIT30 72.00000
PROPIVIT20 62.00000
PROPIVIT_400 18.70000
PROPIVIT_110 5.15000
PROPIVIT_250 11.70000

Питам chatGPT за VBA код и след няколко уточняващи въпроса той най-накрая ми дава следния код.

Private Sub CommandButton81_Click()
Me.Hide
Dim cell As Range
Stop
Dim txt As String

For Each cell In Selection
If Not IsEmpty(cell.Value) Then
txt = CStr(cell.Value)
txt = Replace(txt, ".", ",")

If IsNumeric(txt) Then
' закръгляме до 2 знака
cell.Value = Round(CDbl(txt), 2)
' форматираме винаги с 2 десетични знака
cell.NumberFormat = "0.00"
Else
cell.Value = txt
End If
End If
Next cell
End Sub

Ами това е. Маркирам цените и пускам макроса като натискам бутона и резултатът е следният:

ProductCode ProductPrice
PROPIVIT_900_STANDARD 42,00
PROPIVIT10 52,00
PROPIVIT40 82,00
PROPIVIT30 72,00
PROPIVIT20 62,00
PROPIVIT_400 18,70
PROPIVIT_110 5,15
PROPIVIT_250 11,70

Точно този, който ми трябва. Добре, че знаех какво да попитам chatGPT и да го насоча. Обръщам внимание на реда STOP в кода. Много удобна команда за Debug Step by Step с F8

21/09/2025

Диалогът SaveAs се отваря в MS WORD при първото записване на файла или от менюто SaveAs когато искаме да запишем файла с друго име, в друга папка.
Долният код е изключително важен. Той прави следното"
Запомня папката на активния документ
Преработва името така, че в края му добавя Time Stamp
Отваря диалога Save As. Много добре е, че така промененото име се поставя в полето File name:

Private Sub CommandButton138_Click()
'Private Sub CommandButton131_Click()
CommandButton131.BackColor = vbRed
'Sub SaveWithTimestamp()
Dim doc As Document
Dim filePath As String
Dim folderPath As String
Dim fileName As String
Dim fileExtension As String
Dim baseName As String
Dim newFileName As String
Dim timestamp As String
Dim timestampLength As Integer
Dim saveFileDialog As FileDialog

' Define the length of the timestamp (14 characters: yyyyMMddHHmmss)
timestampLength = 14

' Get the active document
Set doc = ActiveDocument

' Check if the document is saved
If doc.path = "" Then
MsgBox "The document is not saved. Please save it first.", vbExclamation
Exit Sub
End If

' Extract the document path, file name, and extension
filePath = doc.FullName
folderPath = doc.path & Application.PathSeparator
fileName = doc.name
fileExtension = Right(fileName, Len(fileName) - InStrRev(fileName, ".") + 1)

' Extract the base name (without extension)
baseName = Left(fileName, InStrRev(fileName, ".") - 1)

' Check if the file name ends with a 14-digit timestamp
If Len(baseName) >= timestampLength And IsNumeric(Right(baseName, timestampLength)) Then
' Remove the last 14 characters (the old timestamp)
baseName = Left(baseName, Len(baseName) - timestampLength)
End If

' Generate the new timestamp
timestamp = Format(Now, "yyyyMMddHHmmss")

' Create the new file name
If Right(baseName, 1) = "_" Then
newFileName = baseName & timestamp & fileExtension
Else
newFileName = baseName & "_" & timestamp & fileExtension
End If

' Open Save As dialog
Set saveFileDialog = Application.FileDialog(msoFileDialogSaveAs)

' Set the default folder and file name
saveFileDialog.InitialFileName = folderPath & newFileName

' Set the file type (same as current document)
saveFileDialog.FilterIndex = 1 ' The current file type (e.g., .docx for Word documents)

' Show the Save As dialog
If saveFileDialog.Show = -1 Then
' Save the document with the new name
doc.SaveAs2 fileName:=saveFileDialog.SelectedItems(1), FileFormat:=doc.SaveFormat
MsgBox "The file has been saved as: " & saveFileDialog.SelectedItems(1), vbInformation
End If
'End Sub

End Sub

Call now to connect with business.

21/09/2025

View/Zoom дава възможност образът на екрана да се увеличава/Намалява 75%, 100%. 200%. Page width, Text width, Whole page
А ето един бутон при натискането на който View се увеличава/намалява с 1% до удобна стойност в зависимост от стойността на cbZoom1_plus.Caption
cbZoom1_plus.Caption се задава от CheckBox1 - това е един чек бокс, малко квадратче, което мойе да е включено/изключено.

Private Sub cbZoom1_plus_Click()
'ZOOM_UP
If cbZoom1_plus.Caption = "ZOOM 1+" Then
ActiveWindow.ActivePane.View.Zoom.Percentage = ActiveWindow.ActivePane.View.Zoom.Percentage + 1
Else
ActiveWindow.ActivePane.View.Zoom.Percentage = ActiveWindow.ActivePane.View.Zoom.Percentage - 1
End If
End Sub

Private Sub CheckBox1_Click()
'MsgBox CheckBox1
If CheckBox1 Then
CheckBox1.Caption = "ZOOM 1+"
cbZoom1_plus.Caption = "ZOOM 1-"
Else
CheckBox1.Caption = "ZOOM 1-"
cbZoom1_plus.Caption = "ZOOM 1+"
End If
End Sub

Send a message to learn more

20/09/2025

Ето днешната функция.
Какво прави тя.
Предназначена е за работа с MS WORD. С малко доработка кодът може да се доработи така, че да е актуален и за MS EXCEL, MS ACCESS, CorelDRAW

За какво служи.
Когато се запише някакъв документ с име D:\PROBA\DOCUMENT1.DOCM той остава на това място D:\PROBA - в тази папка докато не се промени името по някакъв начин. Често това се прави с Save As от редактора WORD. Промяната нс името има смисъл, тъй като остават стари редакции на документа. При някакъв проблем се намалява риска от загуба на информация.
Активирането на функцията води до записване на активния документ с неговото име, като в края на името се добавя DateStamp и името става D:\PROBA\DOCUMENT1_20250920163545.DOCM - YYYYMMDDHHMMSS
При мен функцията се стартира чрез бутон, разположен на потребителска форма с Caption SAVEASTIMESTAMP F4
Името има само информазионна за оператора стойност. F4 в края напомня, че функцията може да се стартира и чрез натискане на клавиш F4.

Public Sub CommandButton131_Click()
CommandButton131.BackColor = vbRed
'Sub SaveWithTimestamp()
Dim doc As Document
Dim filePath As String
Dim folderPath As String
Dim fileName As String
Dim fileExtension As String
Dim baseName As String
Dim newFileName As String
Dim timestamp As String
Dim timestampLength As Integer

' Define the length of the timestamp (14 characters: yyyyMMddHHmmss)
timestampLength = 14

' Get the active document
Set doc = ActiveDocument

' Check if the document is saved
If doc.path = "" Then
MsgBox "The document is not saved. Please save it first.", vbExclamation
Exit Sub
End If

' Extract the document path, file name, and extension
filePath = doc.FullName
folderPath = doc.path & Application.PathSeparator
fileName = doc.name
fileExtension = Right(fileName, Len(fileName) - InStrRev(fileName, ".") + 1)

' Extract the base name (without extension)
baseName = Left(fileName, InStrRev(fileName, ".") - 1)

' Check if the file name ends with a 14-digit timestamp
If Len(baseName) >= timestampLength And IsNumeric(Right(baseName, timestampLength)) Then
' Remove the last 14 characters (the old timestamp)
baseName = Left(baseName, Len(baseName) - timestampLength)
End If

' Generate the new timestamp
timestamp = Format(Now, "yyyyMMddHHmmss")

' Create the new file name
If Right(baseName, 1) = "_" Then
newFileName = folderPath & baseName & timestamp & fileExtension
Else
newFileName = folderPath & baseName & "_" & timestamp & fileExtension
End If

' Save the document with the new name
doc.SaveAs2 fileName:=newFileName, FileFormat:=doc.SaveFormat

MsgBox "The file has been saved as: " & newFileName, vbInformation
'End Sub
End Sub

В някой от командните модули трябва да се включи функцията AUTOEXEC.
Тя се изпълнява, когато WORD се стартира.
Вътре в нея кодът е

Sub AutoExec()
'CommandButton131_Click
KeyBindings.ADD KeyCode:=BuildKeyCode(Arg1:=wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="save_active_document_as"
End Sub

Горния код указва, че при стартиране на WORD към F4 се свързва макроса save_active_document_as. Този макрос ще се изпълни при натискане на F4. Свързването на клавиш с макрос става чрез KeyBindings.ADD

Долният код е записан в някой команден модул и симулира натискането на бутона CommandButton131_Click, с caption SAVEASTIMESTAMP F4

Sub save_active_document_as()
UF_COMMANDS.CommandButton131_Click
End Sub

Обърнете специално внимание на Public
Това означава, че функцията е публична, т.е. достъпна е не само при натискане на клавиша във формата, но и от кой да е друг модул на проекта, както и от друга форма във проекта и др,

Стандартно бутоните във формата са с префикс Private
Private Sub CommandButton134_Click()
Но ако са Private, те са достъпни само от родителския обект или контейнер в който са и това е формата UF_COMMANDS
Чрез PUBLIC формата става нещо като чанта с инструменти и почти толкова лесно се използва. Как - ще видим. Но засега аналогията с чанта или библиотека е достатъчна. Потрябва ти инструмент - отваряш чантата/формата - Виждаш инструмента/бутона и го използваш. Ако ли пък няма подходящ инструмент - отваряш формата за редакция и създаваш новия инструмент като можеш да използваш кода на вече наличните инструменти/бутони или да напишеш нещо съвсем оригинално.
Стига толкова за днес. Ако има въпроси и коментари - моля!