powered by simpleCommunicator - 2.0.52     © 2025 Programmizd 02
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Export msflexgrid to excell
6 сообщений из 6, страница 1 из 1
Export msflexgrid to excell
    #38721724
kiv-1980
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
Доброго,


Есть процедурка по экспорту msflexgrid'ов в excell, проблема заключается в следующем, не получается экспортировать 1-ую колонку, код не мой, частично подправленный мною под себя, перепробовал всё, но так и не получается передать в эксель первый столбец грида:

Код: vbnet
1.
FlexGrd_SaveToExcel MSFlexGrid1, , , 1, 16, App.Path & "\ms_masthead_10x7a_ltr.bmp", , , 37, 35, True



Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
Public Function FlexGrd_SaveToExcel(FG As MSFlexGrid, Optional sHeader As String = "", Optional sFooter As String = "", Optional ColumnHeaderFontColorIndex As Long, Optional ColumnHeaderBackColorIndex As Long, Optional CoLogoPicLocation As String, Optional WorkBkBackColorIndex As Long, Optional WorkBkGridColorIndex As Long, Optional AlternateRowColorIndex1 As Long, Optional AlternateRowColorIndex2 As Long, Optional AutoColumnFitter As Boolean)
  Static objExcelDel As Object
  Static objWorkbookDel As Excel.Workbook
  Static objWorksheetDel As Excel.Worksheet
  Static HeadRange    As Excel.Range
  Static NewRange As Excel.Range
  Static GridRange As Range
  Static PicObject As Excel.ShapeRange
  Dim lRow As Integer, lCol As Integer
  Dim i As Integer, j As Integer
  Dim C As Integer

  Dim rowOffset As Long
  Dim TempStr() As String

    Set objExcelDel = CreateObject("Excel.application")
    
  
  If Err.Number <> 0 Then
                Set objExcelDel = New Excel.Application
             
                    Err.Clear
            End If
        On Error Resume Next
            objExcelDel.Visible = False
  
  If Len(sHeader) >= 0 Then
    TempStr = Split(sHeader, vbTab)
    rowOffset = UBound(TempStr) + 1
  End If
  
  
  
  Set objWorkbookDel = objExcelDel.Workbooks.Add
        
        'Turn off the alerts
        objExcelDel.DisplayAlerts = False
            
        'Set objWorksheet to the remaining worksheet.
        Set objWorksheetDel = objExcelDel.ActiveSheet

  With objWorksheetDel
       
    ' Sheet Header
   
    For lRow = 1 To rowOffset
           .PageSetup.CenterHeader = TempStr(lRow - 1)
    Next lRow

    '************************
    ' Get Column Headers
    For lRow = 1 To FG.FixedRows
      For lCol = 1 To FG.Cols
        .Cells(4, lCol - 1) = FG.TextMatrix(lRow - 1, lCol - 1)
      Next lCol
    Next lRow
   
    Set HeadRange = objWorksheetDel.Range(objWorksheetDel.Cells(4, 1), _
                objWorksheetDel.Cells(4, lCol - 2))
    With HeadRange
        '*****Sets Column Header Back Color
        If Val(ColumnHeaderBackColorIndex) > 0 Then
            .Interior.ColorIndex = ColumnHeaderBackColorIndex
            Else
            ' My Default Background color for Column header index change it to what ever you want
            .Interior.ColorIndex = 5
            End If
         '************************************
        .Interior.Pattern = xlSolid
        .Interior.PatternColorIndex = 6
        .Interior.Pattern = xlLightHorizontal
        .Interior.ColorIndex = 20
        .Font.Name = "Rockwell"
        .Font.FontStyle = "Bold"
        .Font.Shadow = True
        '***** Sets Column header Font color*****
        If Val(ColumnHeaderFontColorIndex) > 0 Then
            .Font.ColorIndex = ColumnHeaderFontColorIndex
            Else
            ' My Default Font color for Column header index change it to what ever you want
            .Font.ColorIndex = 2
            End If
        .Font.Bold = True
        '************************************
        'Sets border colors of header. You could also add this
        'to the function but I thought I was getting carried away
        'as it was.
        
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 16  'grey
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 16
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 16
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 16
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 1 ' Black
        End With
    End With
    
    HeadRange = Nothing
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim RowCounter As Integer ' used for all alternate row color
    RowCounter = 0    ' ditto
   ' Dim ColCounter As Integer ' used for all alternate row color
   ' ColCounter = 0
    Dim G As Integer ' ditto
    Dim Alternate As Boolean  'ditto
    '''''''''''''''''''''''''''''''''''''''
    ' Fill excel sheet with data
    ' Row data from flexgrid
    For i = 1 To FG.Rows
       
        For j = 1 To FG.Cols
            objWorksheetDel.Cells(i + 4, j) = FG.TextMatrix(i, j)
            objWorksheetDel.Cells(i + 4, j + 1).VerticalAlignment = xlTop
        Next j
        RowCounter = RowCounter + 1
    Next i
    RowCounter = RowCounter - 1  ' Getting rid of extra row
    ''''''''''''''''''''''''''''''''''''''''''''''''
  
 
    ' Autofit columns
    If AutoColumnFitter = True Then
        .Columns.AutoFit
        End If
        '******************************************
 
    objWorksheetDel.OLEObjects
    
    
    ' Page Footer
    If Len(sFooter) > 0 Then
      TempStr = Split(sFooter, vbTab)
      For lRow = 0 To UBound(TempStr)
          .PageSetup.CenterFooter = TempStr(lRow)
      Next lRow
    End If
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

  End With
  objExcelDel.Visible = True
                       objExcelDel.DisplayAlerts = True
                       Set objWorksheetDel = Nothing
                       Set objWorkbookDel = Nothing
                       Set objExcelDel = Nothing
End Function

...
Рейтинг: 0 / 0
Export msflexgrid to excell
    #38721725
kiv-1980
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
Заранее благодарю за помощь.
...
Рейтинг: 0 / 0
Export msflexgrid to excell
    #38721726
Фотография Shocker.Pro
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
kiv-1980не получается экспортировать 1-ую колонку
первую? а может все-таки нулевую?
...
Рейтинг: 0 / 0
Export msflexgrid to excell
    #38721728
Фотография Shocker.Pro
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
Shocker.Prokiv-1980не получается экспортировать 1-ую колонку
первую? а может все-таки нулевую? а все дело в волшебной строке
Код: vbnet
1.
 On Error Resume Next

вы просто не видите возникающих ошибок, иначе сразу бы поняли, в чем дело
...
Рейтинг: 0 / 0
Export msflexgrid to excell
    #38722510
kiv-1980
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
Shocker.Pro,
Да, конечно нулевую, on error resume next закоментарил, код перестал работать, ошибка выскакивает Error load dll, пока не пойму где грабли.
...
Рейтинг: 0 / 0
Export msflexgrid to excell
    #38725332
kiv-1980
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
Проблему решил, переделал код, со старым кодом регулярно вис в процессах excel.exe, странно но со старым кодом проработал не один год, видимо так было мне нужно :), ниже всё переделано и работает, вдруг кому пригодится экспорт грида в Excel (осталось немного лишнего, но в принципе это не критично) и свою проблему собственно решил:
Код: vbnet
1.
FlexGrd_SaveToExcel MSFlexGrid1, , , 1, 16, , , , 0, 20, True



Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
Public Sub FlexGrd_SaveToExcel(FG As MSFlexGrid, Optional sHeader As String = "", Optional sFooter As String = "", Optional ColumnHeaderFontColorIndex As Long, Optional ColumnHeaderBackColorIndex As Long, Optional CoLogoPicLocation As String, Optional WorkBkBackColorIndex As Long, Optional WorkBkGridColorIndex As Long, Optional AlternateRowColorIndex1 As Long, Optional AlternateRowColorIndex2 As Long, Optional AutoColumnFitter As Boolean)
Dim objXL As Object, k, i
Dim objWb As Object
Dim objWs As Object
 
Set objXL = CreateObject("Excel.Application")
If objXL Is Nothing Then Exit Sub
 
objXL.SheetsInNewWorkbook = 1
Set objWb = objXL.Workbooks.Add
Set objWs = objWb.Worksheets(1)
 
objXL.Visible = False
  
With objWs
    Dim RowCounter As Integer, G ' used for all alternate row color
    RowCounter = 0    ' ditto
    
    For k = 0 To FG.Cols - 1
        For i = 0 To FG.Rows - 1
            .Cells(i + 4, k + 1) = FG.TextMatrix(i, k)
        Next i
        RowCounter = RowCounter + 1
    Next k
    RowCounter = FG.Rows - 1
    
    Set HeadRange = objWs.Range(objWs.Cells(4, 1), _
                objWs.Cells(4, FG.Cols))
    With HeadRange

        If Val(ColumnHeaderBackColorIndex) > 0 Then
            .Interior.ColorIndex = ColumnHeaderBackColorIndex
            Else
            ' My Default Background color for Column header index change it to what ever you want
            .Interior.ColorIndex = 16
            End If

        .Interior.Pattern = xlSolid
        .Interior.PatternColorIndex = 6
        .Interior.Pattern = xlLightHorizontal
        .Interior.ColorIndex = 20
        .Font.Name = "Rockwell"
        .Font.FontStyle = "Bold"
        .Font.Shadow = True

        If Val(ColumnHeaderFontColorIndex) > 0 Then
            .Font.ColorIndex = ColumnHeaderFontColorIndex
            Else
            ' My Default Font color for Column header index change it to what ever you want
            .Font.ColorIndex = 1
            End If
        .Font.Bold = True
        
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 16  'grey
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 16
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 16
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 16
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = 1 ' Black
        End With
    End With
    
    G = 0
    Do Until G = RowCounter ' RowCounter is figured when row data is taken
        Set NewRange = objWs.Range(objWs.Cells(G + 5, 1), _
            objWs.Cells(G + 5, FG.Cols))
 
        With NewRange
        If Alternate <> True Then
            .Interior.ColorIndex = AlternateRowColorIndex1 '&#231;&#224;&#228;&#237;&#232;&#233; &#244;&#238;&#237;
            .Borders.ColorIndex = 1
            'Sets font color either 1 Black or 2 white for row
            Select Case AlternateRowColorIndex1
                Case 1, 3, 5, 9, 11, 13, 14, 16, 17, 21, 23, 25
                    .Font.ColorIndex = 2
                Case Else
                    .Font.ColorIndex = 1
            End Select
            Alternate = True
           Else
            .Interior.ColorIndex = AlternateRowColorIndex2 '&#231;&#224;&#228;&#237;&#232;&#233; &#244;&#238;&#237;
            .Borders.ColorIndex = 1
            'Sets font color either 1 Black or 2 white
            Select Case AlternateRowColorIndex2
                Case 1, 3, 5, 9, 11, 13, 14, 16, 17, 21, 23, 25
                    .Font.ColorIndex = 2
                Case Else
                    .Font.ColorIndex = 1
            End Select
            Alternate = False
            End If
        End With
         G = G + 1
    Loop

    .Columns.AutoFit
End With
 
objXL.Visible = True
Set objWs = Nothing
Set objWb = Nothing
Set objXL = Nothing
End Sub

...
Рейтинг: 0 / 0
6 сообщений из 6, страница 1 из 1
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Export msflexgrid to excell
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Найденые пользователи ...
Разблокировать пользователей ...
Читали форум (0):
Пользователи онлайн (0):
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]