Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1037
  • Last Modified:

Excel: VB -> Delphi Conversion

I basically want this function converted from VB to Delphi. The data from the VB version is coming from SQL, the delphi
one will come from a TList. so that part can be ignored or replaced with something like MyList(list[i]).Item1);

Public Sub ExportTQC(intMode As Integer)
On Error GoTo HandleError 'Resume Next
'intMode = 1 All Info
'intMode = 2 AD Info...no cell numbers
'intMode = 2 All Info sort by dept

Dim rst As ADODB.Recordset

Dim sSQL As String
Dim sMsg As String

Dim strFax() As String
Dim strConf() As String
Dim strOther() As String

Dim appExcel As Excel.Application
Dim wbkNew As Excel.Workbook
Dim wksNew As Excel.Worksheet

Dim iCounter As Long
Dim iFldCount As Long
Dim i As Integer, j As Long
Dim lColumnCount As Long

Dim sRootPath As String
Dim sFileName As String
Dim sScriptFileName As String
Dim sExcelFileName As String
Dim sExcelFileAndPath As String
Dim sSQLString As String

Dim strRange As String
Dim strEndColumn As String
Dim lBackcolor As Long
Const vbLightBlue = 16777164
Const xlLightBlue = 37

    Set appExcel = Excel.Application
    Set wbkNew = appExcel.Workbooks.Add
    Set wksNew = appExcel.Worksheets("Sheet1")
   
    wbkNew.Sheets("Sheet1").Name = "TQC Directory"
    Application.DisplayAlerts = False
    wbkNew.Sheets("Sheet2").Delete
    wbkNew.Sheets("Sheet3").Delete
    Application.DisplayAlerts = True
   
    wbkNew.Protect "tqc123", True, False
   
    Select Case intMode
        Case 1
            sExcelFileAndPath = iQSettings.AllStaff & "TQC Directory.xls"
            lColumnCount = 6
            strEndColumn = "G"
            sSQLString = "SP_GetTQCActive"
        Case 2
            sExcelFileAndPath = iQSettings.AllStaff & "TQC DirectoryAD.xls"
            lColumnCount = 5
            strEndColumn = "F"
            sSQLString = "SP_GetTQCActiveAD"
       Case 3
            sExcelFileAndPath = iQSettings.AllStaff & "TQC DirectoryDept.xls"
            lColumnCount = 6
            strEndColumn = "G"
            sSQLString = "usp_GetTQCActiveByDept"
    End Select
   
    Set rst = CreateRecordSet(sSQLString)
   
    iFldCount = rst.Fields.Count

    With wksNew
        .Cells.Font.Name = "Arial"
        .Cells.Font.Size = 8
        .Cells.Font.Strikethrough = False
        .Cells.Font.Superscript = False
        .Cells.Font.Subscript = False
        .Cells.Font.OutlineFont = False
        .Cells.Font.Shadow = False
        .Cells.Font.Underline = xlUnderlineStyleNone
        .Cells.Font.ColorIndex = xlAutomatic
       
        .Rows("2:2").Select
        ActiveWindow.FreezePanes = True
       
        ActiveSheet.PageSetup.PrintTitleRows = "$1:$1"
        ActiveSheet.PageSetup.PrintTitleColumns = ""

        .Rows("1:1").Select
        Selection.Font.Bold = True
       
        'ActiveSheet.PageSetup.PrintArea = ""
        .PageSetup.LeftHeader = "TQC Directory"
        .PageSetup.CenterHeader = ""
        .PageSetup.RightHeader = ""
        .PageSetup.LeftFooter = "&D"
        .PageSetup.CenterFooter = ""
        .PageSetup.RightFooter = "&P of &N"
           
        .PageSetup.LeftMargin = 48
        .PageSetup.RightMargin = 36
        .PageSetup.TopMargin = 36
        .PageSetup.BottomMargin = 54
        .PageSetup.HeaderMargin = 18
        .PageSetup.FooterMargin = 18
           
        .PageSetup.PrintHeadings = False
        .PageSetup.PrintGridlines = False
        .PageSetup.PrintComments = xlPrintNoComments
        .PageSetup.PrintQuality = 600
        .PageSetup.CenterHorizontally = True
        .PageSetup.CenterVertically = False
        .PageSetup.Draft = False
        .PageSetup.FirstPageNumber = xlAutomatic
        .PageSetup.Order = xlDownThenOver
        .PageSetup.BlackAndWhite = False
        .PageSetup.Zoom = 90
        .PageSetup.Orientation = xlLandscape
       
       
        ' Create column headers
        For i = 0 To lColumnCount
'            If intMode = 2 And i = 3 Then
'                .Cells(1, i + 1).Value = ""
'                GoTo SkipToNext
'            End If
            If InStr(1, rst.Fields(i).Name, "zip") > 0 Then
                .Cells.NumberFormat = "@"
                .Cells(1, i + 1).Value = Format(CStr(rst.Fields(i).Name), "00000")
            Else
                .Cells.NumberFormat = "@"
                .Cells(1, i + 1).Value = rst.Fields(i).Name
            End If
'SkipToNext:
        Next

        strRange = "A1:" & strEndColumn & "1"
       
        .Range(strRange).Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Range(strRange).Borders(xlEdgeBottom).Weight = xlThin
        .Range(strRange).Borders(xlEdgeBottom).ColorIndex = xlAutomatic

        ' Data starts on 3rd row
        j = 2
   
        ' Loop through recordset adding rows to Excel
        Do Until rst.EOF
       
            strRange = "A" & CStr(j) & ":" & strEndColumn & CStr(j)
           
            lBackcolor = xlLightBlue
            If rst.Fields("FlagRecord") = 0 Then lBackcolor = xlNone
            .Range(strRange).Interior.ColorIndex = lBackcolor
           
            If (j - 1) Mod 5 = 0 Then
                .Range(strRange).Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Range(strRange).Borders(xlEdgeBottom).Weight = xlThin
                .Range(strRange).Borders(xlEdgeBottom).ColorIndex = xlAutomatic
            Else
                .Range(strRange).Borders(xlEdgeBottom).LineStyle = xlNone
            End If
           
            For i = 0 To lColumnCount
'                If intMode = 2 And i = 3 Then
'                    .Cells(j, i + 1).Value = ""
'                Else
                    .Cells(j, i + 1).Value = rst.Fields(i).Value
'                End If
            Next
                   
            j = j + 1
            rst.MoveNext
        Loop
       
        .Cells.Select
        .Cells.EntireColumn.AutoFit
        .Range("A1").Select
       
'======================
'set up special numbers
'======================
Dim intX As Integer
Dim intRootJ As Integer
       
        j = j + 1
        .Cells(j, 1) = "FAX NUMBERS"
        .Cells(j, 4) = "CONFERENCE ROOMS"
        .Cells(j, 6) = "OTHER NUMBERS"
       
        strRange = "A" & j & ":F" & j
        .Range(strRange).Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Range(strRange).Borders(xlEdgeBottom).Weight = xlThin
        .Range(strRange).Borders(xlEdgeBottom).ColorIndex = xlAutomatic
        .Range(strRange).Font.Bold = True
       
        intRootJ = j
        Set rst = New ADODB.Recordset
        Set rst = CreateRecordSet("SP_GetTQCSpecialNumbers 1") 'fax numbers
        ReDim strFax(rst.RecordCount)
        intX = 0
        Do While rst.EOF = False
            intX = intX + 1
            strFax(intX) = rst.Fields("string_label") & " " & rst.Fields("string")
            .Cells(j + intX, 1) = strFax(intX)
            rst.MoveNext
        Loop
               
        Set rst = New ADODB.Recordset
        Set rst = CreateRecordSet("SP_GetTQCSpecialNumbers 2") 'conf numbers
        ReDim strConf(rst.RecordCount)
        intX = 0
        Do While rst.EOF = False
            intX = intX + 1
            strConf(intX) = rst.Fields("string_label") & " " & rst.Fields("string")
            .Cells(j + intX, 4) = strConf(intX)
            rst.MoveNext
        Loop
               
        Set rst = New ADODB.Recordset
        Set rst = CreateRecordSet("SP_GetTQCSpecialNumbers 3") 'other numbers
        ReDim strOther(rst.RecordCount)
        intX = 0
        Do While rst.EOF = False
            intX = intX + 1
            strOther(intX) = rst.Fields("string_label") & " " & rst.Fields("string")
            .Cells(j + intX, 6) = strOther(intX)
            rst.MoveNext
        Loop
               
        .Protect Password:="tqc123", DrawingObjects:=False, Contents:=True, Scenarios:=False

    End With
   
    appExcel.Visible = True
   
On Error GoTo HandleError
   
    KillFile (sExcelFileAndPath)
    wbkNew.Protect "tqc123", True, False
    wbkNew.SaveAs FileName:=sExcelFileAndPath
ShowTQC:
    appExcel.DisplayFullScreen = True
    appExcel.DisplayFullScreen = False
    If Not wksNew Is Nothing Then
        wksNew.Select
    End If
KillObjects:
    Set rst = Nothing

    ' Cleanup Excel objects
    Set wksNew = Nothing
    Set wbkNew = Nothing
    Set appExcel = Nothing
Exit Sub

HandleError:
If Err.Number = 1004 Then
    MsgBox "The file cannot be copied to the network location. A user on the network has the file opened." & vbCr & "The TQC File needs to be saved manually by you.", vbOKOnly
    GoTo ShowTQC
Else
    MsgBox "The following error occured:" & vbCr & Err.Description & vbCr & Err.Number
End If
GoTo KillObjects

End Sub


0
gwarguitar
Asked:
gwarguitar
  • 4
  • 3
1 Solution
 
Pierre CorneliusCommented:
Where does the recordset you create come from? Excel? Access? Other?
0
 
gwarguitarAuthor Commented:
It comes from activeDirectory actually. i just store it in a tlist.
0
 
Pierre CorneliusCommented:
Sorry, I need more information. I don't have experience working with ActiveDirectory.

I have already converted most of the code, but am stuck on the dataset to be used.

Do you already have the data you want to save to excel in the TList? My understanding is that a TList merely stores a list of pointers and is used to maintain lists of objects. Where are the fieldcount, fieldnames (for column headings) and field values coming from?

0
Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
gwarguitarAuthor Commented:
Yeah, I store my fieldnames in the tlist.

it is formatted like this..

type
  TUserInfo = class
  private
    Ffirst_name : string;
    Flast_name  : string;
    Fdid_ext    : string;
    Fdirect_no  : string;
    Fmobile_no  : string;
    Ftitle      : string;
    Fmail_addr  : string;
    Fdepartment : string;
    Foffice     : string;
    Fvalid      : integer;
  public
      property first_name : string
          read Ffirst_name;
      property last_name : string
          read Flast_name;
      property did_ext : string
          read Fdid_ext;
      property direct_no : string
          read Fdirect_no;
      property mobile_no : string
          read Fmobile_no;
      property title : string
          read Ftitle;
      property mail_addr : string
          read Fmail_addr;
      property department : string
          read Fdepartment;
      property office : string
          read Foffice;
      property valid : integer
          read Fvalid;
  end;

So the dataset you don't really have to worry about, it is more just the core excel code.
Like highlighting the rows, freezing the panes, adding special numbers on the bottom, etc...


basically it needs to look like this..

www.rev23.com/xls.gif

don't even worry about the modes and stuff.. i can figure that all out.


0
 
Pierre CorneliusCommented:
Herewith full working demo:

~~~~~~~~~
Source
~~~~~~~~~
unit main;

interface

uses
  Windows, SysUtils, Variants, Forms, ExcelXP, Classes, Controls, StdCtrls;

type
  PUserInfo = ^TUserInfo;
  TUserInfo = record
    Ffirst_name : ShortString;
    Flast_name  : ShortString;
    Fdid_ext    : ShortString;
    Fdirect_no  : ShortString;
    Fmobile_no  : ShortString;
    Ftitle      : ShortString;
    Fmail_addr  : ShortString;
    Fdepartment : ShortString;
    Foffice     : ShortString;
    Fvalid      : integer;
  end;

  PSpecialNums = ^TSpecialNums;
  TSpecialNums = record
    FaxNum  : ShortString;
    ConfRoom: ShortString;
    OtherNum: ShortString;
  end;


  TForm1 = class(TForm)
    btnExport: TButton;
    procedure btnExportClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    UserInfo: TList;
    SpecialNums: TList;
  end;

  procedure ExportTQC(intMode: Integer; rst, SpecNums: TList);
var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure ExportTQC(intMode: Integer; rst, SpecNums: TList);
Const vbLightBlue = 16777164;
      xlLightBlue = 37;
      xlWorksheet = -4167;

var lcid: integer;
    appExcel: TExcelApplication;
    wbkNew: TExcelWorkbook;
    wksNew: TExcelWorksheet;
    r: ExcelRange;
    i, j, lBackcolor: integer;
begin
  lcid:= GetUserDefaultLCID;;

  appExcel:= TExcelApplication.Create(nil);   //  Set appExcel = Excel.Application
  wbkNew:= TExcelWorkbook.Create(nil);
  wksNew:= TExcelWorksheet.Create(nil);
  wbkNew.ConnectTo(appExcel.Workbooks.Add(LongWord(xlWBATWorksheet), lcid)); //  Set wbkNew = appExcel.Workbooks.Add
  wksNew.ConnectTo(wbkNew.Worksheets[1] as _Worksheet);
  wksNew.Name:= 'TQC Directory';

  wbkNew.Protect('tqc123', True, False);

    With wksNew do
    begin
      Cells.Font.Name := 'Arial';
      Cells.Font.Size := 8;
      Cells.Font.Strikethrough := False;
      Cells.Font.Superscript := False;
      Cells.Font.Subscript := False;
      Cells.Font.OutlineFont := False;
      Cells.Font.Shadow := False;
      Cells.Font.Underline := xlUnderlineStyleNone;
      Cells.Font.ColorIndex := xlAutomatic;

      Rows.Range['A2','A2'].Select;
      appExcel.ActiveWindow.FreezePanes := True;
      PageSetup.PrintTitleRows   := '$1:$1';
      PageSetup.PrintTitleColumns:= '';

      //TEMP Rows.Range['1','1'].Select;
      Rows.Range['A1','A1'].EntireRow.Font.Bold:= true; //Selection.Font.Bold := True

      //ActiveSheet.PageSetup.PrintArea := ""
      PageSetup.LeftHeader   := 'TQC Directory';
      PageSetup.CenterHeader := '';
      PageSetup.RightHeader  := '';
      PageSetup.LeftFooter   := '&D';
      PageSetup.CenterFooter := '';
      PageSetup.RightFooter  := '&P of &N';

      PageSetup.LeftMargin   := 48;
      PageSetup.RightMargin  := 36;
      PageSetup.TopMargin    := 36;
      PageSetup.BottomMargin := 54;
      PageSetup.HeaderMargin := 18;
      PageSetup.FooterMargin := 18;

      PageSetup.PrintHeadings  := False;
      PageSetup.PrintGridlines := False;
      PageSetup.PrintComments  := xlPrintNoComments;
      PageSetup.PrintQuality[EmptyParam] := 600;
      PageSetup.CenterHorizontally:= True;
      PageSetup.CenterVertically  := False;
      PageSetup.Draft             := False;
      PageSetup.FirstPageNumber   := xlAutomatic;
      PageSetup.Order             := xlDownThenOver;
      PageSetup.BlackAndWhite     := False;
      PageSetup.Zoom              := 90;
      PageSetup.Orientation       := xlLandscape;

      // Create column headers
      Range['A1','A1'].Value2:= 'Name';
      Range['B1','B1'].Value2:= 'DID(Ext)';
      Range['C1','C1'].Value2:= 'Direct';
      Range['D1','D1'].Value2:= 'Cell Phone';
      Range['E1','E1'].Value2:= 'Title';
      Range['F1','F1'].Value2:= 'Email';
      Range['G1','G1'].Value2:= 'Department';

      with Range['A1','g1'] do
      begin
        Borders[xlEdgeBottom].LineStyle := xlContinuous;
        Borders[xlEdgeBottom].Weight := xlThin;
        Borders[xlEdgeBottom].ColorIndex := xlAutomatic;
      end;

      // Data starts on 3rd row
      j := 2;

      // Loop through recordset adding rows to Excel
      for i:= 0 to rst.Count-1 do
      begin
        lBackcolor := xlLightBlue;
        If PUserInfo(rst[i]).Fvalid = 0
          Then lBackcolor := xlNone;
        r:= Range['A' + IntToStr(j), 'G' + IntToStr(j)];
        r.Interior.ColorIndex := lBackcolor;

            If (j - 1) Mod 5 = 0 Then
            begin
              r.Borders[xlEdgeBottom].LineStyle := xlContinuous;
              r.Borders[xlEdgeBottom].Weight := xlThin;
              r.Borders[xlEdgeBottom].ColorIndex := xlAutomatic;
            end
            else r.Borders[xlEdgeBottom].LineStyle := xlNone;

        Range['A'+IntToStr(j),'A'+IntToStr(j)].Value2:=
          PUserInfo(rst[i]).Flast_name+', '
          +PUserInfo(rst[i]).Ffirst_name;

        Range['B'+IntToStr(j),'B'+IntToStr(j)].Value2:=
          PUserInfo(rst[i]).Fdid_ext;

        Range['C'+IntToStr(j),'C'+IntToStr(j)].Value2:=
          PUserInfo(rst[i]).Fdirect_no;

        Range['D'+IntToStr(j),'D'+IntToStr(j)].Value2:=
          PUserInfo(rst[i]).Fmobile_no;

        Range['E'+IntToStr(j),'E'+IntToStr(j)].Value2:=
          PUserInfo(rst[i]).Ftitle;

        Range['F'+IntToStr(j),'F'+IntToStr(j)].Value2:=
          PUserInfo(rst[i]).Fmail_addr;

        Range['G'+IntToStr(j),'G'+IntToStr(j)].Value2:=
          PUserInfo(rst[i]).Fdepartment;

        j := j + 1;
      end;

      Range['A1', 'G'+IntToStr(j)].Columns.AutoFit;

      //======================
      //set up special numbers
      //======================

      j := j + 1;
      Range['A'+IntToStr(j), 'A'+IntToStr(j)].Value2 := 'FAX NUMBERS';
      Range['D'+IntToStr(j), 'D'+IntToStr(j)].Value2 := 'CONFERENCE ROOMS';
      Range['E'+IntToStr(j), 'E'+IntToStr(j)].Value2 := 'OTHER NUMBERS';

      r:= Range['A'+IntToStr(j),'F'+IntTostr(j)];
      r.Borders[xlEdgeBottom].LineStyle := xlContinuous;
      r.Borders[xlEdgeBottom].Weight := xlThin;
      r.Borders[xlEdgeBottom].ColorIndex := xlAutomatic;
      r.Font.Bold := True;

      j := j + 1;
      For i:= 0 to SpecNums.Count-1 do
      begin
        Range['A'+IntToStr(j), 'A'+IntToStr(j)].Value2 :=
          PSpecialNums(SpecNums[i]).FaxNum;
        Range['D'+IntToStr(j), 'D'+IntToStr(j)].Value2 :=
          PSpecialNums(SpecNums[i]).ConfRoom;
        Range['F'+IntToStr(j), 'F'+IntToStr(j)].Value2 :=
          PSpecialNums(SpecNums[i]).OtherNum;
        j:= j+1;
      end;

      Protect('tqc123', False, True, False);

      appExcel.Visible[lcid]:= true;
    end;

  wksNew.Free;
  wbkNew.Free;
  appExcel.Quit;
  appExcel.Disconnect;
  appExcel.Free;
end;

procedure TForm1.btnExportClick(Sender: TObject);
begin
  ExportTQC(1, UserInfo, SpecialNums);
end;

procedure TForm1.FormCreate(Sender: TObject);
var d: PUserInfo;
    n: PSpecialNums;
begin
  inherited;
  UserInfo:= TList.Create;
  SpecialNums:= TList.Create;

  new(d);
  d.Ffirst_name:= 'Allan';
  d.Flast_name:= 'Anwey';
  d.Fdid_ext:= '123';
  d.Fdirect_no:= '123-4567';
  d.Fmobile_no:= '083 123 4567';
  d.Ftitle:= 'Mr.';
  d.Fmail_addr:= 'aa@blah.com';
  d.Fdepartment:= 'Sales & Marketing';
  d.Foffice:= 'JHB';
  d.Fvalid:= 0;
  UserInfo.Add(d);

  new(d);
  d.Ffirst_name:= 'Brian';
  d.Flast_name:= 'Baxter';
  d.Fdid_ext:= '456';
  d.Fdirect_no:= '011-89567';
  d.Fmobile_no:= '083 456 4567';
  d.Ftitle:= 'Mr.';
  d.Fmail_addr:= 'bb@blah.com';
  d.Fdepartment:= 'Admin';
  d.Foffice:= 'PTA';
  d.Fvalid:= 1;
  UserInfo.Add(d);

  New(n);
  n.FaxNum  := '123 456 7890';
  n.ConfRoom:= 'Monroe Room';
  n.OtherNum:= '011 123 4569';
  SpecialNums.Add(n);

  New(n);
  n.FaxNum  := '123 456 7891';
  n.ConfRoom:= 'Sinatra Room';
  n.OtherNum:= '011 555 1234';
  SpecialNums.Add(n);
end;

procedure TForm1.FormDestroy(Sender: TObject);
var i: integer;
begin
  for i:= 0 to UserInfo.Count-1 do
    Dispose(PUserInfo(UserInfo[i]));

  for i:= 0 to UserInfo.Count-1 do
    Dispose(PSpecialNums(SpecialNums[i]));

  SpecialNums.Free;
  UserInfo.Free;
  inherited;
end;

end.


~~~~~~~~~
DFM Source
~~~~~~~~~
object Form1: TForm1
  Left = 192
  Top = 114
  Width = 261
  Height = 100
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object btnExport: TButton
    Left = 56
    Top = 24
    Width = 121
    Height = 25
    Caption = 'Export to Excel'
    TabOrder = 0
    OnClick = btnExportClick
  end
end

Kind regards
Pierre Cornelius
0
 
gwarguitarAuthor Commented:
woohoo! that will get me goin. thanks a lot pierre.
0
 
Pierre CorneliusCommented:
Glad I could help.
0

Featured Post

[Webinar On Demand] Database Backup and Recovery

Does your company store data on premises, off site, in the cloud, or a combination of these? If you answered “yes”, you need a data backup recovery plan that fits each and every platform. Watch now as as Percona teaches us how to build agile data backup recovery plan.

  • 4
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now