Lotsia PLM: Форум по семейству систем PLM/PDM/TDM/ERP/Workflow

Код: Выделить всё

Dim Doc
Set Doc=Application.ActiveDocument
....
тут чтение данных отчета и формирование внешних документов
....
if Not Doc Is Nothing Then
             Doc.Close
             Set Doc= Nothing
End if

Код: Выделить всё

Option explicit       'требование объявления переменных
Sub rep_Vizitka
     Dim ExcApp,doc,shBadge,Count,mRow,mRowD,mValue,templName,bool,j
     'проверим запущен ли в системе Excel если да то подключимся к нему если нет откроем новый
     '(проверку на то что в системе вообще установлен Excel здесь делать не будем)
     On Error Resume Next                         'если дальше будет ошибка - учесть ее и продолжить работу
     set ExcApp = Getobject(, "Excel.Application")'попробовать подключиться к запущенному Excel   
     if Err.Number <> 0 then                      'Если оказалось что Excel еще не открыт - запустить его
         set ExcApp=CreateObject("Excel.Application")
     end if

     templName= LsRpt.GetItem(1,"Path") 
     set Doc=ExcApp.WorkBooks.Add( templName )    'создать новый файл на основе шаблона      
     set shBadge=Doc.WorkSheets("Бейдж")              'подключиться к листу

'     ExcApp.Visible=True                                               'сделать Excel видимым
     mRow=LsRpt.RowCount()                                       'прочитать количество строк в отчете Лоции
     shBadge.Activate                                                    'сделаем лист активным
                                                                                     'подсчитаем количество строк из расчета 2 на одной строке
       bool=mRow And 1                                                 'проверим четное нечетное
        If bool Then
              mRowD=(mRow+1-1)/2
                   Else
              mRowD=(mRow-1)/2
        End If

 'вставим пустые строки под таблицу и отформатируем их
         with shBadge
            .select
            .Cells(5,1).Resize(mRowD*4).EntireRow.Insert     
            .Rows("1:4").copy

             j=1
             for Count=1 to mRowD*2 step 2

                 .Cells(j,2).Value= LsRpt.GetItem(Count,"col2")          'ФИО
                 .Cells(j+1,2).Value= LsRpt.GetItem(Count,"col5")      'Должность
                 .Cells(j+2,2).Value= LsRpt.GetItem(Count,"col6")      'Компания
                 .Cells(j+3,1).Value= LsRpt.GetItem(Count,"number")

                  if Count<mRow then 
                            .Cells(j,4).Value= LsRpt.GetItem(Count+1,"col2")      'ФИО
                            .Cells(j+1,4).Value= LsRpt.GetItem(Count+1,"col5")  'Должность
                            .Cells(j+2,4).Value= LsRpt.GetItem(Count+1,"col6")  'Компания
                            .Cells(j+3,3).Value=  LsRpt.GetItem(Count+1,"number") 
                                             else
                            .Cells(j,4).Value=""
                            .Cells(j+1,4).Value=""
                            .Cells(j+2,4).Value=""
                            .Cells(j+3,3).Value= ""
                 end if
                 j=j+4 

                if mRow>2 and count<mRow-1 then  
                      .Range(.Cells(j,1),.Cells(j,1)).select
                      .paste
                      .ClearContents
                end if                
            next  
           ExcApp.CutCopyMode = False
           .Range(.Cells(4,1),.Cells(4,1)).select
         end with     

       ExcApp.Visible=True                      'сделать Excel видимым

    'отключимся от Excel (очистим память) (убъем обекты)
     if Not shOrder Is Nothing Then Set shBadje = Nothing
     if Not Doc Is Nothing Then Set Doc = Nothing
     if Not ExcApp Is Nothing Then Set ExcApp = Nothing

End Sub 

Код: Выделить всё

'------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
'подготовить Бейджи
Sub Print_Beidg()
'------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
     Dim ExcApp,doc,shBadge,Count, mRowD, Path 
     Dim sql,id_aObject, Arr, i , j, Check

'прочтем данные из Лоции
     id_aObject=LsVars.GetVarValue("id_aObject")
     Check=LsVars.GetVarValue("Check")
     Path= "...\Семинары\Бейдж.xls" 

'прочтем данные из БД
    If DataBase.ADODB_Connected Then                                                                                       ' если подключиться удалось работаем иначе нет
      If DataBase.ADODB_RecordSet Then                                                                                      ' если удалось создать recordset тоже работаем
        select case check
          case 1 'докладчики и участники
            sql = "SELECT rw.description, vv1.value, vv2.value FROM lsdbo.object_reference rw left join lsdbo.object_type tw on rw.type_id=tw.id left join lsdbo.attrib_value av1 on rw.id=av1.object_id and av1.attrib_id=3000000000086 left join lsdbo.value_string vv1 on av1.value_id=vv1.id and av1.attrib_id=3000000000086 left join lsdbo.attrib_value av2 on rw.id=av2.object_id and av2.attrib_id=100004068400000 left join lsdbo.value_string vv2 on av2.value_id=vv2.id and av2.attrib_id=100004068400000 where rw.id in (select id from LSDBO.Ric_Get_objChild("+cStr(id_aObject)+",'Стки,Стк') union all select id from LSDBO.Ric_Get_objChild("+cStr(id_aObject)+",'Lsts,Lst')) order by vv2.value"
          case 2 'только докладчики
            sql = "SELECT rw.description, vv1.value, vv2.value FROM lsdbo.object_reference rw left join lsdbo.object_type tw on rw.type_id=tw.id left join lsdbo.attrib_value av1 on rw.id=av1.object_id and av1.attrib_id=3000000000086 left join lsdbo.value_string vv1 on av1.value_id=vv1.id and av1.attrib_id=3000000000086 left join lsdbo.attrib_value av2 on rw.id=av2.object_id and av2.attrib_id=100004068400000 left join lsdbo.value_string vv2 on av2.value_id=vv2.id and av2.attrib_id=100004068400000 where rw.id in (select id from LSDBO.Ric_Get_objChild("+cStr(id_aObject)+",'Стки,Стк')) order by vv2.value"
          case 0 'только участники
            sql = "SELECT rw.description, vv1.value, vv2.value FROM lsdbo.object_reference rw left join lsdbo.object_type tw on rw.type_id=tw.id left join lsdbo.attrib_value av1 on rw.id=av1.object_id and av1.attrib_id=3000000000086 left join lsdbo.value_string vv1 on av1.value_id=vv1.id and av1.attrib_id=3000000000086 left join lsdbo.attrib_value av2 on rw.id=av2.object_id and av2.attrib_id=100004068400000 left join lsdbo.value_string vv2 on av2.value_id=vv2.id and av2.attrib_id=100004068400000 where rw.id in (select id from LSDBO.Ric_Get_objChild("+cStr(id_aObject)+",'Lsts,Lst')) order by vv2.value"
        end select  
        rs.Open sql, cn
        Arr = rs.GetRows '(Rows, Start, Fields)
        rs.Close
        Set rs = Nothing       'убить объект recordset
        Set cn = Nothing       'убить объект соединения с базой
      End if
    End If

'сформируем Excel
     set ExcApp=CreateObject("Excel.Application")
     set Doc=ExcApp.WorkBooks.Add(Path )                                                           'создать новый файл на основе шаблона      
     set shBadge=Doc.WorkSheets("Бейдж")                                                           'подключиться к листу
     shBadge.Activate                                                                                                'сделаем лист активным

'     ExcApp.Visible=True                                                                                           'сделать Excel видимым
    
    mRowD = UBound(Arr, 2) + 1                                                                               'подсчитаем количество строк из расчета 2 на одной строке
    If mRowD And 1Then                                                                                            'проверим четное нечетное
      mRowD = (mRowD + 1) / 2
    Else
      mRowD = (mRowD) / 2
    End If

 'вставим пустые строки под таблицу и отформатируем их
    with shBadge
      .Select
      If mRowD > 1 Then
        .Cells(5, 1).Resize((mRowD - 1) * 4).EntireRow.Insert
        .Rows("1:4").Copy
'        .Range(.Cells(5, 1), .Cells(5 + (mRowD * 4) - 1, 4)).Select
        j = 5
        For i = 1 To mRowD - 1
          .Rows(j).Select
          .Paste
          j = j + 4
        Next
        .Range("A4").Select
      End If
      ExcApp.CutCopyMode = False

      j = 0
      For Count = 0 To (mRowD * 2) - 1 Step 2
        .Cells(j + 1, 1).Value = Count + 1
        For i = 0 To 2 'LBound(Arr, 2) To UBound(Arr, 2) - 1
          .Cells(j + i + 1, 2).Value = Arr(i, Count)
        Next
        If Count < UBound(Arr, 2) Then 'mRowD * 2 Then
          .Cells(j + 1, 3).Value = Count + 2
          For i = 0 To 2 ' LBound(Arr, 2) To UBound(Arr, 2) - 1
            .Cells(j + i + 1, 4).Value = Arr(i, Count + 1)
          Next
        End If
        j = j + 4
      Next
    End With
    Erase Arr

    ExcApp.Visible=True                      'сделать Excel видимым

   'отключимся от Excel (очистим память) (убъем обекты)
    If Not shBadge Is Nothing Then Set shBadge = Nothing
    If Not doc Is Nothing Then Set doc = Nothing
    If Not ExcApp Is Nothing Then Set ExcApp = Nothing
End Sub 

Код: Выделить всё

Option Explicit          'требование объявления переменных
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

' по работе с БД   http://www.script-coding.info/ADO.html
' по работе с ADO http://msdn.microsoft.com/en-us/library/ms676795%28v=VS.85%29.aspx
' по работе с VBA http://www.askit.ru/custom/vba_office/vba_office_plan.htm
'                           http://msdn.microsoft.com/ru-ru/library/2x7h1hfk%28v=VS.90%29.aspx

' функция создания и открытия подключения к базе данных
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Function ADODB_Connected
  If IsObject(cn) And TypeName(cn) = "Connection" Then
      ADODB_Connected=True
'      msgbox "Соединение уже существует"
      Exit Function
  Else
      On Error Resume Next
      set cn = CreateObject("ADODB.Connection")
'подключение под админом
'           cn.Open "Provider=SQLOLEDB;Data Source=имя сервера;Initial Catalog=наименование БД;User ID=логин админа;Password=пароль админа;"
'подключение через юзера db_reader
            cn.Open "Provider=SQLOLEDB;Data Source=имя сервера;Initial Catalog=наименование БД;User ID=логин 'быстрого' юзера;Password=пароль 'быстрого' юзера;"

'      If cn.Errors.Count = 0 And Err.Number = 0 Then (cn.Errors сработать еще не успевает поэтому уходим по Err)
      If Err.Number = 0 Then
          ADODB_Connected = True
'          msgbox "Новое соединение"
          Exit Function
        Else
        '  ShowError ("Подключение к БД")
          ShowCnError ("Подключение к БД")
          ADODB_Connected = False
          If Not cn Is Nothing Then Set cn = Nothing
        End If
  End If
End Function

' функция создания recordset
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Function ADODB_RecordSet()
  If IsObject(rs) And TypeName(rs) = "Recordset" Then
      ADODB_RecordSet = True
'      msgbox "RecordSet уже существует"
      Exit Function
  Else
       On Error Resume Next
       Set rs = CreateObject("ADODB.Recordset")
       If Err.Number = 0 Then
          ADODB_RecordSet = True
'         msgbox "Новый RecordSet"
          Exit Function
       Else
          ShowError ("Создание объекта Recordset")
          ADODB_RecordSet = False
          If Not rs Is Nothing Then Set rs = Nothing
          If Not cn Is Nothing Then Set cn = Nothing
       End If
  End If
End Function

' функция создания command и подключения к cn
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Function ADODB_Command()
  If IsObject(cmd) And TypeName(cmd) = "Command" Then
      ADODB_Command = True
'      msgbox "Command уже существует"
      Exit Function
  Else
       On Error Resume Next
       Set cmd = CreateObject("ADODB.Command")
             cmd.ActiveConnection = cn
       If Err.Number = 0 Then
          ADODB_Command = True
'         msgbox "Новый Command"
          Exit Function
       Else
          ShowError ("Создание объекта Command")
          ADODB_Command = False
          If Not cmd Is Nothing Then Set cmd = Nothing
          If Not cn Is Nothing Then Set cn = Nothing
       End If
  End If
End Function

' процедура просмотра информации о ошибках при создании объекта Connect
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub ShowCnError(Msg)
  Dim errLoop
  Dim strError
          
    strError = ""
      For Each errLoop In cn.Errors
        strError = strError & _
                       "Error #" & errLoop.Number & vbCr & _
                       "   " & errLoop.Description & vbCr & _
                       "   (Source: " & errLoop.Source & ")" & vbCr & _
                       "   (SQL State: " & errLoop.SqlState & ")" & vbCr & _
                       "   (NativeError: " & errLoop.NativeError & ")" & vbCr
        If errLoop.HelpFile = "" Then
          strError = strError & _
                       "   No Help file available" & vbCr & vbCr
        Else
          strError = strError & _
                       "   (HelpFile: " & errLoop.HelpFile & ")" & vbCr & _
                       "   (HelpContext: " & errLoop.HelpContext & ")" & vbCr & vbCr
        End If
      Next
      
     strError = strError & vbCr & vbCr & _
                        "Обратитесь к администратору системы"
                   
      MsgBox strError, vbOKOnly + vbExclamation + vbSystemModal, Msg
' cn.Errors.Clear
End Sub

' процедура просмотра информации о ошибках (объект Err)
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub ShowError(Msg)
  Dim strError
        strError = "Error #" & Err.Number & vbCr & _
                       "   " & Err.Description & vbCr & _
                       "   (Source: " & Err.Source & ")" & vbCr
        If Err.HelpFile = "" Then
          strError = strError & _
                       "   No Help file available" & vbCr & vbCr
       Else
          strError = strError & _
                       "   (HelpFile: " & Err.HelpFile & ")" & vbCr & _
                       "   (HelpContext: " & Err.HelpContext & ")" & vbCr & vbCr
        End If
    
        Err.Clear
        strError = strError & vbCr & vbCr & _
                       "Обратитесь к администратору системы"

         MsgBox strError, vbOKOnly + vbExclamation + vbSystemModal, Msg

               '        "   (Erl: " & Err.Erl & ")" & vbCr & _
               '        "   (LastDllError: " & Err.LastDllError & ")" & vbCr & vbCr &
End Sub

' процедура просмотра информации о параметрах хранимой процедуры для cmd
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub ShowCmdParameters(desc)
Dim tmp, Param
  
  tmp = desc & vbCr & vbCr
  For Each Param In cmd.Parameters
    tmp = tmp & "Name = " & Param.Name & _
                        " Attributes = " & Param.Attributes & _
                        " Direction = " & Param.Direction & _
                        " Size = " & Param.Size & _
                        " Type = " & Param.Type & _
                        " Value = " & Param.Value & vbCr
  Next
  MsgBox tmp, vbOKOnly + vbInformation + vbSystemModal, "Параметры хранимой процедуры"

End Sub

' процедура очистки/удаления всех параметров cmd
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub ClearCmdParameters()
  Dim lngX
    cmd.CommandType = DataBaseConstant.adCmdUnknown            'тип объекта - по умолчанию
    cmd.CommandText = ""                                  'имя
    For lngX = (cmd.Parameters.Count - 1) To 0 Step -1
        cmd.Parameters.Delete lngX
    Next
End Sub

' функция открытия recordset
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Function OpenRecordSet(sql)
'  On Error Resume Next
   rs.Open sql, cn
'  If Err.Number = 0 Then
   If Not rs Is Nothing Then
      If Not (rs.EOF Or rs.BOF) Then
         OpenRecordSet = True         'есть данные
         Exit Function
       Else
         OpenRecordSet = False        'пустой
         Exit Function
      End If
   Else
         OpenRecordSet = False        'recordset не существует
         Exit Function
  End If
'Else
'          MsgBox "Error: " & Err.Number
'         OpenRecordSet = False        'ошибка открытия
'End If
End Function


' функция выполнения одного запроса через объект cn (Connect)
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Function GetSingleData(Sql)
 Dim Rs, val

   Set Rs = cn.Execute(sql)
   If Rs.BOF And Rs.EOF Then
     val = vbNullString
   Else
     val = Rs.Fields(0).Value
   End If

   Set Rs = Nothing
   GetSingleData = val
End Function

Код: Выделить всё

Option Explicit          'требование объявления переменных
'---------------------------------------------------------------------------------------------------------------------------
'    Глобальные переменные
'---------------------------------------------------------------------------------------------------------------------------
Public cn                            'соединение
Public rs                             'recordset