Solved

Excel: VB -> Delphi Conversion

Posted on 2004-08-30
7
987 Views
Last Modified: 2010-04-16
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
Comment
Question by:gwarguitar
  • 4
  • 3
7 Comments
 
LVL 14

Expert Comment

by:Pierre Cornelius
ID: 11936610
Where does the recordset you create come from? Excel? Access? Other?
0
 

Author Comment

by:gwarguitar
ID: 11936628
It comes from activeDirectory actually. i just store it in a tlist.
0
 
LVL 14

Expert Comment

by:Pierre Cornelius
ID: 11937521
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
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 

Author Comment

by:gwarguitar
ID: 11942371
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
 
LVL 14

Accepted Solution

by:
Pierre Cornelius earned 400 total points
ID: 11943649
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
 

Author Comment

by:gwarguitar
ID: 11945151
woohoo! that will get me goin. thanks a lot pierre.
0
 
LVL 14

Expert Comment

by:Pierre Cornelius
ID: 11945438
Glad I could help.
0

Featured Post

Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

Join & Write a Comment

Have you ever had your Delphi form/application just hanging while waiting for data to load? This is the article to read if you want to learn some things about adding threads for data loading in the background. First, I'll setup a general applica…
Introduction Raise your hands if you were as upset with FireMonkey as I was when I discovered that there was no TListview.  I use TListView in almost all of my applications I've written, and I was not going to compromise by resorting to TStringGrid…
This video discusses moving either the default database or any database to a new volume.
This video explains how to create simple products associated to Magento configurable product and offers fast way of their generation with Store Manager for Magento tool.

762 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now