Simple

понедельник, 29 июня 2020 г.

Проверяем актуальность версии СБИС оффлайн

Так получилось, что мне досталась внагрузку СБИС оффлайновая версии 2.4
Ну и приходится мониторить актуальность версии и регулярно ее обновлять.
Можно, конечно, каждое утро заходить на сайт СБИС в специальный раздел, но после трех раз эту задачу уже следует автоматизировать.
Вот Вам код сравнения актуальности Вашей СБИС и на сайте.
При необходимости корректируйте под Ваши нужды.
Для отправки почты используем старый добрый blat.
Сохраняем в sbis_ver_check.vbs, в эту же папку кладем blat, запускаем планировщиком или любым другим удобным способом.
На здоровье.

[code]On Error Resume Next

strNew=SbisNewVersion
strCur=SbisCurrentVersion

If strNew>strCur Then
'Wscript.Echo "Есть новая версия СБИС"
SendMail
'ElseIf strNew<strCur Then
' Wscript.Echo "Бред. У Вас версия новее, чем на сайте"
'Else
' Wscript.Echo "У Вас актуальная версия СБИС"
End If

Function SbisNewVersion
On Error Resume Next
strVersionCheck="https://sbis.ru/download?tab=ereport&innerTab=history"
a=GetText(strVersionCheck)
arr=Split(a,"<h2 class=" & chr(34) & "sbis_ru-header-h3" & chr(34) & ">")
If ubound(arr)<1 Then Wscript.Quit
b=arr(1)
i=Instr(1,b,"</h2>")
If i=0 Then Wscript.Quit
c=Ltrim(rtrim(Mid(b,1,i-1)))
If c="" Then Wscript.Quit
arrVer=Split(c," ")
strVer=arrVer(1)
SbisNewVersion=strVer
End Function

Function SbisCurrentVersion
On Error Resume Next
Set objFSO=Createobject("Scripting.Filesystemobject")
tmpVer=objFSO.GetFileVersion ("\\sbisserver\sbissharename\sbis.exe")
arrTmp=Split(tmpVer,".")
For j=0 to 2
Ver=Ver & arrTmp(j) & "."
Next
If Right(Ver,1)="." Then Ver=Left(Ver,Len(Ver)-1)
SbisCurrentVersion=Ver
End Function

Function GetText(strURL)
iTimeout=10
On Error Resume Next
GetText = ""
Set objXML = CreateObject("MSXML2.XMLHTTP")
objXML.Open "GET", strURL, False
objXML.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:77.0) Gecko/20100101 Firefox/77.0"
objXML.Send
x = Timer
Do
If Timer - x >= iTimeOut Then Exit Do
If objXML.ReadyState = 4 Then
If objXML.Status = 200 Then Exit Do
End If
Loop
strResult = objXML.ResponseText
GetText = strResult
End Function
Function FindText(strWhere, strFindStart, strFindEnd)
'
' Выделить кусок текста между выражениями strFindStart и strFindEnd в предоставленном тексте strWhere
'
On Error Resume Next
FindText=""
iFind=Instr(1,strWhere,strFindStart)
If iFind=0 Then Exit Function
iFindEnd=Instr(iFind +Len(strFindStart),strWhere,strFindEnd)
If iFindEnd<=iFind Then Exit Function
FindText=Mid(strWhere,iFind+len(strFindStart),iFindEnd-(iFind+len(strFindStart)))
End Function
Function GetPath
On Error Resume Next
arrPath=Split(Wscript.ScriptFullName,"\")
strPath=""
For i=0 to ubound(arrPath)-1
strPath=strPath & arrPath(i) & "\"
Next
strPath=Left(strPath,Len(strPath)-1)
GetPath=strPath
End Function
Sub SendMail
On Error Resume Next
Set objShell=Createobject("Wscript.Shell")
Set objFSO=Createobject("Scripting.Filesystemobject")
Set objFile=objFSO.OpenTextFile (GetPath & "\send.txt",2, True)
objFile.WriteLine "Добрый день." & vbcrlf & vbcrlf & "Ваша версия СБИС: " & strCur & vbcrlf & "Версия СБИС на сайте: " & strNew & vbcrlf & "Запланируйте обновление"
objFile.Close
strCmd=GetPath & "\blat.exe " & GetPath & "\send.txt -to recipient@domain.com -f sender@domain.com -u authsender@domain.com -pw P@s$W0rD -server mailserver.domain.com -charset windows-1251 -s " & chr(34) & "Новая версия СБИС" & chr(34)
objShell.Run strCmd,1,True
End Sub

[/code]

четверг, 15 августа 2019 г.

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

Понятно, что Вы можете включить учетку администратора с помощью групповых политик, но поменять пароль на учетку Вы не сможете (раньше можно было, да).
И да, LAPS мне не подходит.

Зато подходит такой вот скрипт:
Если хотите - можете часть функций обрезать и запихнуть в автозагрузку от лица машины.

[code]
Set objDomain=Getobject("WinNT://DOMAIN")
For Each object in objDomain
If object.Class="Computer" Then
If Ping(object.Name)=1 Then
print CheckAdmin(object.Name)
End If
End If
Next

Function Ping(strComputer)
Ping=0
On Error Resume Next
Err.Clear
Set objWMI = GetObject("winmgmts:\\.\ROOT\cimv2")
strQuery="select * from Win32_PingStatus Where address='" & strComputer & "'"
Set col = objWMI.ExecQuery(strQuery)
For Each obj in col
If obj.StatusCode=0 Then Ping=1
Next
' If Ping=1 Then print strComputer & " have ping" Else print strComputer & " have no ping"
End Function

Function CheckAdmin(strComputer)
On Error Resume Next
CheckAdmin=""
Set objComputer=Getobject("WinNT://" & strComputer)
For Each obj In objComputer
If lcase(obj.Class)="group" Then
If lcase(obj.Name)="администраторы" or lcase(obj.Name)="administrators" Then
Set objGroup=Getobject("WinNT://" & strComputer & "/" & obj.Name)
For Each objGroupMember in objGroup.Members
If Lcase(objGroupMember.Name)="администратор" Or LCase(objGroupMember.Name)="administrator" Then
Enable strComputer,objGroupMember.Name
Set objUser=Getobject("WinNT://" & strComputer & "/" & objGroupMember.Name)
bState=objUser.AccountDisabled
If bState=True Then
CheckAdmin=strComputer & "|" & objGroupMember.Name & "|disabled"
else
CheckAdmin=strComputer & "|" & objGroupMember.Name & "|enabled"
End If
End If
Next
End If
End If
Next
End Function
Sub print(strWhat)
On Error Resume Next
Wscript.Echo strWhat
End Sub
Sub Enable(strComputer,strUser)
Set objShell=Createobject("Wscript.Shell")
objShell.Run "c:\psutils\psexec.exe \\" & strComputer & " net user " & strUser & " Str0nGP@$$w)rD",0,True
Set objAdm=Getobject("WinNT://" & strComputer & "/" & strUser)
objAdm.AccountDisabled=False
objAdm.SetInfo
objShell.Run "c:\psutils\psexec.exe \\" & strComputer & " /s gpupdate /force /target:computer",0,False
End Sub
[/code]

понедельник, 29 июля 2019 г.

Хочу прописывать базы 1с через членство в AD

Копипастим скрипт, создаем в AD группы с именем 1cbase_bla-bla-bla
Добавляем туда пользователей.
В описание (поле info) пишем информацию о подключении к БД (никаких русских буков):
[DBCaption]
Connect=Srvr="1сservername";Ref="dbname";
OrderInList=-1
Folder=/
OrderInTree=-1
External=0
ClientConnectionSpeed=Normal
App=Auto
WA=1

Скрипт добавляем на вход пользователя и все - радуемся.

Если пользователь не в группе - ibases.v8i не будет изменен.

Все! Радуемся, пьем пиво и никуда больше не бегаем.

[code]
On Error Resume Next
Set objNet=Createobject("Wscript.Network")
Set objUser=Getobject("WinNT://" & objNet.UserDomain & "/" & objNet.UserName)
Set objFSO=Createobject("Scripting.Filesystemobject")
Set objShell=Createobject("Wscript.Shell")
strUP=objShell.ExpandEnvironmentStrings("%USERPROFILE%")
strFile=strUP & "\AppData\Roaming\1c\1cestart\ibases.v8i"
arrGroup=Split(GroupList,"|")
For i=0 to Ubound(arrGroup)
If IsMember(arrGroup(i),objUser.Name)=True Then
strBL=strBL & GetBaseInfo(arrGroup(i)) & vbcrlf
End If
Next
If strBL<>"" Then
Set objFile=objFSO.OpenTextFile(strFile,2,True)
objFile.Write strBL
objFile.Close
Set objFile=Nothing
End If
Set objShell=Nothing
Set objFSO=Nothing
Set objUser=Nothing
Set objNet=Nothing
Wscript.Quit

Function GetBaseInfo(strGroup)
On Error Resume Next
GetBaseInfo = GetLDAPValue("info", "cn ='" & strGroup & "'")
End Function

Function GetLDAPValue(strValue, strFilter)
On Error Resume Next
Const ADS_SCOPE_SUBTREE = 2
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
strQuery = "SELECT " & strValue & " FROM 'LDAP://" & GetLDAPDomain & "' WHERE " & strFilter
objCommand.CommandText = strQuery
Set objRecordSet = objCommand.Execute
Do Until objRecordSet.EOF
strVar = strVar & objRecordSet.Fields(strValue).Value & "|"
objRecordSet.MoveNext
Loop
If Len(strVar) > 1 Then strVar = Left(strVar, Len(strVar) - 1)
GetLDAPValue = strVar
End Function

Function GetLDAPDomain()
Set iAdRootDSE = GetObject("LDAP://RootDSE")
GetLDAPDomain = iAdRootDSE.Get("defaultNamingContext")
End Function

Function GroupList
On Error Resume Next
strGrouplist=""
Set objDomain=Getobject("WinNT://" & objNet.UserDomain)
For Each object in objDomain
If object.Class="Group" Then
If Left(Lcase(object.Name),7)="1cbase_" Then
strGroupList=strGroupList & object.name & "|"
End If
End If
Next
If Right(strGroupList,1)="|" Then strGroupList=Left(strGroupList,Len(strGroupList)-1)
GroupList=strGroupList
End Function
Function IsMember(strGroup,strUser)
On Error Resume Next
IsMember=False
Set objGroup=Getobject("WinNT://" & objNet.UserDomain & "/" & strGroup)
For Each objMember In objGroup.Members
If Lcase(objMember.Name)=Lcase(strUser) Then IsMember=True
Next
End Function

[/code]

пятница, 31 мая 2019 г.

Хочу на FreePBX динамические конференции с одноразовым паролем

Имеем: FreePBX, Exchange.
Задача: хочу динамические конференции, чтобы постоянно пароль менялся сам на произвольный и чтобы оповещение участников по почте приходило.

yum update -y && yum install epel-release -y && yum install ssmtp -y

Далее пишем файлы:
/var/www/html/conf.php:
<html>
<meta><title>It's easy to create new conference</title></meta>
<body>
<form method='POST' action='/makeconf.php'>
Please, enter emails of conference participants:<br>
<textarea name='emails' cols=80 rows=10>
username@domain.com
</textarea><br>
Enter here any additional text to include in email message:<br>
<textarea name='msg' cols=80 rows=10>
</textarea><br>
<input type='submit' value='Create'><br>
</form>
<br><br><br>
<font color=red><center><h3>WARNING!!!</h3>Conferences is valid only in today!!!<br>This conference will be automatically removed in 00:00</center></font>
</body>
</html>

/var/www/html/makeconf.php:
<?php
#
# Read values from conf.php
#
$emails=$_POST['emails'];
$msg=$_POST['msg'];
if (empty($emails)) {
echo "No emails were sent";
exit();
}
if ($email="") { echo "No emails were sent"; exit (); }
#
# Set default timezone
#
date_default_timezone_set('Asia/Yekaterinburg');
#
# Set database connection variables
#
$dbuser="freepbxuser";
$dbpass="5f2ecaef00a5bda7e7f16f00c616e484";
$dbname="asterisk";
#
# Trying to connect
#
echo "Connecting DB...";
$conn=mysqli_connect('localhost',$dbuser,$dbpass,$dbname);
if (!$conn) {
die('Error connecting MySQL DB');
exit();
} else {
echo "OK<br>";
}
#
# Get MAX of extension number
#
echo "Get new conference number...";
$res=mysqli_query($conn,"SELECT MAX(exten) FROM meetme;");
if ( $res ) {
echo "OK<br>";
} else {
echo "Error";
exit();
}
$row=mysqli_fetch_row($res);
#
# +1
#
$conf_num=$row[0];
$conf_num++;
#$res=mysqli_close($conn);
#
# Show conference number to user
#
echo "Conference Number: " .$conf_num ."<br>";
#
# Generate random PIN
#
echo "Generate new PIN...";
$newpin1=mt_rand(1000,9999);
$newpin=$newpin1;
echo $newpin."<br>";
#
# Convert current date/time to YYYY-MM-DD format
#
$date=date('Y-m-d');
#
# And insert it to the database
#
echo "Inserting values to MySQL DB for new conference...";

$query="insert into meetme (exten,options,userpin,description,timeout,adminpin,music) values (".$conf_num.",\"oTc\",".$newpin.",\"".$date."\",21600,\"\",\"inherit\");";
$res=mysqli_query($conn,$query);
#echo $query ."<br>";
if ( $res == TRUE ) {
echo "OK<br>";
} else {
echo "Error<br>";
exit();
}
exec("asterisk -rx 'database put CONFERENCE/".$conf_num." userpin ".$newpin."'");
exec('mysqladmin refresh');
exec("fwconsole reload");
$pin=$newpin;
#
# Prepare email message
#
$message="Hello\nYou are invited to join conference ".$conf_num." with PIN:".$pin."\n\n".$msg;
$email=explode("\n",$emails);
$z=0;
#
# And send the emails
#
echo "Sending emails...<br>";
while ($email[$z]<>"") {
echo $email[$z]."...";
$res=mail($email[$z],"Conference invitation",$message);
if ( $res == TRUE ) {
echo "OK<br>";
} else {
echo "Error<br>";
}
$z++;
}
echo "Done<br>";
#
# Reload FreePBX configuration
#
echo "Reloading configuration of FreePBX<br>";
exec("fwconsole reload");
?>
<a href="/conf.php">Create another conference</a>

/var/www/html/remove_old_conf.php:
<?php
#
# This will remove all conferences by filter
# We are writing current date to the description field in makeconf.php
# So, if date from conference is lower than current date - we should remove it
#

#
# Set default timezone
#
date_default_timezone_set('Asia/Yekaterinburg');
#
# Database connection variables
#
$dbuser="freepbxuser";
$dbpass="freepbxuser_mysql_password";
$dbname="asterisk";
#
# And connecting
#
$conn=mysqli_connect('localhost',$dbuser,$dbpass,$dbname);
if (!$conn) {
die('Error connecting MySQL DB');
exit();
}
#
# Get conf numbers and descriptions
# If you have static conferences you won't remove - you should exclude it here or below or some other way
#
$res=mysqli_query($conn, "SELECT description,exten from meetme");
#
# Convert current date/time to YYYY-MM-DD format
#
$date=date('Y-m-d');
$z=0;
#
# And compare with exten description in cycle
#
while ($row=mysqli_fetch_row($res)) {
$d=$row[0];
$e=$row[1];
if ($date > $d ) {
#
# If match - remove it and increment counter
#
echo "Remove ".$e."<br>\n";
mysqli_query($conn, "DELETE FROM `meetme` where exten=".$e);
$z++;
}
}
#
# Show counter to user
#
echo "Removed ".$z ." items<br>\n";
#
# Reload FreePBX configuration
#
if ($z > "0") { exec("fwconsole reload"); } else { echo "nothing to reload<br>\n"; }
?>

/etc/crontab:
59 23 * * * root php /var/www/html/remove_old_conf.php

/etc/ssmtp/revaliases:
asterisk:voip@domain.com:mail.domain.com:25

/etc/ssmtp/ssmtp.conf:
root=voip@domain.com
mailhub=mail.domain.com
RewriteDomain=domain.com
Hostname=voip.domain.com
FromLineOverride=Yes
UseStartTLS=No
Debug=No
AuthUser=voip
AuthPass=P@$$w)rD

Теперь сделаем, чтобы из IVR можно было добраться до конференции. У меня IVR, с которого я хочу сделать возможность звонить в конференцию - ivr-1.
/etc/asterisk/extensions_custom.conf:
[ivr-1-custom]
include =>ext-meetme

Делаем: mv /usr/sbin/sendmail /usr/sbin/sendmail.bak && ln -s /usr/sbin/ssmtp /usr/sbin/sendmail && service asterisk restart && service crond restart
И все должно заработать.
~~Это не совсем готовая инструкция, применяйте голову.~~
Теперь это готовый код. Проблема была в том, что нужно вручную записывать значение userpin через обращение к AstDB (ищите в коде database put)

Авторизацию на эту "админку" сами прикручивайте какую хотите.

понедельник, 27 марта 2017 г.

Опять Zabbix

Есть VPN-клиенты с УТМ(Мерката).
Захотелось мониторить некоторую информацию с этих машин.
Написал скрипты:
{{{
#!/bin/sh
hosts=`cat /usr/local/etc/zabbix32/zabbix/externalscripts/3-15`
for host in $hosts
do
host_end=`echo $host | cut -d "." -f 4`
hst=`echo $host_end"-10" | bc -ql`
if [ $hst -lt "10" ]; then
    hst=`echo "0"$hst`
fi
loss=`ping -s 32 -c 5 $host | grep "packet loss" | cut -d "," -f 3 | cut -d "%" -f 1 | cut -d " " -f 2`
code=`curl --connect-timeout 2 -s -I http://$host:8080 | grep HTTP | cut -d " " -f 2`
if [ -z $code ]; then
    code="0"
fi
warn=`curl -s --connect-timeout 2 http://$host:8080 | grep warn`
if [ -z $warn ]; then
    warn="0"
fi
if [ ! -z $warn ]; then
        echo $warn
        zabbix_sender -z 127.0.0.1 -s "Zabbix server" -k remote$hst.warnings -o $warn
fi
done
echo $loss
zabbix_sender -z 127.0.0.1 -s "Zabbix server" -k remote$hst.ping -o $loss
echo $code
zabbix_sender -z 127.0.0.1 -s "Zabbix server" -k remote$hst.httpcode -o $code
}}}
{{{
#!/bin/sh
hosts=`cat /usr/local/etc/zabbix32/zabbix/externalscripts/3-15`
for host in $hosts
do
host_end=`echo $host | cut -d "." -f 4`
hst=`echo $host_end"-10" | bc -ql`
if [ $hst -lt "10" ]; then
    hst=`echo "0"$hst`
fi
fsrar_id=`curl --connect-timeout 2 -s http://$host:8080 | grep FSRAR | grep PKI | cut -d ":" -f 2 | cut -d "-" -f 3 | cut -d " " -f 1`
version=`curl --connect-timeout 2 -s http://$host:8080 | grep version | cut -d ":" -f 2`
serial=`curl --connect-timeout 2 -s http://$host:8080/info/certificate/RSA | grep "SerialNumber" | cut -d "[" -f 2 | cut -d "]" -f 1`
exp=`curl --connect-timeout 2 -s http://$host:8080/info/certificate/RSA | grep "To:" | sed -e 's/]//g' | sed -e 's/ //g' | sed -e 's/To: //g'`
echo "\"Zabbix server\" remote$hst.version \"$version\"" >/tmp/315_daily.tmp
echo "\"Zabbix server\" remote$hst.fsrarid \"$fsrar_id\"" >>/tmp/315_daily.tmp
echo "\"Zabbix server\" remote$hst.serial \"$serial\"" >>/tmp/315_daily.tmp
echo "\"Zabbix server\" remote$hst.expire \"$exp\"" >>/tmp/315_daily.tmp
zabbix_sender -z 127.0.0.1 -i /tmp/315_daily.tmp
done
}}}
Ну ок, думаю, что надо создавать элементы данных для каждого клиента VPN. Один, второй, третий, данунахер!!! Их (клиентов) там 30 штук и внутри каждого по 5-6 элементов данных и прибывают.
Ок, что нам предложит заббикс? Zabbix trapper + discovery.
Для начала напишу скрипт для discovery, подумал я.
{{{
#!/bin/sh
names=`cat /3-15`
data="{\"data\":["
num=0
for name in $names
do
num=`echo $num +1|bc`
if [ $num -lt "10" ]; then
        num=`echo "0"$num`
fi
#echo $num
data=`echo $data"{\"{#REMOTE}\":\"$name\",\"{#NUM}\":\"$num\"},"`
done
data=`echo $data | sed "s/.$//"`
data=`echo $data"]}"`
echo $data
#zabbix_sender -z localhost -p 10051 -s "Zabbix server" -k remote.name -o '$data'
}}}
Ок, создаем шаблон. Делаем новое дисковери, даже называем его как-то. Переходим к созданию прототипов элементов данных и тут заббикс подкладывает свинью - он не умеет в качестве ключа и названия прототипа использовать макросы. Все, приехали.
Как вариант - надо попробовать прикрутить через API.

Спасибо за внимание.

пятница, 15 января 2016 г.

Перенаправление почты в Exchange 2003 по расписанию

Задача: пользователь уйдет в отпуск с 01 января по 11 января и его почту надо в его отсутствие пересылать другому пользователю.

Ок, вот Вам код - запускайте каждый час с ключом /SCHEDULE. Если без ключа - получите форму для управления списком.

Проект написан на VB6.
Сохранить в новой форме и все.
[code]
VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.Form Form1
AutoRedraw = -1 'True
BorderStyle = 3 'Fixed Dialog
Caption = "On-Vacation Replacement"
ClientHeight = 9105
ClientLeft = 45
ClientTop = 375
ClientWidth = 7950
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 9105
ScaleWidth = 7950
StartUpPosition = 3 'Windows Default
Begin VB.TextBox txtFilterField
Appearance = 0 'Flat
Height = 495
Left = 120
TabIndex = 1
Text = "Filter-field"
ToolTipText = "Поле для фильтрации"
Top = 5280
Width = 2895
End
Begin VB.CommandButton Command6
Caption = "Показать расписание"
Height = 495
Left = 2760
TabIndex = 8
Top = 5880
Width = 3015
End
Begin VB.TextBox txtcfgFile
Height = 2535
Left = 120
MultiLine = -1 'True
TabIndex = 9
Top = 6480
Width = 7695
End
Begin VB.CommandButton Command5
Caption = "Добавить переадресацию"
Height = 495
Left = 120
TabIndex = 7
Top = 5880
Width = 2535
End
Begin VB.TextBox txtDateTo
Appearance = 0 'Flat
Enabled = 0 'False
Height = 375
Left = 5760
TabIndex = 16
TabStop = 0 'False
Top = 5280
Width = 2055
End
Begin VB.CommandButton Command4
Caption = "По какое число"
Height = 375
Left = 5760
TabIndex = 6
Top = 4800
Width = 2055
End
Begin VB.CommandButton Command3
Caption = "С какого числа"
Height = 375
Left = 5760
TabIndex = 5
Top = 3720
Width = 2055
End
Begin VB.TextBox txtDateFrom
Appearance = 0 'Flat
Enabled = 0 'False
Height = 375
Left = 5760
TabIndex = 15
TabStop = 0 'False
Top = 4200
Width = 2055
End
Begin MSComCtl2.MonthView MonthView1
Height = 2310
Left = 3240
TabIndex = 4
Top = 3480
Width = 2415
_ExtentX = 4260
_ExtentY = 4075
_Version = 393216
ForeColor = -2147483630
BackColor = -2147483632
Appearance = 0
ShowWeekNumbers = -1 'True
StartOfWeek = 53149698
CurrentDate = 42284
End
Begin VB.TextBox txtVacationTo
Appearance = 0 'Flat
Enabled = 0 'False
Height = 375
Left = 3120
TabIndex = 14
TabStop = 0 'False
ToolTipText = "Этому пользователю будет перенаправлена почта пользователя уходящего в отпуск."
Top = 3000
Width = 4695
End
Begin VB.TextBox txtVacationFrom
Appearance = 0 'Flat
Enabled = 0 'False
Height = 375
Left = 3120
TabIndex = 13
TabStop = 0 'False
ToolTipText = "Этот пользователь в отпуске. Его почту необходимо перенаправлять в другой почтовый ящик"
Top = 1920
Width = 4695
End
Begin VB.CommandButton Command2
Appearance = 0 'Flat
Caption = "Этот пользователь замещает"
Height = 495
Left = 3120
TabIndex = 3
Top = 2400
Width = 4695
End
Begin VB.CommandButton Command1
Appearance = 0 'Flat
Caption = "Этот пользователь в отпуске"
Height = 495
Left = 3120
TabIndex = 2
Top = 1320
Width = 4695
End
Begin VB.ListBox List1
Appearance = 0 'Flat
Height = 4710
ItemData = "Form1.frx":0000
Left = 120
List = "Form1.frx":0002
Sorted = -1 'True
TabIndex = 0
ToolTipText = "Выберите пользователя"
Top = 480
Width = 2895
End
Begin VB.Label Label1
Caption = "Почта перенаправлена следующему пользователю:"
Height = 495
Left = 3360
TabIndex = 12
Top = 120
Width = 3255
End
Begin VB.Label lblAltRecipient
Height = 375
Left = 3360
TabIndex = 11
Top = 720
Width = 3375
End
Begin VB.Label lblDomain
Caption = "Label1"
Height = 255
Left = 120
TabIndex = 10
Top = 120
Width = 2895
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public strFile As String

Function ReadSchedules()
On Error Resume Next
Err.Clear
Open strFile For Input As #1
If Not Err.Number = 0 Then Exit Function
Do While Not EOF(1)
Line Input #1, strTemp
ReadSchedules = ReadSchedules & strTemp & vbCrLf
Loop
Close #1
End Function
Sub WriteNewSchedule(strString)
'
' After all checks in other prodecures we can finally write new schedule for our program
'
Open strFile For Append As #1
Print #1, strString
Close #1
End Sub
Function FindDuplicates(strString)
'
' Here we will check if we have already scheduled job with absolutely same parameters
' This means, that everything is equal: user-from;user-to;date-from;date-to
'
FindDuplicates = False
Open strFile For Input As #1
Do While Not EOF(1)
Line Input #1, strTemp
If LCase(strTemp) = LCase(strString) Then FindDuplicates = True: Exit Do
Loop
Close #1
End Function
Sub SetCfgFile()
strFile = App.Path
If Right(strFile, 1) = "\" Then strFile = Left(strFile, Len(strFile) - 1)
strFile = strFile & "\ovr.cfg"
End Sub
Private Sub Command1_Click()
'
' Users must not to be equal
'
txtVacationFrom.Text = List1.List(List1.ListIndex)
If LCase(txtVacationFrom.Text) = LCase(txtVacationTo.Text) Then
'
' Otherwise - blink
'
txtVacationTo.Text = ""
Blink_object_background txtVacationFrom
Exit Sub
End If

End Sub

Private Sub Command2_Click()
'
' Users must not be equal
'
txtVacationTo.Text = List1.List(List1.ListIndex)
If LCase(txtVacationFrom.Text) = LCase(txtVacationTo.Text) Then
'
' Otherwise - blink
'
txtVacationTo.Text = ""
Blink_object_background txtVacationFrom
Exit Sub
End If

End Sub

Private Sub Command3_Click()
'
' Check selected day-month-year
'
strDay = MonthView1.Day
strMonth = MonthView1.Month
strYear = MonthView1.Year
If strDay < 10 Then strDay = "0" & strDay
If strMonth < 10 Then strMonth = "0" & strMonth
strDateFrom = strDay & "-" & strMonth & "-" & strYear
txtDateFrom.Text = strDateFrom
'
' Date From must to lower than Date To
'
If txtDateFrom.Text = txtDateTo.Text Then
'
' Otherwise - blink
'
txtDateTo.Text = ""
Blink_object_background txtDateFrom
End If
If txtDateFrom.Text > txtDateTo.Text And txtDateTo.Text <> "" Then Blink_object_background txtDateFrom
End Sub

Private Sub Command4_Click()
'
' The same as Command3_Click() but working with other field
'
strDay = MonthView1.Day
strMonth = MonthView1.Month
strYear = MonthView1.Year
If strDay < 10 Then strDay = "0" & strDay
If strMonth < 10 Then strMonth = "0" & strMonth
strDateTo = strDay & "-" & strMonth & "-" & strYear
txtDateTo.Text = strDateTo
If txtDateFrom.Text = txtDateTo.Text Then
txtDateTo.Text = ""
Blink_object_background txtDateFrom
End If
If txtDateFrom.Text > txtDateTo.Text And txtDateTo.Text <> "" Then Blink_object_background txtDateFrom
End Sub
Private Sub Command5_Click()
On Error Resume Next
'
' Finally check all again
'
strUserFrom = txtVacationFrom.Text
strUserTo = txtVacationTo.Text
strDateFrom = txtDateFrom.Text
strDateTo = txtDateTo.Text
If strDateFrom >= strDateTo Then txtDateTo.Text = "": Blink_object_background Form1.txtDateTo: Exit Sub
If strDateFrom = "" Then Blink_object_background Form1.txtDateFrom: Exit Sub
If strDateTo = "" Then Blink_object_background Form1.txtDateTo: Exit Sub
If strUserFrom = "" Then Blink_object_background Form1.txtVacationFrom: Exit Sub
If strUserTo = "" Then Blink_object_background Form1.txtVacationTo: Exit Sub
If LCase(strUserFrom) = LCase(strUserTo) Then Blink_object_background Form1.txtVacationTo: txtVacationTo.Text = "": Exit Sub
strString = strUserFrom & ";" & strUserTo & ";" & strDateFrom & ";" & strDateTo
If FindDuplicates(strString) = True Then MsgBox ("Такая комбинация пользователь1;пользователь2;дата1;дата2 уже есть"): Exit Sub
'
' Passed
'
WriteNewSchedule (strString)
txtcfgFile.Text = ReadSchedules
End Sub

Private Sub Command6_Click()
'
' Read config file and show in text-box
' Even if user will change it - it doesn't matter. Enabled if this text-box set to True
' because in other case user will not be able to scroll text-box
'
SetCfgFile
txtcfgFile.Text = ReadSchedules
End Sub

Private Sub Form_Load()
On Error Resume Next
Const ADS_PROPERTY_CLEAR = 1
'
' Go check for some command-line arguments
'
strCmd = Command
'
' And if we got only one special command-line argument - go ahead, do your job.
'
If UCase(strCmd) = "/SCHEDULE" Then
'
' Get CFG File name and path
'
SetCfgFile
'
' Load everything from this file
'
a = ReadSchedules
'
' Split it and load into array
'
b = Split(a, vbCrLf)
'MsgBox ("Number of lines in file: " & UBound(b))
'
' Retrieve everyline and go into a cycle
'
i = 0
Do While i < UBound(b)
'If i >= UBound(b) Then MsgBox (i): Exit Do
'
' Now we need to parse CSV (Comma-Separated) File. Comma=";"
'
c = Split(b(i), ";")
'
' There is a cycle to easyly parse stupid checks below
'
For j = 1 To 1
user1 = LTrim(RTrim(c(0)))
user2 = LTrim(RTrim(c(1)))
datefrom = c(2)
dateto = c(3)
'
' Stupid checks but doing it
'
If CheckDate(datefrom) = False Then Exit For
If CheckDate(dateto) = False Then Exit For
If datefrom > dateto Then Exit For
If datefrom = dateto Then Exit For
If IsUserValid(user1) = False Then Exit For
If IsUserValid(user2) = False Then Exit For
If UCase(user1) = UCase(user2) Then Exit For
strUser1DN = GetLDAPValue("distinguishedName", "displayName='" & user1 & "'")
strUser2DN = GetLDAPValue("distinguishedName", "displayName='" & user2 & "'")
strDate = Date
dateto = CDate(dateto)
datefrom = CDate(datefrom)
If strDate = dateto Then
'
' Clear user1 AltRecipient field
'
Set objUser = GetObject("LDAP://" & strUser1DN)
objUser.PutEx ADS_PROPERTY_CLEAR, "altRecipient", 0
objUser.PutEx ADS_PROPERTY_CLEAR, "deliverAndRedirect", 0
objUser.SetInfo
ElseIf ((strDate >= datefrom) And (strDate < dateto)) Then
'
' Set user1 AltRecipient with user2 distinguishedName
'
Set objUser = GetObject("LDAP://" & strUser1DN)
objUser.Put "altRecipient", strUser2DN
objUser.Put "deliverAndRedirect", "TRUE"
objUser.SetInfo
End If
Next
i = i + 1
Loop
End
End If
'
' Auto-center form on load
'
Form1.Left = (Screen.Width - Form1.Width) \ 2
Form1.Top = (Screen.Height - Form1.Height) \ 2
'
' Read userlist from AD
'
Read_Users
'
' Set very important variable
'
SetCfgFile
End Sub
Sub Read_Users()
On Error Resume Next
'
' clear list
'
For i = 0 To Form1.List1.ListCount - 1
Form1.List1.RemoveItem (0)
Next
'
' Create network object
'
Set objNet = CreateObject("Wscript.Network")
'
' Get User's Domain
'
strDomain = objNet.UserDomain
'
' Connect to domain
'
Set objDomain = GetObject("WinNT://" & strDomain)
'
' Get object collection
'
For Each object In objDomain
'
' Filter only users
'
If LCase(object.Class) = "user" Then
'
' User's account must be enabled
'
If object.AccountDisabled = False Then
'
' Get user's email. That means that user must have email
'
strmail = GetLDAPValue("mail", "sAMAccountName='" & object.Name & "'")
'
' Filter only *@npcprom.ru users
'
If InStr(1, LCase(strmail), "@npcprom.ru") > 0 Then
'MsgBox (strMail)
'
' Check if user already have altRecipient
'
'strAlt = ""
'strAlt = GetLDAPValue("altRecipient", "sAMAccountName='" & object.Name & "'")
'If strAlt <> "" Then MsgBox (object.Name & vbCrLf & strAlt)
'
' If user have no altRecipient we can assign it
'
' Add to List1
'If strAlt = "" Then
Form1.List1.AddItem object.FullName
Counter = Counter + 1
Else
'
' not @npcprom.ru mailbox
'
End If
End If
End If
Next
'
' Show domain name and number of found users
'
Form1.lblDomain.Caption = UCase(objNet.UserDomain) & " (" & Counter & ")"

End Sub

Function GetLDAPDomain()
Set iAdRootDSE = GetObject("LDAP://RootDSE")
GetLDAPDomain = iAdRootDSE.Get("defaultNamingContext")
End Function

Function GetLDAPValue(strValue, strFilter)
Const ADS_SCOPE_SUBTREE = 2
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
strQuery = "SELECT " & strValue & " FROM 'LDAP://" & GetLDAPDomain & "' WHERE " & strFilter
objCommand.CommandText = strQuery
Set objRecordSet = objCommand.Execute
Do Until objRecordSet.EOF
strVar = strVar & objRecordSet.Fields(strValue).Value & "|"
objRecordSet.MoveNext
Loop
If Len(strVar) > 1 Then strVar = Left(strVar, Len(strVar) - 1)
If strVar = "|" Then strVar = ""
GetLDAPValue = strVar
End Function

Private Sub List1_Click()
'
' Change List's ToolTipText with default text
'
List1.ToolTipText = "Выберите пользователя"
'
' Clear some other values
'
lblAltRecipient.Caption = ""
lblAltRecipient.ToolTipText = ""
'
' Get user's displayName (in WinNT provider can be accessed via FullName)
'
strDisplayName = List1.List(List1.ListIndex)
'
' Get user's email
'
strmail = GetLDAPValue("mail", "displayName='" & strDisplayName & "'")
'
' If user's email is not empty - show it in list's tooltiptext where all users are shown
'
If strmail <> "" Then List1.ToolTipText = strmail
'
' Now check if user already have set altRecipient
'
strUserDN = GetLDAPValue("altRecipient", "displayName='" & strDisplayName & "'")
'
' If not - exit this sub
'
If strUserDN = "" Then Exit Sub
'
' If set - connect to this object in AD
' because altRecipient always set as some user distinguishedName if not empty
'
Set objUser = GetObject("LDAP://" & strUserDN)
'
' Let's show if we have altRecipient (get his displayName)
'
lblAltRecipient.Caption = objUser.DisplayName
'
' And show this user's email in ToolTipText
'
lblAltRecipient.ToolTipText = objUser.mail
'
' Show some black-to-red blinking
'
intdefcolor = lblAltRecipient.ForeColor
red = "&H000000FF"
lblAltRecipient.ForeColor = red
Sleep 500
lblAltRecipient.ForeColor = intdefcolor
Sleep 500
lblAltRecipient.ForeColor = red
Sleep 500
lblAltRecipient.ForeColor = intdefcolor

'lblAltRecipient.Caption = strDisplayName
End Sub
Sub Sleep(how_much)
'
' I do not remember internal Sleep function so I wrote it
' incoming parameter - miliseconds
'
x = Timer
Do
If Timer - x >= how_much / 1000 Then Exit Do
'
' Next line means - do not hangup while in cycle. Let other application do some work too
'
DoEvents
Loop
End Sub
Sub shake(object As Object, delta)
'
' 'Shake' an object means lift it left-right-up-down not much than delta
'
On Error Resume Next
xTop = object.Top
xLeft = object.Left
For i = 1 To 50
xDelta = (Rnd(Timer) * (delta \ 2)) - delta
yDelta = (Rnd(Timer) * (delta \ 2)) - delta
'
' Top and Left property of object cann't be lower than 0
'

If xTop + yDelta < 0 Then object.Top = 0 Else object.Top = xTop + yDelta
If xLeft + xDelta < 0 Then object.Left = 0 Else object.Left = xLeft + xDelta
'
' Get some sleep so user could see this shaking
'
Sleep 10
Next
'
' Turn back previously saved values
'
object.Top = xTop
object.Left = xLeft
End Sub

Private Sub txtFilterField_Change()
'
' Very cool search algorithm
'
If txtFilterField.Text <> "" And txtFilterField.Text <> "Filter-field" Then
'
' If anything is changed in search field - pass-through the list items and find first list item, which begins with searching text
' case-insensitive
'
strFilter = UCase(txtFilterField.Text)
For i = 0 To List1.ListCount - 1

If Len(List1.List(i)) >= Len(strFilter) Then
If UCase(Left(List1.List(i), Len(strFilter))) = strFilter Then List1.ListIndex = i: Exit Sub
End If
Next
End If
If txtFilterField.Text = "" Then List1.ListIndex = 0
End Sub

Private Sub txtFilterField_GotFocus()
'
'
'
If txtFilterField.Text = "Filter-field" Then txtFilterField.Text = ""
End Sub

Private Sub txtFilterField_LostFocus()
'
'
'
If txtFilterField.Text = "" Then txtFilterField.Text = "Filter-field"
End Sub
Sub Blink_object_background(obj As Object)
intOriginalColor = obj.BackColor
red = "&H000000FF"
For i = 1 To 3
obj.BackColor = red
Sleep 250
obj.BackColor = intOriginalColor
Sleep 250
Next
End Sub
Function CheckDate(strDate) As Boolean
'
' Checking date is valid
'

Dim days As String
Dim strDay As Integer
Dim strMonth As Integer
Dim strYear As Integer

CheckDate = False
days = "31;28;31;30;31;30;31;31;30;31;30;31"
arrDays = Split(days, ";")
arrDate = Split(strDate, "-")
If UBound(arrDate) < 2 Then Exit Function
strDay = arrDate(0)
strMonth = arrDate(1)
strYear = arrDate(2)
'Stop
If strYear Mod 4 = 0 Then arrDays(1) = 29
If strDay < 1 Or strDat > arrDays(strMonth - 1) Then Exit Function
If strMonth < 1 Or strMonth > 12 Then Exit Function

CheckDate = True
End Function
Function IsUserValid(strUser)
IsUserValid = False
strUserAcc = GetLDAPValue("sAMAccountName", "displayName='" & strUser & "'")
If strUserAcc = "" Or strUserAcc = "|" Then Exit Function
Set objNet = CreateObject("Wscript.Network")
strUserDomain = objNet.UserDomain
Set objUser = GetObject("WinNT://" & strUserDomain & "/" & strUserAcc)
IsUserValid = Not objUser.AccountDisabled
End Function
[/code]

Загрузка фотографий в Active Directory (автоматически)

Проект написан на VB6.
Запускать от лица админа или от лица, которому разрешено исправлять thumbnailPhoto аттрибут у других пользователей.
Также нужны права на запись в папку, где хранятся фотки для создания временных файлов.
Можете допилить создание временных файлов в любом удобно для Вас месте.

[code]
Attribute VB_Name = "Модуль1"
Private Function ResizeImage(ByVal Original As WIA.ImageFile, ByVal WidthPixels As Long, ByVal HeightPixels As Long) As WIA.ImageFile
On Error Resume Next
With New WIA.ImageProcess
.Filters.Add .FilterInfos!Scale.FilterID
With .Filters(1).Properties
!MaximumWidth = WidthPixels
!MaximumHeight = HeightPixels
End With
Set ResizeImage = .Apply(Original)
End With
End Function

Sub UpdateMe(strUserDN As String, strFile As String)
On Error Resume Next
Dim adoStreamRead As Object
Dim objUser As Object
Dim bytesRead As String

Const adTypeBinary = 1
Set objUsr = GetObject("LDAP://" & strUserDN)
Set adoStreamRead = CreateObject("ADODB.Stream")
Err.Clear
adoStreamRead.Type = adTypeBinary
adoStreamRead.Open

If Err.Number = 0 Then
adoStreamRead.LoadFromFile strFile
objUsr.Put "thumbnailPhoto", adoStreamRead.read()
Else
objUsr.PutEx ADS_PROPERTY_CLEAR, "thumbnailPhoto", 0
End If
objUsr.SetInfo
adoStreamRead.Close
Set objUsr = Nothing
Set adoStreamRead = Nothing

End Sub

'
' Some LDAP functions
'
Function GetUserDN(strUser As String) As String
GetUserDN = GetLDAPValue("distinguishedName", "sAMAccountName ='" & strUser & "'")
End Function
Function GetLDAPValue(strValue As String, strFilter As String)
On Error Resume Next
Dim objConnection As Object
Dim objCommand As Object
Dim objRecordSet As Object
Dim strQuery As String
Dim strVar As String
Const ADS_SCOPE_SUBTREE = 2
GetLDAPValue = ""
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
strQuery = "SELECT " & strValue & " FROM 'LDAP://" & GetLDAPDomain & "' WHERE " & strFilter
objCommand.CommandText = strQuery
Set objRecordSet = objCommand.Execute
Do Until objRecordSet.EOF
strVar = strVar & objRecordSet.Fields(strValue).Value & "|"

objRecordSet.MoveNext
Loop
If Len(strVar) > 1 Then strVar = Left(strVar, Len(strVar) - 1)
GetLDAPValue = strVar
Set objRecordSet = Nothing
Set objCommand = Nothing
Set objConnection = Nothing
End Function

Function GetLDAPDomain() As String
On Error Resume Next
Dim iAdRootDSE As Object
Set iAdRootDSE = GetObject("LDAP://RootDSE")
GetLDAPDomain = iAdRootDSE.Get("defaultNamingContext")
Set iAdRootDSE = Nothing
End Function

Sub Resize_and_Save(strFile As String)
On Error Resume Next
Dim imgPhoto As Object
Set imgPhoto = New WIA.ImageFile
imgPhoto.LoadFile strFile
Set imgPhoto = ResizeImage(imgPhoto, 100, 100)
imgPhoto.SaveFile strFile & "_min"
Set imgPhoto = Nothing
End Sub
Sub Main()
Dim objFSO As Object
Dim strFolder As String
Dim objFolder As Object
Dim objFiles As Object
Dim objFile As Object
Dim strExt As String
Dim strUser As String
Dim strUserDN As String

Set objFSO = CreateObject("Scripting.Filesystemobject")
' Next UNC MUST be enabled for writing!!!
strFolder = "\\SERVER\FOTO_FOLDER"
Set objFolder = objFSO.GetFolder(strFolder)
Set objFiles = objFolder.Files

For Each objFile In objFiles
DoEvents
a = Split(objFile.Name, ".")
strExt = UCase(a(UBound(a)))
If strExt = "JPG" And Len(objFile.Name) > 4 Then
strUser = a(0)
strUserDN = GetLDAPValue("distinguishedName", "displayName='" & strUser & "'")
If objFSO.FileExists(strFolder & "\" & objFile.Name & "_min") = True Then objFSO.DeleteFile strFolder & "\" & objFile.Name & "_min"
If objFile.Size > 0 Then
Resize_and_Save strFolder & "\" & objFile.Name
UpdateMe strUserDN, strFolder & "\" & objFile.Name & "_min"
objFSO.DeleteFile strFolder & "\" & objFile.Name & "_min"
End If
End If
Next
Set objFile = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End
End Sub
[/code]

понедельник, 29 июня 2020 г.

четверг, 15 августа 2019 г.

понедельник, 29 июля 2019 г.

пятница, 31 мая 2019 г.

понедельник, 27 марта 2017 г.