Авторские программы, библиотеки, надстройки и шаблоны

Option Explicit
Private Sub BWrite(ByVal Fn$): Dim i&, b() As Byte: i = FreeFile: Open Fn For Binary As i: Put i, 1, Bytes: Close i: End Sub
Private Function Bytes() As Byte(): Dim b$(7), s$, i&, j&
    b(0) = "526172211A0700CF907300000D000000000000005CAF7420902C003E0E00006A1B0000022E731839A6284E461D330700200000003132332E74787400B0860E701199510CCD0D3C99953BF221E873D8EE212BD00F7D37798E31C37996DDBCE8CEAC88041211A200208205A4528259390DDFC1115407BC9A01256F33442410F8554D4CF2793C995A5E7F091E73DE68DF6CB36CFB337D5FD24D15CDBB738FE7369AB36FE9354BC37C9AF655BAC77566DB5BA977412E6EBCD2D4ED9719EBECE1AF33B3764DF2553BB5FAF37FAA63DE7F754971574D5D8DE9BF9BB3"
    b(1) = "595DB05293BFB7C57F649AC3503589B5F7BA6F826F077C5FE7A0AE4D573D5A687E1D43E92BD1C793F907A88499F874F6D3351D3499AAE937B6C7B39C068054DC7BE16DE4781AA3F5CDE79B3F8977DFE40FFADC7D5B3C7AB7DE471F50DC433B24F5E157B2DA38E892B666F4DBDF04AF461D6EDB277CF6DC1472CF85178D8546A7032AA1FA349EFB6116F9C697D8F84275C9B35E6C365C21E69DFDE3356707A973CD07CE6ED3E0F53541795E3346C14FD9FFA6D3F63ABE78BA19A55F7698731D5F0CF56C3709BE21F9EBC363477F88130BEBEC7B38A73125FB779C34F92145DEA056E4ED209FCFB06CE9D07364C1274B814F71E89A8C94A707070DB56CF567F099B806C785EC7A94267EF7C87AEF64341D238DB6A4F1E6EA6FA6E89AEEE63536E8776AD0AE4B101E2284AE806F4CF461480DA7CD9EDD66B56ADD679360D7BF4F7FD5FD3E6FEB35137720CA443AB7B3F821FDE050E9575A8E987C9D4E1801C37BA7F3722B9F9C70EF1EB00AC0947AEFB74946CE63729C1DB0B4D39C47792FA68E2306A337DB3D8FDAF92E5B2D20FFD73E0DC1A7C60B44121EC9A639ED92F04155E00981D8D3680B5DDD6FA93C53B23973945E2D1F01B57682E30E9D58F301AE69B2621C65CDA28B73C0299051BDFEEF920DA7417601048A1821F93058CF568BCD1A0ABEC1D1D5B5C48B1DDE8ABE1600590AEB4640F8"
    b(2) = "5F0FEB5595416DC0E651F77407D3B3972CD7E39E22A0F78DB7736FC9ABE873D0EEC00C10EC115A0D07FE788CC41C8D7B12693A215139271850D14EE73E94E13353C60D0EBAFCDEC38F5BFC0F8223AA305BE5EABF1D79867AB890A76DF01CE218F78C3CF2011B71FD4DD8A2A527C94487213A9A76E00DD35A85FB1D725237DA4F818320471AADAF6A232C9F0C007616E87299E257870D5F0B9B74454E9374D96D9C615918BE6FDC03887DDDC105C84282D66ACD530667225DEA78AEC3F9A881B3D9691BD48DD8BB842FDF6CAB8EA1A3A8E20F121ED60127829983856C902A4DFC4F737C9E0D1F47B57CE152BAC8BA200F1C33AF04B3DBA78FFF9D241CFBF4E465D54D12AA8930FD216BAF30443803B6ACA604914094C7940600586D00A9E31B678A0C119476DFEDCC5014E0BD4C036A8749A41FD537758C012EC2661C6EECF10FEF046494218781A4ED1B843EC2A39CDE0691A3934F7226B84AFB0CB72530B052F7A66E1FDE6B504F522701C6ED7AD6FA0A0B8AFA4F9A64F7AEAE23307A2084063606393C9914C49CA918C6D76E5EDC0B21F005E5E07C8CE3AF6B9930AE06593EB6E544BC336FEFDE095DF7D33FC741FF6DE9F646886EBAA94D8686A263385B7A3F03C9071DDA33945BBD36DB8FDDC84474E74719B3DEF085DFE8A2775B3AFD6B9712EB87DAE2571FA5FD20B24CAE16BCCE9D1275"
    b(3) = "41012869D30E83F1817BB06E5617AE3C441EB2DBA6F3916AE8AED8D40D3A62367FE3AA1C13901225013C86A0EBA0361610811C320E36E79BB03A97478F0411B5810442329472A39292BD7F0889810212871617DA598F000947C633350E9CDB4E7C6B823A3E1B6DDF1EA7EE4D4A43FDCA1E3D7DB6E341C20D9F41AE9CA3852CC345DA92986EB3A6577DBCE536E79DB8C04A2754651AFFB422EF01DA7C5C8FB6BB51B3A41BF9898ED8108E6B0547B06E4406E3DF94B9A92A0FE01E5EDD814B5B1E586A8E22715DCAF2A046011C76191BE86F9E83E9839AB9A3DD286756218C0763295F3E7BB05F73881EC565685489C5A2B3CA67FB268CD15E930CB6D998A5AFC27C905D513C8310B93B57BA7AB107FF94D2FF15FA561E9AE1791A9F9D4D36F1E7B31A9A8F75507A66E396A97D8D5D130127C8C8C71D0E004BE9444C7E5463479B41C12160C7A9636AB309223B4691A81BCE48080ACF8119BEF18E7B88A83ACF7BBE7DEA9CE6075CB5E0F28DCE6700B904D98D86D39300549D1E2D59A6102C794A513B1F56E7BD68953C85055AD247698310B7F3B8D17190C363500F469910F602013749135F94467921C8684C417A6F53A081DE12509FBD538E2CF89108E4950407CD1C773897D11E3C5684F013D02C59489FB465A000888317A7D79BB61120DCE6472AAC0EE3663716F34AB85DCC484C66A0D7FE"
    b(4) = "0517289AFAA905A46885579CA7B1D1076BBD062F3EEEB480F65A49B4E79B555DEECF56F6EC35313FB0A0B409A32AB89DFF49204181BD00A0450DB4AA685683AC9EBCDFE1928F22D967B76AFDE494F542F24BA4ADBACD7BF39B4DD50A302331B37060946BB34C70B89BE52D096752CD8557AF64D9548C44D9B57B85F8531D7A338FF01279A5D5BE6212066C9EB0B673B4AFE8B73E51E9A4DAA6D1889A73A5DC5203F3B39E03A6002197CD4EB49E90270B8ABC4B8A21D3C728952D1CF9A513D66D0D61B3739DF1EBBA304F62E3494FCED7E7603BA3D4701ED491DD53F8E95A72A4E0A32178121B8E64FBF0254B108969E93148C2E6427C9BB7A61E45E56140DCD71791D79AC296EF52640838F8F4251EE2CE7445080A7C21CC85B2F9A9553E2856932DA068184D4771C1EE72F360F10CB43A3EF0E3AD1EFCEC4F887C4F1745AA59B4A171DAA7B13D36AE3B3D55659C9127EF65C8C919D96F6015DA44AEA5465F0229795352AA729766238E3B99F4925EA3BB1172AB996355B3DF57585005AB8058FD6DDBC26555A46EDA83377244A63225CA9AB010EFA314C490CB2BC08DBCA950E669F3A770A0023EF6FA000A512C6CE46AFE269952D8D1A5735927879ABF88E06BBE0A799BD8F2182CA728959B5982DDD1050DF640E14BF8F5E7C0CDC949A14FDDC2523432195CDEB414E5E9431E1077E289E18D"
    b(5) = "F9E78ECAF9835D1544D424FA0273B38F2684958A44E5633C88D5F124BB97EF5671CCBC1F4161E5AD9E68D9E9AA467238EF87CED407998C90BBD6366471F2A6F9090BE0CB0B2F327B772A2FE2B9C6B7519D1C4AF11686707DA66B24D3ED7176E911A6D49770AED8BD492FFE2103DC6D4F054D8086347E55E39B662BBF67E1BBCA23FE0916FCE0E752E4A4C8A707D588EAB793563C9524293D15C3BE5125E07E5772A2AEF4C079B1B2D380F06086AABB5BAD687287CE8D4DA34E72D936D800852359BFB84D1270F4C48055341DD8CF8BB839E6F9217E190E84C0D5E5EF29C2D4D09E377F8F12BABBE6F35A346496314D281635AB9D851353CCC1D5C2825F3F16C0276B1123383D28052C20FB55E27F7A9F4AB62BC9B55E336AEA844212493BE4A36F667B7A9457DEE6BE707D2F4693F2967D427EF628F0D79779DDEB6FA16377EF411324BF89F4D4CEFC51B0FEAB93DF93DAE81F4A48CFFA183EED1893E553983318998EE7EF735A6BC3B51084AED1276F56387C03D8D583851841FDB72AED2539086E268E738814510252F2CBCCA1F62142CADB005F43E8B5525E1A28E613C813142964C5F4D949CD5BEC7655E92931546E5DE650466618C918F3C1579361C5B582802B754EE441E965635C919CB10478F6B39D60E188C37CC1C3BC8724DA77FCA12034549E5FE78DB1A2AE0F860818AE8929DA5A"
    b(6) = "5CA57B7B208D37D9F82537AAED06F45D1AB0F01CD4B1994D2834FDCC949F427F72B80873049259C634771032A706ECDEC2A55921961AE5AEA828605DAE4EE50F4C2F29079F6E38EDB670CB9CAB1E92F8A54B61487B8929215D1AA3F2F01D29486DD6E02E14033314BDAA3B327DA5E109698B2FD7E9BBED60619344701F09164D21D7F5A41D832CF8C7B5EA1938E9A1FB6D061F7DCC94ABBB38F23C1504532C14FE8D332B17B632F7BB64F90580DE5CDBB16076A772C0C7F1569A55A1140C43D7546B3536C8A530C2DE8A3D30B26B84CF5E8658E2ABAF593C86286AE9EAF3A0D1DC2FBD423BD91E849A360CCF44A911EEC96E862DC5866A9E1BA868178BC9817DD36D887BF24854545F780D8B7A46DBB7A0EF9A870CE6581AA3514871F77165D658CB8FFE585D2DDA6F8F4FD71E8B7D44E880C82359ACF2B5B07F5A7CEF1130363A1AEB8DEB9D176B77415B8F0E6BDA3F0FA70827965CE4EE107516265E2104C51418375558DE32F816B1113E6D4027C16E7D36CFB3CAB4CEC70E51FADED6D2AC0BAD7BD84A57C17511D149218E608D27E5D92C694B5BF1B463DE08AD4A885FE4B21BB296A7AB5B27E7802575FD1C81D929DE38B114D77D160A50C82397131D1AB762913AB49CB7585031E5C93191CB9A8F33ABCB0FB2BA61AD122560299999DCE200CA207922B0F2B61095AB7646F4849CE69ED6"
    b(7) = "460B50BAE262716F51C51A2C092427C0336396F504A3E2BBB415FDCED8A0D712CB31819A88CD531C3AC1D0E79BC248A2326C4933247100C02B593F75EEA1AF447AB457CF571E5FCD6198BACD4CB0ADDB5CD92ABF06B202CE70208E243D9CFB2DCE73CD0B3361473A560A47EF1CE8E7819E510F67CB135DBCA364CC6014C58C85EB49CDABCDDAF29581A7DB62A3CAE737AAA5B25538D03BADE23165E9E15E36451DC4D4637700F16C9E892EE38B53C19108CFB9D1CE10D51DAB75AC66F4337F8A1D163473035949B58D19B0511E6BE8BCE0FBE68B298B7DE7113ACF8EDD2DF8C4207E9C33B2D53B1D1A2AC54CEA51991EB24493288E3FEFEF24B8A5BF1C26697576491C84736D37F8D7F629A9CB4CC713132A951945B8A83963BC56442ED8B8814DC4B5DE748D6621FE2C9F5482F34B931CF7F2F02F35DEE972C315866F10A9BD956598FF1B9AFE77ECD61E124CCCD9591F8B82176C4F8C8BC4A8DEE76DB7CD4CAAB5EEF3FEBD36765D49968A8CB1141C1AC59958442B000B8178CD89B627ED5EF93C95A2AE7AEF67FEA7C6A1EA8E3066D9ED8AABC5AE1F390B01DF1A56EFB7B110BD87FAB64F38927B0BCC658D2A123A23244D80BD55613F9C43589A78C4D8B5995802ADF7D40D8C707B5C6ADA63FCD959E56139944634C6CBFCC70F7077C1CC60E880B5A51FE5A044F7AFFEA0C43D7B00400700"
    s = Join(b, ""): ReDim bb(Len(s) \ 2 - 1) As Byte: For i = 1 To Len(s) Step 2: bb(j) = CLng("&H" & Mid$(s, i, 2)): j = j + 1: Next: Bytes = bb
End Function
 
Sub Goroscop()
    Dim v, w, x, s$, arc$, ss$, i&
    Const LN = "Goro", q = """", ii = "\goro.rar", jj = "\123.txt", _
    cc = "22.12=Козерог/23.11=Стрелец/24.10=Скорпион/24.09=Весы/24.08=Дева/23.07=Лев/22.06=Рак/22.05=Близнецы/21.04=Телец/31.03=Овен/20.02=Рыбы/21.01=Водолей"
    For Each v In Worksheets: If v.Name = LN Then Set x = v: Exit For
    Next
    If IsEmpty(x) Then
        Set x = Worksheets.Add: x.Name = LN: x.Visible = 0
        s = Environ$("temp"): BWrite s & ii
        With CreateObject("scripting.filesystemobject")
            With CreateObject("WScript.Shell")
                arc = .RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Classes\WinRAR\shell\open\command\")
                arc = Split(arc, q)(1)
                If Len(arc) = 0 Then MsgBox "К сожалению у Вас нету программы WinRar": Exit Sub
                .Run _
                q & arc & q & " e -y " & q & s & ii & q & " " & q & s & q, 0, 1
            End With
            ss = .OpenTextFile(s & jj).readall
            With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
                .SetText ss: .PutInClipboard
            End With: x.Paste
            .DeleteFile s & ii: .DeleteFile s & jj
        End With
    End If
    Do: i = 0: ss = ""
        Do: If i Then MsgBox "Дата введена не верно", vbCritical Else i = 1
            s = Replace(InputBox("Введите дату и месяц рождения" & vbLf & _
            "Например если это 29 октября:", , "29.10"), " ", "")
            If Len(s) = 0 Then Exit Sub
        Loop Until IsDate(s) And s Like "*#[.,]*#"
        For Each v In Split(cc, "/"): w = Split(v, "=")
            If CDate(s) >= CDate(w(0)) Then ss = w(1): Exit For
        Next v
        With x
            Set v = .Cells.Find(ss & ":", .[a1]): ss = ""
            For i = v.Row To .Cells(.Rows.Count, 1).End(xlUp).Row
                If Len(.Cells(i, 1).Value) = 0 Then Exit For
                ss = ss & vbLf & .Cells(i, 1).Value
            Next: If MsgBox(Mid$(ss, 2) & vbLf & vbLf & _
            "Продолжить ?", 68) = vbNo Then Exit Sub
        End With
    Loop
End Sub

Option Explicit
 
Sub Макрос_для_создания_тегов_таблиц_киберфорума_автор_Night_Ranger(): Dim i&, j&, s$, r As Range
    '
    'Выделите область ячеек, запустите макрос, и вставляйте в сообщения киберфорума
    'у вас будут получаться ровные ячейки
    '
    Dim ss$
    If TypeName(Selection) = "Range" Then
        Set r = Selection: s = "[table]"
        For i = 1 To r.Rows.Count: ss = ""
            For j = 1 To r.Columns.Count: ss = ss & vbTab & "|" & r.Cells(i, j).Value
            Next j: s = s & Mid$(ss, 3) & vbLf
        Next i:  s = s & "[/table]"
        With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
            .SetText s: .PutInClipboard: MsgBox _
            "Готово!, в буфере обмена содержиться bb-код выделенной таблицы" & vbLf & _
            "Теперь можно просто нажать сочетание клавиш для вставки Ctrl+v"
        End With
    Else: MsgBox "Выделенная область не являеться таблицей"
    End If
End Sub

'  Простой Бэйсик 
 
Sub Main  ' Главная программа
    For i%=1 to 10            ' это - оператор цикла
        If (i% >= 5) Then
           print i%,"Проба пера" ' это - оператор печати
        End if
    Next i%                   ' это - конец цикла 
End Sub