Автоматизация учета основных средств на предприятии

s_folder = CurrentProject. Path

If Right$ (s_folder,

1) <> "\" Then s_folder = s_folder + "\"

s_folder = s_folder + "blanks\"

If Len (Dir$ (s_folder, vbDirectory)) = 0 Then

MsgBox "Путь к папке с бланками " & s_folder & " не обнаружен!", vbCritical + vbOKOnly

Exit Sub

End If

Set db = CurrentDb

Se

t Rec = db. OpenRecordset ("select * from Формы where НомерФорма = " & NomerForm, dbOpenSnapshot)

If Rec. RecordCount > 0 Then

StrFormName = Rec. Fields ("Наименование"). Value

StrFile = Rec. Fields ("Файл"). Value

Else

Set Rec = Nothing

MsgBox "Нет информации о форме №" & NomerForm & "!", vbCritical + vbOKOnly

Exit Sub

End If

Set Rec = Nothing

StrPath = s_folder + StrFile

If Len (Dir$ (StrPath)) = 0 Then

MsgBox "Файл бланка формы '" & StrFormName & "' " & StrPath & " не обнаружен!", vbCritical + vbOKOnly

Exit Sub

End If

Set Rec = db. OpenRecordset ("SELECT Параметры. *, Сотрудники. Сотрудник, Сотрудники. ТабельныйНомер, Должности. Должность FROM ( (Должности RIGHT JOIN Сотрудники ON Должности. НомерДолжн = Сотрудники. НомерДолжн) RIGHT JOIN Параметры ON Сотрудники. НомерСотр = Параметры. ИнвОтвеств)", dbOpenSnapshot)

If Rec. RecordCount > 0 Then

StrFirmName = Nz (Rec. Fields ("НаименованиеФирмы"). Value, "")

StrFirmOKPO = Nz (Rec. Fields ("ОКПО"). Value, "")

StrInvOtvName = Nz (Rec. Fields ("Сотрудник"). Value, "")

StrInvOtvDolzhn = Nz (Rec. Fields ("Должность"). Value, "")

StrInvOtvNomer = Nz (Rec. Fields ("ТабельныйНомер"). Value, "")

Else

MsgBox "Общие параметры фирмы не занесены!", vbCritical + vbOKOnly

Exit Sub

End If

Set Rec = Nothing

Set Rec = db. OpenRecordset ("select * from ВспомДата where НомерМес = " & Month (v_dat1), dbOpenSnapshot)

If Rec. RecordCount > 0 Then

StrMonth1 = Nz (Rec. Fields ("НазвМес"). Value, "")

Else

StrMonth1 = "нет названия"

End If

Set Rec = Nothing

Set Rec = db. OpenRecordset ("select * from ВспомДата where НомерМес = " & Month (v_dat2), dbOpenSnapshot)

If Rec. RecordCount > 0 Then

StrMonth2 = Nz (Rec. Fields ("НазвМес"). Value, "")

Else

StrMonth2 = "нет названия"

End If

Set Rec = Nothing

Set oApp = CreateObject ("Excel. Application")

oApp. Workbooks. Open FileName: =StrPath, ReadOnly: =True

oApp. ActiveWorkbook. Sheets (1). Select

oApp. Cells (rFirmName, cFirmName). Value = StrFirmName

oApp. Cells (rFirmOKPO, cFirmOKPO). Value = StrFirmOKPO

oApp. Cells (rStruct, cStruct). Value = StrStruct

oApp. Cells (rDat1Day, cDat1Day). Value = Format$ (v_dat1, "dd")

oApp. Cells (rDat1Mon, cDat1Mon). Value = StrMonth1

oApp. Cells (rDat1Year, cDat1Year). Value = Right$ (Format$ (v_dat1, "yyyy"),

1)

oApp. Cells (rDat2Day, cDat2Day). Value = Format$ (v_dat2, "dd")

oApp. Cells (rDat2Mon, cDat2Mon). Value = StrMonth2

oApp. Cells (rDat2Year, cDat2Year). Value = Right$ (Format$ (v_dat2, "yyyy"),

1)

oApp. Cells (rInvName, cInvName). Value = StrInvOtvName

oApp. Cells (rInvDolzhn, cInvDolzhn). Value = StrInvOtvDolzhn

oApp. Cells (rInvNomer, cInvNomer). Value = StrInvOtvNomer

Application. SysCmd acSysCmdInitMeter, "Вывод информации о товарах", 100

If nomer_struct = 0 Then

Set qry = db. QueryDefs ("запрос_ИнвКнига2")

qry. Parameters (0) = v_dat1

qry. Parameters (1) = v_dat2

Else

Set qry = db. QueryDefs ("запрос_ИнвКнига")

qry. Parameters (0) = v_dat1

qry. Parameters (1) = nomer_struct

qry. Parameters (2) = v_dat2

End If

Set RecList = qry. OpenRecordset (dbOpenSnapshot)

NRecord = RecList. RecordCount

If NRecord > 0 Then

RecList. MoveLast

NRecord = RecList. RecordCount

RecList. MoveFirst

i = 0

p = rSh1_1 - 1

While Not RecList. EOF

i = i + 1

p = p + 1

If p > rSh1_2 Then GoTo ex

Application. SysCmd acSysCmdUpdateMeter, i / NRecord * 100

With oApp. ActiveWorkbook. Sheets (2)

. Cells (p, cNomer). Value = i

. Cells (p, cTovar). Value = Nz (RecList. Fields ("Наименование"). Value, "")

. Cells (p, cInv). Value = Nz (RecList. Fields ("ИнвНомер"). Value, "")

. Cells (p, cOsn). Value = Nz (RecList. Fields ("ОснованиеПринятия"). Value, "")

. Cells (p, cDatePrin). Value = Format$ (Nz (RecList. Fields ("ДатаПринятияКУчету"). Value, Date), "dd. mm. yyyy")

. Cells (p, cStructTov). Value = Nz (RecList. Fields ("СтруктурноеПодразделение"). Value, "")

. Cells (p, cOtv). Value = Nz (RecList. Fields ("Сотрудник"). Value, "")

. Cells (p, cPervStoim). Value = Nz (RecList. Fields ("ПервСтоииость"). Value, 0)

. Cells (p, cSrok). Value = Nz (RecList. Fields ("СрокИспользования"). Value, 0) & "мес."

. Cells (p, cAmort). Value = Nz (RecList. Fields ("Аморт"). Value, 0)

End With

oApp. ActiveWorkbook. Sheets (3). Cells (p, cOstStoim). Value = _

Nz (RecList. Fields ("ОстСтоииость"). Value, 0)

RecList. MoveNext

Wend

End If

ex:

Application. SysCmd acSysCmdRemoveMeter

If Not (oApp Is Nothing) Then oApp. Visible = True

Set qry = Nothing

Set RecList = Nothing

Set oApp = Nothing

Set db = Nothing

Exit Sub

LblErr:

MsgBox Err. Description, vbCritical + vbOKOnly

GoTo ex

End Sub

Код модуля общий

Option Compare Database

Option Explicit

Function translateNumber (ByVal Num As Long) As String

On Error GoTo LblErr

Dim num_str As String

Dim razr_count As Long

Dim razr_all As Long

Dim tri_count As Long

Dim tri_all As Long

Dim cur_dig As Byte

Dim point_pos As Long

Dim mg As Boolean

Dim mgl As Boolean

Dim kstr1 As Long

translateNumber = ""

num_str = Trim (Str (Num))

tri_count = 1

razr_all = Len (num_str)

If razr_all = 0 Then

translateNumber = "ноль"

Exit Function

End If

If Num = 0 Then

translateNumber = "ноль"

Exit Function

End If

For razr_count = 1 To razr_all Step 3

kstr1 = Mid (num_str, razr_all - razr_count + 1,1)

If razr_count = 1 Then mgl = True

If razr_count = 4 Then

mgl = True

If razr_count >= razr_all Then GoTo m1

If Mid (num_str, razr_all - razr_count,

1) = "1" Then

translateNumber = " тысяч" & translateNumber

 Скачать реферат