SaveText.Ru

Без имени
  1. Const PROJECT_NAME = "NoSubtotals"
  2.  
  3. Public Sub KillSubtotals()
  4. Dim pt As PivotTable
  5. Dim pf As PivotField
  6. On Error Resume Next
  7. For Each pt In ActiveSheet.PivotTables
  8.     For Each pf In pt.PivotFields
  9.       pf.Subtotals(1) = False
  10.     Next pf
  11.     With pt
  12.         .InGridDropZones = True
  13.         .RowAxisLayout xlTabularRow
  14.         .HasAutoFormat = False
  15.     End With
  16. Next pt
  17. End Sub
  18.  
  19. Public Sub ListForSqlQuery()
  20. ' äëÿ òîãî, ÷òîáû ðàáîòàòü ñ áóôåðîì
  21. ' â ðåäàêòîð êîäà ... ìåíþ - tools->references ... â äèàëîãå êëèê ïî êíîïêå browse ...
  22. ' íàõîäèì fm20.dll â ïàïêå system32 ... îòêðûòü ... â ñïèñêå äîëæíî äîáàâèòüñÿ ...
  23. ' ìàêðîñîôò ôîðìñ 2.0 ëèáðàðè îáúåêò ... ñòàâèì ãàëî÷êó (õîòÿ îíà äîëæíà ïîñòàâèòüñÿ ñàìà) ... îê
  24. If Workbooks.Count > 0 Then
  25.     Dim ab As Workbook, WS As Worksheet
  26.     Dim n As Long, r0 As Long, c0 As Long, i As Long
  27.     Dim S As String ' ðàçäåëèòåëü
  28.     Dim O As String ' îáîñîáëÿòåëü
  29.     Dim T As String ' èòîã
  30.     Dim V As String ' ñêëåèâàåìîå íåèçâåñòíîå
  31.     Dim Clp As New DataObject
  32.        
  33.     Set ab = ActiveWorkbook
  34.     Set WS = ActiveSheet
  35.    
  36.     S = ","
  37.     O = "'"
  38.     Dim fst_r, fst_c, last As Long
  39.     last = 0
  40.     For Each cell In Selection
  41.         last = last + 1
  42.         If last = 1 Then
  43.             fst_r = cell.Row
  44.             fst_c = cell.Column
  45.         End If
  46.        
  47.     Next cell
  48.    
  49.     r0 = fst_r ' ïåðâàÿ ñòðîêà ñ äàííûìè
  50.     c0 = fst_c ' êîëîíêà ñ äàííûìè
  51.     last = last + r0 - 1 ' ïîñëåäíÿÿ êîëîíêà
  52.  
  53.     ' ñêëåèâàåì
  54.     T = ""
  55.     For i = r0 To last
  56.         V = WS.Cells(i, c0).Value
  57.         T = T & O & V & O & IIf(i = last, "", S)
  58.     Next i
  59.    
  60.     Clp.SetText (T)
  61.     Clp.PutInClipboard
  62. End If
  63. End Sub
  64.  
  65. 'îòïðàâèòü ñîîáùåíèå â Outlook
  66. Sub CreateOutlookMail()
  67.  
  68. Dim olApp As Object 'Outlook.Application
  69. Dim olMailMessage As Object 'Outlook.MailItem
  70. Set olApp = CreateObject("Outlook.Application")
  71. usern = Environ("USERNAME")
  72. Dim pat As String
  73.  
  74. pat = "E:temp_outlook"
  75. If Dir(pat, vbDirectory) = "" Then MkDir (pat)
  76. ChDir pat
  77.  
  78.     Dim sFileName As String
  79.     sFileName = pat & "" & Application.ActiveWorkbook.Name    'èìÿ ôàéëà äëÿ óäàëåíèÿ
  80.     If Dir(sFileName, 16) <> "" Then Kill sFileName    'óäàëÿåì ôàéë
  81. a = 0
  82.  
  83. 'BaseName = CreateObject("Scripting.FileSystemObject").GetBaseName(ActiveWorkbook)
  84. b = Application.ActiveWorkbook.Name
  85. a = InStr(b, ".xls")
  86. If a = 0 Then
  87. ActiveWorkbook.SaveCopyAs Filename:= _
  88.     pat & "" & Application.ActiveWorkbook.Name & ".xlsx"
  89.     file_name = pat & "" & Application.ActiveWorkbook.Name & ".xlsx"
  90. Else:
  91. ActiveWorkbook.SaveCopyAs Filename:= _
  92.     pat & "" & Application.ActiveWorkbook.Name
  93.     file_name = pat & "" & Application.ActiveWorkbook.Name
  94. End If
  95. ' ñîáèðàåì ñîîáùåíèå
  96.  
  97. 'olApp.inspectors
  98.  
  99. Set olMailMessage = olApp.CreateItem(olMailItem)
  100. With olMailMessage
  101.     .Subject = Application.ActiveWorkbook.Name
  102.     .Body = "Äîáðûé äåíü." _
  103.     & Chr(13) & _
  104.     "Âî âëîæåíèè."
  105.     .Attachments.Add file_name, olByReference
  106.     .Display
  107. End With
  108. Set olMailMessage = Nothing
  109. Set olApp = Nothing
  110.  
  111. 'óäàëÿåì ôàéë
  112. Kill file_name
  113.  
  114. End Sub
  115.  
  116. 'ñîçäàåì ñîîáùåíèå â Outlook
  117. Sub CreateOutlook()
  118.  
  119. Dim olApp As Object 'Outlook.Application
  120. Dim olMailMessage As Object 'Outlook.MailItem
  121. Set olApp = CreateObject("Outlook.Application")
  122. usern = Environ("USERNAME")
  123. Dim pat As String
  124.  
  125.  
  126. Set olMailMessage = olApp.CreateItem(olMailItem)
  127. With olMailMessage
  128.     .Subject = "" 'Application.ActiveWorkbook.Name
  129.     .Body = "Äîáðûé äåíü." _
  130.     & Chr(13) & Chr(13)
  131.     .Display
  132. End With
  133.  
  134. Set olMailMessage = Nothing
  135. Set olApp = Nothing
  136.  
  137. End Sub
  138.  
  139.  
  140.  
  141. Sub InsertInOutlook()
  142.  
  143. Dim olApp As Object 'Outlook.Application
  144. Dim olMailMessage As Object 'Outlook.MailItem
  145. Set olApp = CreateObject("Outlook.Application")
  146. usern = Environ("USERNAME")
  147. Dim pat As String
  148. On Error Resume Next: Err.Clear
  149. pat = "E:temp_outlook"
  150. If Dir(pat, vbDirectory) = "" Then MkDir (pat)
  151. ChDir pat
  152.  
  153.     Dim sFileName As String
  154.     sFileName = pat & "" & Application.ActiveWorkbook.Name    'èìÿ ôàéëà äëÿ óäàëåíèÿ
  155.     If Dir(sFileName, 16) <> "" Then Kill sFileName    'óäàëÿåì ôàéë
  156. a = 0
  157.  
  158. 'BaseName = CreateObject("Scripting.FileSystemObject").GetBaseName(ActiveWorkbook)
  159. b = Application.ActiveWorkbook.Name
  160. a = InStr(b, ".xls")
  161. If a = 0 Then
  162. ActiveWorkbook.SaveCopyAs Filename:= _
  163.     pat & "" & Application.ActiveWorkbook.Name & ".xlsx"
  164.     file_name = pat & "" & Application.ActiveWorkbook.Name & ".xlsx"
  165. Else:
  166. ActiveWorkbook.SaveCopyAs Filename:= _
  167.     pat & "" & Application.ActiveWorkbook.Name
  168.     file_name = pat & "" & Application.ActiveWorkbook.Name
  169. End If
  170. ' ñîáèðàåì ñîîáùåíèå
  171.  
  172. 'olApp.inspectors
  173.  
  174. Set olMailMessage = olApp.ActiveInspector
  175. With olMailMessage.currentitem
  176.     .Attachments.Add file_name, olByReference
  177.     .Display
  178. End With
  179. Set olMailMessage = Nothing
  180. Set olApp = Nothing
  181.  
  182. 'óäàëÿåì ôàéë
  183. Kill file_name
  184.  
  185.  
  186. End Sub
  187.  
  188.  
  189. Sub ScreenShot()
  190.    
  191.     'Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
  192.     Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
  193. End Sub
  194.  
  195.  
  196. Public Sub copy_insert_sql()
  197.  
  198. ' äëÿ òîãî, ÷òîáû ðàáîòàòü ñ áóôåðîì
  199. ' â ðåäàêòîð êîäà ... ìåíþ - tools->references ... â äèàëîãå êëèê ïî êíîïêå browse ...
  200. ' íàõîäèì fm20.dll â ïàïêå system32 ... îòêðûòü ... â ñïèñêå äîëæíî äîáàâèòüñÿ ...
  201. ' ìàêðîñîôò ôîðìñ 2.0 ëèáðàðè îáúåêò ... ñòàâèì ãàëî÷êó (õîòÿ îíà äîëæíà ïîñòàâèòüñÿ ñàìà) ... îê
  202. Dim Clp As New DataObject
  203. Dim sql As String
  204. Dim c As Range
  205. Dim sql_start As Variant
  206. Dim clm As Integer
  207. Dim poz_c As Integer
  208. Dim check As Variant
  209. Dim rw As Integer
  210. Dim cel As Integer
  211. Set Clp = New DataObject  'Äëÿ ðàáîòû ñ áóôåðîì
  212. poz_c = 0       'ñ÷åò÷èê äëÿ îïðåäåëåíèÿ íîâîé ñòðîêè
  213. check = 0       'ñ÷åò÷èê äëÿ îïðåäåëåíèå íîâîé íå ïåðâîé ñòðîêè
  214.  
  215. rw = Selection.Rows.Count       'Êîë-âî âûáðàííûõ ñòðîê
  216. clm = Selection.Columns.Count   'Êîë-âî âûáðàííûõ ñòîëáöîâ
  217. sql_start = ""
  218.  
  219. For Each c In Selection.Cells       ' Öèêë ïî âûáðàííûì ÿ÷åéêàì
  220. If poz_c = 0 And check = 0 Then     ' Åñëè ïåðâàÿ ñòðîêà
  221. sql_start = sql_start & "values ("
  222. End If
  223. If poz_c = 0 And check <> 0 Then    'Åñëè íîâàÿ ñòðîêà, íî íå ïåðâàÿ
  224. sql_start = sql_start & ", ("
  225. End If
  226.  
  227.    poz_c = poz_c + 1
  228.    check = check + 1
  229.    If poz_c <> clm Then
  230.    
  231.     sql = c.Cells(1, 1).Value
  232.         If IsNumeric(c.Cells(1, 1).Value) Then  'Åñëè çíà÷åíèå ÷èñëîâîå, ìåíÿåì çàðÿòóþ íà òî÷êó
  233.             sql = Replace(sql, ",", ".")
  234.         End If
  235.        
  236.         If IsDate(c.Cells(1, 1).Value) Then  'Åñëè çíà÷åíèå äàòû, ìåíÿåì ôîðìàò äëÿ sql
  237.             sql = Format(sql, "yyyy-mm-dd")
  238.         End If
  239.     sql_start = sql_start & "'" & sql & "',"
  240.     Else
  241.     poz_c = 0
  242.     sql = c.Cells(1, 1).Value
  243.         If IsNumeric(c.Cells(1, 1).Value) Then   'Åñëè çíà÷åíèå ÷èñëîâîå, ìåíÿåì çàðÿòóþ íà òî÷êó
  244.     sql = Replace(sql, ",", ".")
  245.         End If
  246.         If IsDate(c.Cells(1, 1).Value) Then  'Åñëè çíà÷åíèå äàòû, ìåíÿåì ôîðìàò äëÿ sql
  247.             sql = Format(sql, "yyyy-mm-dd")
  248.         End If
  249.     sql_start = sql_start & "'" & sql & "')" & vbNewLine
  250.     End If
  251.  
  252. Next
  253. 'MsgBox sql_start
  254. ' d.SetText strTest
  255.  
  256.  Clp.SetText (sql_start)
  257.     Clp.PutInClipboard
  258.  
  259. End Sub
  260.  
  261.  
  262. Public Sub create_table_sql()
  263.  
  264. ' äëÿ òîãî, ÷òîáû ðàáîòàòü ñ áóôåðîì
  265. ' â ðåäàêòîð êîäà ... ìåíþ - tools->references ... â äèàëîãå êëèê ïî êíîïêå browse ...
  266. ' íàõîäèì fm20.dll â ïàïêå system32 ... îòêðûòü ... â ñïèñêå äîëæíî äîáàâèòüñÿ ...
  267. ' ìàêðîñîôò ôîðìñ 2.0 ëèáðàðè îáúåêò ... ñòàâèì ãàëî÷êó (õîòÿ îíà äîëæíà ïîñòàâèòüñÿ ñàìà) ... îê
  268. Dim Clp As New DataObject
  269. Dim sql As String
  270. Dim c As Range
  271. Dim sql_start As Variant
  272. Dim clm As Integer
  273. Dim poz_c As Integer
  274. Dim cel As Integer
  275. Dim Db As String, t_n As String
  276. Set Clp = New DataObject  'Äëÿ ðàáîòû ñ áóôåðîì
  277. poz_c = 0       'ñ÷åò÷èê äëÿ îïðåäåëåíèÿ íîâîé ñòðîêè
  278. Db = InputBox("Ââåäèòå èìÿ ÁÄ:", "ÈÌß ÁÄ")
  279. t_n = InputBox("Ââåäèòå èìÿ òàáëèöû:", "ÈÌß ÒÀÁËÈÖÛ")
  280. clm = Selection.Columns.Count   'Êîë-âî âûáðàííûõ ñòîëáöîâ
  281.  
  282. sql_start = "create table " & Db & ".dbo." & t_n & vbNewLine & " (" & vbNewLine
  283.  
  284. For Each c In Selection.Columns       ' Öèêë ïî âûáðàííûì ÿ÷åéêàì
  285. poz_c = poz_c + 1
  286.     sql = c.Cells(1, 1).Value
  287.    
  288.    
  289.    
  290.    If poz_c <> clm And poz_c <> 1 Then
  291.            
  292.             If IsNumeric(c.Cells(2, 1).Value) Then  'Åñëè çíà÷åíèå ÷èñëîâîå, òèï äàííûõ decimal (18,2)
  293.                 If (c.Cells(2, 1).Value) = CInt(c.Cells(2, 1).Value) Then
  294.                  sql = ", " & sql & " int" & vbNewLine
  295.                     Else
  296.                 sql = ", " & sql & " real" & vbNewLine
  297.                     End If
  298.             ElseIf IsDate(c.Cells(2, 1).Value) Then  'Åñëè çíà÷åíèå äàòû, òèï äàííûõ date
  299.                 sql = ", " & sql & " date" & vbNewLine
  300.                
  301.             Else: sql = ", " & sql & " nvarchar (64)" & vbNewLine
  302.             End If
  303.            
  304.     ElseIf poz_c = 1 Then
  305.            
  306.             If IsNumeric(c.Cells(2, 1).Value) Then  'Åñëè çíà÷åíèå ÷èñëîâîå, òèï äàííûõ decimal (18,2)
  307.                 If (c.Cells(2, 1).Value) = CInt(c.Cells(2, 1).Value) Then
  308.                  sql = "  " & sql & " int" & vbNewLine
  309.                     Else
  310.                 sql = "  " & sql & " real" & vbNewLine
  311.                     End If
  312.             ElseIf IsDate(c.Cells(2, 1).Value) Then  'Åñëè çíà÷åíèå äàòû, òèï äàííûõ date
  313.                 sql = "  " & sql & " date" & vbNewLine
  314.                
  315.             Else: sql = "  " & sql & " nvarchar (64)," & vbNewLine
  316.             End If
  317.            
  318.     Else:
  319.                If IsNumeric(c.Cells(2, 1).Value) Then  'Åñëè çíà÷åíèå ÷èñëîâîå, òèï äàííûõ decimal (18,2)
  320.                 sql = ", " & sql & " real" & vbNewLine & ")"
  321.                    
  322.             ElseIf IsDate(c.Cells(2, 1).Value) Then  'Åñëè çíà÷åíèå äàòû, òèï äàííûõ date
  323.                 sql = ", " & sql & " date" & vbNewLine & ")"
  324.                
  325.             Else: sql = ", " & sql & " nvarchar (64)" & vbNewLine & ")"
  326.             End If
  327.     End If
  328. sql_start = sql_start & sql
  329. Next
  330. 'MsgBox sql_start
  331. ' d.SetText strTest
  332.  
  333.  Clp.SetText (sql_start)
  334.     Clp.PutInClipboard
  335.  
  336. End Sub
  337.  
  338.  
  339.  
  340. 'äîáàâëåíèå êíîïêè
  341. Function Add_Control(ByRef Comm_Bar, ByVal ControlType As CONTROL_TYPES, ByVal B_Face As Integer, _
  342.                      ByVal On_Action As String, ByVal B_Caption As String, _
  343.                      Optional ByVal Button_Style As MsoButtonStyle = msoButtonIcon, _
  344.                      Optional ByVal Begin_Group As Boolean = False, _
  345.                      Optional Tag As String = "") As CommandBarControl
  346.     ' äîáàâëÿåò êîíòðîëû â ìåíþ Comm_Bar, âîçâðàùàåò ññûëêó íà ñîçäàííûé ïóíêò ìåíþ
  347.     On Error Resume Next
  348.     Set Add_Control = Comm_Bar.Controls.Add(Type:=ControlType, Temporary:=True)    ' ñîçäà¸ì íîâûé êîíòðîë
  349.     With Add_Control
  350.         If B_Face > 0 And ControlType = ct_BUTTON Then .FaceId = B_Face    ' íàçíà÷àåì êíîïêå èêîíêó
  351.         .Tag = Tag: .OnAction = On_Action: .Caption = B_Caption    ' ïàðàìåòðû êîíòðîëà
  352.         .BeginGroup = Begin_Group    ' äîáàâëÿåì ðàçäåëèòåëü (ïðè íåîáõîäèìîñòè)
  353.         If ControlType = ct_BUTTON Then .Style = Button_Style
  354.     End With
  355. End Function
  356.  
  357. 'ïîëó÷åíèå ïàíåëè èíñòðóìåíòîâ
  358. Function GetCommandBar(ByVal CommandBarName As String, Optional ByVal Clean As Boolean = False, _
  359.                        Optional ByVal Position As MsoBarPosition = msoBarFloating) As CommandBar
  360.     On Error Resume Next: Err.Clear
  361.     ' ïîëó÷àåì ññûëêó íà ïîëüçîâàòåëüñêóþ ïàíåëü èíñòðóìåíòîâ
  362.     Set GetCommandBar = Application.CommandBars(CommandBarName)
  363.     If Err.Number Then    ' åñëè ïàíåëü íå íàéäåíà - ñîçäà¸ì å¸
  364.         Set GetCommandBar = Application.CommandBars.Add(CommandBarName, Position, False, True)
  365.     End If
  366.     If Clean Then    ' ïåðåáèðàåì íà íåé âñå ýëåìåíòû, è óäàëÿåì èõ
  367.         For Each cbc In GetCommandBar.Controls: cbc.Delete: Next
  368.     End If
  369.     GetCommandBar.Visible = True    ' îòîáðàæàåì ïàíåëü èíñòðóìåíòîâ
  370. End Function
  371.  
  372. 'óäàëåíèå ïàíåëè èíñòðóìåíòîâ
  373. Sub KickWorkPanel()
  374.     GetCommandBar PROJECT_NAME, True
  375. End Sub
  376.  
  377. 'ñîçäàíèå ïàíåëè èíñòðóìåíòîâ
  378. Sub CreateWorkPanel()
  379.  
  380.     On Error Resume Next: Application.ScreenUpdating = False
  381.     ' ïîëó÷àåì ññûëêó íà ïîëüçîâàòåëüñêóþ ïàíåëü èíñòðóìåíòîâ
  382.     Set AddinMenu = GetCommandBar(PROJECT_NAME, True)
  383.  
  384.     ' äîáàâëåíèå íîâûõ ýëåìåíòîâ óïðàâëåíèÿ íà ïàíåëü
  385.     Add_Control AddinMenu, ct_BUTTON, 1099, "mainSubtotals.KillSubtotals", "Óáðàòü èòîãè", msoButtonIconAndCaption, True
  386.     Add_Control AddinMenu, ct_BUTTON, 1087, "mainSubtotals.ListForSqlQuery", "Cêîïèðîâàòü äëÿ SQL", msoButtonIconAndCaption, True
  387.     Add_Control AddinMenu, ct_BUTTON, 24, "mainSubtotals.CreateOutlook", "Ñîçäàòü ñîîáùåíèå", msoButtonIconAndCaption, True
  388.     Add_Control AddinMenu, ct_BUTTON, 1104, "mainSubtotals.CreateOutlookMail", "Îòïðàâèòü ñîîáùåíèå", msoButtonIconAndCaption, True
  389.     Add_Control AddinMenu, ct_BUTTON, 258, "mainSubtotals.InsertInOutlook", "Âëîæèòü ôàéë â ïèñüìî", msoButtonIconAndCaption, True
  390.     Add_Control AddinMenu, ct_BUTTON, 280, "mainSubtotals.ScreenShot", "Ñêðèíøîò îáëàñòè", msoButtonIconAndCaption, True
  391.     Add_Control AddinMenu, ct_BUTTON, 51, "mainSubtotals.copy_insert_sql", "Âñòàâèòü â SQL", msoButtonIconAndCaption, True
  392.     Add_Control AddinMenu, ct_BUTTON, 52, "mainSubtotals.create_table_sql", "Ñîçäàòü òàáëèöó SQL", msoButtonIconAndCaption, True
  393.  
  394.  
  395.  
  396. End Sub
  397.  
  398.  
  399.  

Share with your friends:

Print