Автор: M1chA
Дата сообщения: 17.06.2007 23:58
Люди!помогите пожулуйста!
клиент попросил разобраться в том,как сменить время работы программы.
Что-то у меня не получилось понять эту фишку.
Выкладываю код основного модуля проги.
Язык:Excel VBA.
Если нужно,вышлю всю прогу на мыло.
[more]
Option Explicit
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Public Const kIdx As Integer = 3, kIdx1 As Integer = 4, kIdxV As Integer = 6, kIdxMagenta As Integer = 38
Public Const defPats As Integer = 335
Const strTextMenu As String = "Па&циенты" 'пункт меню
Const strMenuTun As String = "&Настройка"
Const strMenuHlp As String = "&Состояние"
Const strMenuNal As String = "&Журнал"
Const strMenuOtch As String = "От&чёт"
Const strMenuOtchDen As String = "Отчёт за день"
Const strMenuRas As String = "&Рестарт"
Const strMenuAut As String = "&О программе"
Const strMenuNew As String = "БД &пациентов"
Public nKol As Integer, Srok As Long, SrokV As Long, SrokMagenta As Long, kPats As Long
Public MinNal As Integer, MaxNal As Integer, prNal As Integer
Public RegVer As Boolean, RegEx As Boolean 'регистрация
Public today As Boolean, Rest As Boolean
Public kProg As Integer, kSvob As Integer, kVarn As Integer, kVarnMagenta As Integer
Public pswd As Long, ScreenX As Long, ScreenY As Long
Sub Auto_Open()
Dim btn As Object, n As Integer
Const idNal As Integer = 57, DneySaveComment As Integer = 5
Const defSrok As Integer = 30
Const defSrokMagenta As Integer = 20
Const defSrokV As Integer = 10
Const defMinNal As Integer = 8
Const defMaxNal As Integer = 12
'Параметры регистрации
Const kdPr As Long = 40
Const DRJuli As Date = #10/7/1969#
'Стартовые параметры
Rest = False
n = InStr(1, ActiveWorkbook.Name, "Patsienty.xls")
prNal = GetSetting(AppName:="Pobegay", Section:="Setup", Key:="prNal", Default:=1)
kPats = GetSetting(AppName:="Pobegay", Section:="Setup", Key:="kPats", Default:=defPats)
If prNal = 0 And n > 0 Then
Worksheets("Посещения").Visible = xlSheetVisible
Else
If Worksheets("Посещения").Visible <> xlVeryHidden Then Worksheets("Посещения").Visible = xlVeryHidden
RegEx = True
Exit Sub
End If
Srok = GetSetting(AppName:="Pobegay", Section:="Setup", Key:="Srok", Default:=defSrok)
SrokMagenta = GetSetting(AppName:="Pobegay", Section:="Setup", Key:="SrokMagenta", Default:=defSrokMagenta)
SrokV = GetSetting(AppName:="Pobegay", Section:="Setup", Key:="SrokV", Default:=defSrokV)
MinNal = GetSetting(AppName:="Pobegay", Section:="Setup", Key:="MinNal", Default:=defMinNal)
MaxNal = GetSetting(AppName:="Pobegay", Section:="Setup", Key:="MaxNal", Default:=defMaxNal)
pswd = GetSetting(AppName:="Pobegay", Section:="Setup", Key:="Password", Default:=0)
RegEx = (CLng(pswd) - CLng(Date)) < 0
Select Case pswd
Case 0
pswd = CLng(Date) + kdPr
SaveSetting "Pobegay", "Setup", "Password", pswd
Case CLng(DRJuli)
RegVer = True
Case Else
If RegEx Then
MsgBox " Уважаемый Александр Афанасьевич !" & vbCrLf _
& "Напоминаю Вам, что срок пробного использования программы закончился." & vbCrLf _
& "По вопросу его продления обращайтесь к Александру Зиновьевичу" & vbCrLf _
& "по телефонам: 266-90-89 дом. и (+7) 927-2060229 сот." _
, vbCritical, "Пациенты - 2005 - TRIAL version"
' Auto_Close
Exit Sub
End If
End Select
'Настройка меню "Пациенты"
MenuBars(xlWorksheet).Menus.Add Caption:=strTextMenu, Before:=14
MenuBars(xlWorksheet).Menus(strTextMenu).MenuItems.Add _
Caption:=strMenuAut, Before:=1, OnAction:="HelpMe(3)"
MenuBars(xlWorksheet).Menus(strTextMenu).MenuItems.Add _
Caption:=strMenuRas, Before:=1, OnAction:="Restart"
MenuBars(xlWorksheet).Menus(strTextMenu).MenuItems.Add _
Caption:=strMenuOtch, Before:=1, OnAction:="OtchetPrint"
MenuBars(xlWorksheet).Menus(strTextMenu).MenuItems.Add _
Caption:=strMenuOtchDen, Before:=1, OnAction:="OtchetPrintDen"
MenuBars(xlWorksheet).Menus(strTextMenu).MenuItems.Add _
Caption:=strMenuNew, Before:=1, OnAction:="NewPats"
MenuBars(xlWorksheet).Menus(strTextMenu).MenuItems.Add _
Caption:=strMenuNal, Before:=1, OnAction:="HelpMe(2)"
MenuBars(xlWorksheet).Menus(strTextMenu).MenuItems.Add _
Caption:=strMenuTun, Before:=1, OnAction:="HelpMe(1)"
MenuBars(xlWorksheet).Menus(strTextMenu).MenuItems.Add _
Caption:=strMenuHlp, Before:=1, OnAction:="HelpMe(0)"
'Настройка панели "NalPane"
On Error Resume Next
CommandBars.Add ("NalPane")
On Error GoTo 0
With CommandBars("NalPane")
If .Controls.Count = 0 Then
Set btn = CommandBars("NalPane").Controls.Add(msoControlButton)
' btn.TooltipText = "Полундра!"
btn.FaceId = idNal
btn.OnAction = "NalEnd"
End If
.Visible = True
End With
'Запуск программы
Call Progul
' ActiveSheet.Unprotect
' Cells.Select
' Selection.Locked = True
' Columns(nKol).Select
' Selection.Locked = False
' Selection.FormulaHidden = False
' ActiveSheet.Protect Contents:=True, Scenarios:= _
' False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
' AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
' :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
' AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True
n = nKol - DneySaveComment
If n > 1 Then Range(Cells(2, 2), Cells(kPats + 1, n)).ClearComments
Cells(1, nKol).Activate
ActiveWindow.ScrollColumn = nKol
ActiveCell.Interior.ColorIndex = 34
ScreenX = GetSystemMetrics(0)
ScreenY = GetSystemMetrics(1)
Load HelpForm
End Sub
Sub Auto_Close()
Dim MenuNm As Object, i As Integer, RetVal
' Выгрузка скрытых польз. форм
If UserForms.Count > 0 Then
For i = UserForms.Count - 1 To 0 Step -1
Unload UserForms(i)
Next
End If
If Worksheets("Посещения").Visible <> xlVeryHidden Then Worksheets("Посещения").Visible = xlVeryHidden
'Скрытие панели "CounterPane"
On Error Resume Next
CommandBars("NalPane").Visible = False
'Удаление меню "Пациенты"
For Each MenuNm In MenuBars(xlWorksheet).Menus
If MenuNm.Caption = strTextMenu Then MenuNm.Delete
Next
Application.StatusBar = False
If Not Rest Then
If Not ActiveWorkbook.Saved Then ActiveWorkbook.Save
If Dir("D:\Work\Temp", vbDirectory) = "Temp" Then
On Error Resume Next
RetVal = Shell("D:\Work\CopyJobPats.cmd", 1)
End If
End If
End Sub
Sub NewPats()
frmNewPats.Show
End Sub
Sub NalEnd()
SaveSetting "Pobegay", "Setup", "prNal", 1
RegEx = True
Auto_Close
End Sub
Sub Restore()
SaveSetting "Pobegay", "Setup", "prNal", 0
Restart
End Sub
Sub Restart()
Rest = True
Auto_Close
Auto_Open
End Sub
Sub HelpMe(Optional nP As Integer = 0)
HelpForm.MultiPagePob.Value = nP
HelpForm.Show
End Sub
Sub Pereschet()
Application.ScreenUpdating = False
Call Progul
HelpForm.lblRed.Caption = "Отсутствуют " & Srok & " дней - " & Str(kProg)
HelpForm.lblMagenta.Caption = "Отсутствуют " & SrokMagenta & " дней - " & Str(kVarnMagenta)
HelpForm.lblYellow.Caption = "Отсутствуют " & SrokV & " дней - " & Str(kVarn)
HelpForm.lblFree.Caption = "Свободных №№ - " & Str(kSvob)
If nKol > 0 And nKol <= 256 Then
HelpForm.lblTD = "Посещений сегодня - " & _
Str(WorksheetFunction.Sum(Range(Cells(2, nKol), Cells(kPats + 1, nKol))))
Sheets("Список").Activate
HelpForm.lblAll = "Пациентов всего - " & _
Str(WorksheetFunction.Subtotal(3, Sheets("Список").Range(Cells(2, 2), Cells(kPats + 1, 2))))
Sheets("Посещения").Activate
End If
Application.ScreenUpdating = True
End Sub
Sub Progul()
Dim nS As Integer, nK As Integer, nKs As Integer, nKsV As Integer, lenOpis As Integer, nKsMagenta As Integer
Dim today As Date, dZag As Date, kViz As Integer, kVizV As Integer, kVizMagenta As Integer
Application.ScreenUpdating = False
today = Date
nKol = nK
nKs = 0
nKsV = 0
nKsMagenta = 0
kVarn = 0
kVarnMagenta = 0
kProg = 0
kSvob = 0
Sheets("Список").Columns(2).Interior.ColorIndex = xlNone
'Sheets("Комментарии").Columns(2).Interior.ColorIndex = xlNone
Sheets("Посещения").Select
Range(Cells(1, 1), Cells(defPats + 1, 256)).Interior.ColorIndex = xlNone
For nK = 2 To 256
dZag = Cells(1, nK).Value
If nKs = 0 And dZag > today - Srok Then
nKs = nK - 1
End If
If nKsMagenta = 0 And dZag > today - SrokMagenta Then
nKsMagenta = nK - 1
End If
If nKsV = 0 And dZag > today - SrokV Then
nKsV = nK - 1
End If
If dZag >= today Then
nKol = nK
Exit For
End If
Next
' Новые рабочие листы
If nKol = 0 Then
SaveToArchive
SumViz
Worksheets("Посещения").Select
NewSheet
Worksheets("Книга").Select
NewSheet
Restart
Exit Sub
End If
For nS = 2 To kPats + 1
kViz = 0
kVizV = 0
kVizMagenta = 0
For nK = nKs To nKol
If Cells(nS, nK).Value > 0 Then kViz = kViz + 1
Next
For nK = nKsMagenta To nKol
If Cells(nS, nK).Value > 0 Then kVizMagenta = kVizMagenta + 1
Next
For nK = nKsV To nKol
If Cells(nS, nK).Value > 0 Then kVizV = kVizV + 1
Next
lenOpis = Len(Trim(Sheets("Список").Cells(nS, 2).Value))
If kViz = 0 And lenOpis > 0 Then
kProg = kProg + 1
Range(Cells(nS, nKs), Cells(nS, nKol)).Interior.ColorIndex = kIdx
Cells(nS, 1).Interior.ColorIndex = kIdx
Sheets("Список").Cells(nS, 2).Interior.ColorIndex = kIdx
' Sheets("Комментарии").Cells(nS, 2).Interior.ColorIndex = kIdx
ElseIf kVizMagenta = 0 And lenOpis > 0 Then
kVarnMagenta = kVarnMagenta + 1
Range(Cells(nS, nKsMagenta), Cells(nS, nKol)).Interior.ColorIndex = kIdxMagenta
Cells(nS, 1).Interior.ColorIndex = kIdxMagenta
Sheets("Список").Cells(nS, 2).Interior.ColorIndex = kIdxMagenta
' Sheets("Комментарии").Cells(nS, 2).Interior.ColorIndex = kIdxMagenta
ElseIf kVizV = 0 And lenOpis > 0 Then
kVarn = kVarn + 1
Range(Cells(nS, nKsV), Cells(nS, nKol)).Interior.ColorIndex = kIdxV
Cells(nS, 1).Interior.ColorIndex = kIdxV
Sheets("Список").Cells(nS, 2).Interior.ColorIndex = kIdxV
' Sheets("Комментарии").Cells(nS, 2).Interior.ColorIndex = kIdxV
ElseIf lenOpis = 0 And nS <= kPats + 1 Then
kSvob = kSvob + 1
Range(Cells(nS, 1), Cells(nS, nKol)).Interior.ColorIndex = kIdx1
' Cells(nS, 1).Interior.ColorIndex = kIdx1
Sheets("Список").Cells(nS, 2).Interior.ColorIndex = kIdx1
' Sheets("Комментарии").Cells(nS, 2).Interior.ColorIndex = kIdx1
End If
Next
Application.StatusBar = "Отсут. " & SrokV & " дн. (жёл.) - " & kVarn & _
", Отсут. " & SrokMagenta & " дн. (роз.) - " & kVarnMagenta & _
", Отсут. " & Srok & " дн. (крас.) - " & kProg & _
", Своб. - " & kSvob & _
", Сегодня - " & Str(WorksheetFunction.Subtotal(3, Range(Cells(2, nKol), Cells(kPats + 1, nKol))))
Application.ScreenUpdating = True
End Sub
Sub Nalog(nK As Integer)
Dim mas(160) As Integer
Dim i As Integer, kp As Integer, n As Integer, nal As Integer
Application.ScreenUpdating = False
Randomize
kp = Int(Rnd * (MaxNal - MinNal + 1) + MinNal)
n = 0
nal = 0
'nk = nKol 'ActiveCell.Column
For i = 2 To kPats + 1
If Cells(i, nK) = 1 Then
nal = nal + 1
mas(nal) = i - 1
End If
Next
If nal > 0 Then
If nal < kp Then kp = nal
Worksheets("Книга").Activate
ActiveWindow.ScrollColumn = nKol
Range(Cells(2, nK), Cells(kPats + 1, nK)).Select
Selection.ClearContents
Cells(1, nK).Select
ActiveCell.Interior.ColorIndex = 34
Do While n < kp
i = Int(Rnd * nal + 1)
If mas(i) > 0 Then
Cells(mas(i) + 1, nK).Value = 1
mas(i) = 0
n = n + 1
End If
Loop
Worksheets("Посещения").Activate
End If
Application.ScreenUpdating = True
End Sub
Sub NewSheet()
Dim nC As Integer, nR As Integer, D As Date
Range(Columns(2), Columns(227)).Select
Selection.Delete Shift:=xlToLeft
D = Date
nC = 31
Do
If Weekday(D, vbMonday) <> 7 Then
Cells(1, nC) = D
nC = nC + 1
End If
D = D + 1
Loop Until nC = 257
Columns(2).Select
Selection.Copy
Range(Columns(31), Columns(256)).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("AB337").Select
Selection.AutoFill Destination:=Range("AB337:IV337"), Type:=xlFillDefault
End Sub
Sub OtchetPrint()
OtchForm.Show
End Sub
Sub OtchetPrintDen()
frmOtchPos.Show
End Sub
Sub testColor()
Dim i As Integer
For i = 1 To 50
Cells(340, i).Interior.ColorIndex = i
Next
End Sub
Sub testID()
Dim btn As Object, i As Integer
'Настройка панели "NalPane"
On Error Resume Next
CommandBars.Add ("NalPane")
For i = 57 To 57
On Error GoTo 0
With CommandBars("NalPane")
' If .Controls.Count = 0 Then
Set btn = CommandBars("NalPane").Controls.Add(msoControlButton)
' btn.TooltipText = "Полундра!"
btn.FaceId = i
' btn.OnAction = "NalEnd"
' End If
.Visible = True
End With
Next
End Sub
Sub SumViz()
Dim kViz As Integer, nS As Integer, nn As Integer, fd As Date, strPats As String
'kPats = 260 ' debug
Worksheets("Посещения").Select
For nS = 2 To kPats + 1
strPats = dhTrimAll(Worksheets("Список").Cells(nS, 2).Value)
If Len(strPats) > 0 Then
fd = FirstDate(strPats)
kViz = 0
For nn = 226 To 2 Step -1
If Cells(1, nn) < fd Then Exit For
If Cells(nS, nn) = 1 Then kViz = kViz + 1
Next
Worksheets("Список").Cells(nS, 2).Value = strPats & " Посещений - " & kViz & "."
End If
Next
End Sub
[/more]
